C$$$  MAIN PROGRAM DOCUMENTATION BLOCK
C
C MAIN PROGRAM: SYNDAT_SYNDATA
C   PRGMMR: DONG             ORG: NP22        DATE: 2020-01-09
C
C ABSTRACT: PERFORMS FOUR DISTINCT FUNCTIONS.  THE FIRST IS TO
C   GENERATE TYPE 110/210 TROPICAL CYCLONE BOGUS REPORTS IN THE
C   PREPBUFR FILE (ALTHOUGH ONLY TYPE 210 CAN CURRENTLY BE GENERATED)
C   ADDING BACKGROUND AND OBS. ERROR VALUES FOR THESE DATA.  THE SECOND
C   IS TO GENERATE TYPE 111 TROPICAL CYCLONE BOGUS REPORTS IN THE
C   PREPBUFR FILE ADDING BACKGROUND AND OBS. ERROR VALUES FOR THESE
C   DATA.  THE THIRD IS TO FLAG PRESSURE QUALITY MARKS ON ALL LEVELS
C   FOR MASS REPORTS SUFFICIENTLY CLOSE TO ALL STORMS CURRENTLY IN THE
C   TVCITALS LIST.  THE FOURTH IS TO FLAG WIND QUALITY MARKS ON ALL
C   LEVELS FOR DROPWINSONDE REPORTS SUFFICIENTLY CLOSE TO ALL STORMS
C   CURRENTLY IN THE TVCITALS LIST.  (SEE COMMENTS IN SUBROUTINE EDTPRP
C   FOR DEFINITION OF "SUFFICIENTLY CLOSE" - IT IS DETERMINED
C   DIFFERENTLY FOR MASS REPORT FLAGGING VS. DROPWINSONDE WIND REPORT
C   FLAGGING).  ANY ONE OR ALL OF THESE FUNCTIONS MAY BE PERFORMED
C   BASED ON USER-DEFINED SWITCHES IN EITHER THE STANDARD INPUT
C   NAMELIST, OR FOR DO_BOGUS, OBTAINED VIA CALL TO SYSTEM ROUTINE
C   GETENV.
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD - ORIGINAL AUTHOR
C 1997-09-03  S. J. LORD - UNDOCUMENTED CHANGE
C 1998-12-03  D. A. KEYSER - Y2K/F90 COMPLIANCE, STREAMLINED CODE;
C      ADDED SUBROUTINE "PREVENTS" TO PLACE BACKGROUND AND OBS.
C      ERROR FOR THESE DATA INTO PREPBUFR FILE (CURRENTLY
C      COMMENTED OUT BUT MAY BE USED ON IBM SP TO MAKE DATA
C      PROCESSING MORE EFFICIENT)
C 1999-02-05  D. A. KEYSER - MODIFIED ARGUMENT LIST IN ENTRY
C      "FAVWND" TO EXPLICITLY ADD VARIABLES "MODTYP" AND "JVBOG" -
C      ALTHOUGH THESE SHOULD BE SAVED IN GLOBAL MEMORY, A POSSIBLE
C      F90 BUG LED TO THEIR BEING LOST AFTER THE FIRST CALL TO THIS
C      ENTRY AND THIS CAUSED THE PROGRAM TO FAIL WHEN MORE THAN ONE
C      STORM WAS PROCESSED; CORRECTED MINOR DIFFERENCES DUE TO REAL
C      NUMBER PRECISION IN F90 VS. F77; CORRECTED ERROR IN
C      GENERATING MAXIMUM AND MINIMUM TIME DATE-TIME VALUES IN
C      ENTRY "HURPOS"; MODIFIED SOURCE TO ALLOW IT TO PORT TO THE
C      IBM SP MACHINE; FOR IBM SP-VERSION NOW CALLS SUBROUTINE
C      PREVENTS
C 1999-06-28  D. A. KEYSER - IN SUBR. SURPRP: MADE CODE MORE
C      EFFICIENT BY SKIPPING THE READING OF REPORTS OUT OF BUFR
C      MESSAGES WHICH CAN'T EVER PRODUCE A SEA-LEVEL PRESSURE OR
C      WIND; CORRECTED ERROR WHICH NEVER ALLOWED SURFACE MARINE SEA-
C      LEVEL PRESSURE TO BE USED HERE IN THE VICINITY OF STORM,
C      CORRECTED AN ERROR WHICH USUALLY LED TO 1000 MB PRESSURE/
C      HEIGHT NOT BEING USED HERE TO CALC. SEA-LEVEL PRESSURE IN THE
C      VICINITY OF STORM, NOW CHECKS QUALITY MARK OF PERTINENT
C      VARIABLES IN BOTH MEAN-SEA LEVEL PRESSURE PROCESSING AND WIND
C      PROCESSING FOR REPORTS IN THE VICINITY OF THE STORM - IF Q.M.
C      IS BAD SKIPS PROCESSING (NEVER CHECKED Q.M. BEFORE),
C      CORRECTED ERROR WHICH LED TO REPORT TIME MINUS CYCLE TIME
C      BEING A FACTOR OF 100 TOO SMALL (RESULTED IN INCORRECT STORM
C      ADJUSTMENT IN SUBR. SURPRP); IN SUBR. EDTPRP: MADE CODE MORE
C      EFFICIENT BY SKIPPING THE READING OF REPORTS OUT OF BUFR
C      MESSAGES WHICH NEVER CONTAIN MASS DATA OR NEVER CONTAIN
C      PRESSURE SINCE THESE DATA ARE NEVER EDITED BY THIS SUBROUTINE,
C      INSTEAD JUST COPIES SUCH MESSAGES DIRECTLY TO OUTPUT PREPBUFR
C      FILE; CORRECTED ERROR WHICH HAD RESULTED IN ONLY REPORTS IN
C      THE VICINITY OF THE FIRST STORM BEING SUBJECT TO EDITING
C      (PRESS. Q.M. FLAGGING); OUTPUT BOGUS REPORTS NOW HAVE UNIQUE
C      STNIDS; IN BOTH SUBR: STREAMLINED CODE TO MAKE IT MORE
C      EFFICIENT; ADDED DOCBLOCK, COMMENTS, AND MORE STDOUT PRINT;
C      MADE A SERIES OF CHANGES TO CORRECT ERRORS IN IBM VERSION;
C      REPLACED CALL TO SUBROUTINE "PREVENTS" WITH CALL TO W3LIB
C      ROUTINE "GBLEVENTS"; ADDED N-LIST SWITCH "PREVEN" WHICH, WHEN
C      FALSE, WILL BYPASS CALL TO "GBLEVENTS"
C 1999-09-22  D. A. KEYSER - THE FLAGGING OF MASS REPORTS IN THE
C       VICINITY OF STORMS IN SUBR. EDTPRP IS NOW CONTROLLED BY NEW
C       N-LIST SWITCH "FLMASS", IF FALSE THEN REPORTS WILL NOT BE
C       FLAGGED
C 1999-09-24  D. A. KEYSER - CHANGES TO MAKE CODE MORE PORTABLE;
C       REPORTS IN SPSSMI MESSAGES NO LONGER PROCESSED IN SUBR.
C       EDTPRP (USELESS BECAUSE NO WIND DIRECTION AVAILABLE); INCR.
C       STORAGE LIMIT FOR OBSERVATIONS IN STORM VICINITY FROM 150
C       TO 500
C 2001-09-27  D. A. KEYSER - OPTION AVAILABLE TO GENERATE A NEW FORM
C       OF MASS BOGUS REPORT WITH REPORT TYPE 111 AT THE STORM
C       LOCATION, FIRST EVENT WRITES REPORTED STORM CENTRAL PRESSURE
C       FOR SURFACE PRESSURE, THIS IS THEN ADJUSTED ACCORDING TO THE
C       FIRST GUESS PRESSURE AND THE STORM CATEGORY ON THE SAFFIR-
C       SIMPSON SCALE AS A SECOND EVENT, THE GUESS TEMPERATURES AND
C       AN ASSUMPTION OF 99% R.H. ARE USED TO GENERATE SPECIFIC
C       HUMIDITY ON ALL LEVELS THROUGHOUT THE DEPTH OF THE STORM,
C       THE OPTION TO PRODUCE THESE NEW MASS BOGUS REPORTS IS
C       CONTROLLED BY THE NEW N-LIST SWITCH "MAK111", IF FALSE THEN
C       REPORTS WILL NOT BE GENERATED
C 2001-10-10  D. A. KEYSER -- MODIFIED TO NOW PASS TWO SPANNING GLOBAL
C       SIGMA GUESS FILES INTO W3LIB ROUTINE GBLEVENTS IN SITUATIONS
C       WHERE THE CENTER DATE FOR THE PREPBUFR FILE HAS AN HOUR THAT
C       IS NOT A MULTIPLE OF 3 (SEE 2001-10-10 CHANGES TO GBLEVENTS);
C       ADDED PROGRAM CODE ("SYNDATA") AND REASON CODE (0) FOR ALL
C       BOGUS DATA CREATED IN REPORT TYPES 210, 100, 111 (FOR TYPE
C       111 THIS CAN BE UPDATED WITH EVENTS - SEE 2001-09-27)
C 2004-09-09  D. A. KEYSER - MODIFIED SUBR. SURPRP TO NOT PROCESS
C        REPORTS IN NEW MESSAGE TYPE GPSIPW SINCE THEY HAVE NEITHER
C        PRESSURE NOR WIND DATA; MODIFIED SUBR. EDTPRP TO NOT READ
C        REPORTS IN NEW MESSAGE TYPE GPSIPW SINCE THEY NEVER CONTAIN
C        MASS DATA OR PRESSURE AND THUS ARE NEVER EDITED BY THIS
C        SUBR. (THEY ARE INCLUDED IN LIST OF MESSAGE TYPES COPIED
C        DIRECTLY TO OUTPUT PREPBUFR FILE)
C 2005-07-01  D. A. KEYSER - ADDED OPTION TO FLAG DROPWINSONDE WINDS
C        ON ALL LEVELS FOR STORMS SUFFICIENTLY CLOSE TO STORMS (IN
C        SUBR. EDTPRP), VIA NEW NAMELIST SWITCH "FLBWND" (DEFAULTS TO
C        TRUE) (SEE COMMENTS IN SUBR. EDTPRP FOR DEFINITION OF
C        "SUFFICIENTLY CLOSE"); ADDED OPTION TO NOT APPEND TYPE 110/210
C        BOGUS REPORTS TO PREPBUFR FILE (IN SUBR. EDTPRP), VIA NEW
C        SCRIPT VARIABLE "DO_BOGUS" (OBTAINED VIA CALL TO SYSTEM
C        ROUTINE GETENV - DEFAULTS TO "YES") -- IF "DO_BOGUS" IS "NO",
C        AND MAK111 IS FALSE, THEN PROGRAM WILL STOP IMMEDIATELY IF
C        "FLBWND" IS "FALSE", ALSO IF "DO_BOGUS" IS "NO", THEN "FLMASS"
C        IS HARDWIRED TO BE "FALSE"; FIXED SOME MEMORY-CLOBBERING BUGS
C        THAT, ON RARE OCCASIONS CAUSED THIS PROGRAM TO STOP
C        ABNORMALLY, BUT SILENTLY, WITH THE "COMMAND TERMINATED
C        ABNORMALLY" STATEMENT; REPLACED CALL TO BUFRLIB ROUTINE BORT
C        WITH CALL TO W3LIB ROUTINE ERREXIT IN SUBR. SURPRP; ADDED
C        SUBR. CHDIST (CALLED BY SUBR. EDTPRP)
C 2005-11-28  D. A. KEYSER - INCREASED THE MAXIMUM NUMBER OF POINTS
C        THAT CAN BE USED TO CONSTRUCT A TEMPLATE SET OF POINTS FOR
C        AVERAGING OVER THE STORM LOCATION FROM 31x31 TO 50x50 TO
C        ACCOUNT FOR TROPICAL STORM DELTA WHICH HAS A RADIUS OF
C        OUTERMOST CLOSED ISOBAR TOO LARGE FOR THE 31x31 ARRAY (CAUSED
C        NON-FATAL TERMINATION)
C 2012-08-31  D. A. KEYSER - REMOVED DEPENDENCY OF MAK111 ON DO_BOGUS,
C        THUS IF DO_BOGUS=NO AND MAK111=TRUE TYPE 111 BOGUS REPORTS
C        WILL BE GENERATED EVEN THOUGH TYPE 110/220 BOGUS REPORTS ARE
C        NOT (BEFORE NEITHER WOULD BE GENERATED IF DO_BOGUS=NO); FIXED
C        STDOUT PRINT ERROR IN SUBR. EDTPRP FOR LIMITING RADIUS
C        OVERWHICH DROPSONDE REPORTS WILL HAVE WIND QM'S FLAGGED
C 2012-11-20  J. WOOLLEN   - INITIAL PORT TO WCOSS - FIXED A NUMBER OF
C        PROBLEMS IDENTIFIED BY THE INTEL COMPILER MAINLY TO DO WITH
C        LOCAL VARIABLE USE WITHIN SUBROUTINE ENTRY POINTS
C 2013-03-26  D. A. KEYSER - FINAL CHANGES TO RUN ON WCOSS: ADDED CALL
C        TO BUFRLIB ROUTINE SETBMISS(10E08_8) TO RESET BMISS TO A VALUE
C        (10E08_8) WHICH WILL NOT CAUSE INTEGER OVERFLOW WHICH CAN BE
C        UNPREDICTABLE (PRIOR BMISS VALUE WAS 10E10_8); REPLACED GETENV
C        WITH MORE STANDARD GET_ENVIRONMENT_VARIABLE; USE FORMATTED
C        PRINT STATEMENTS WHERE PREVIOUSLY UNFORMATTED PRINT WAS > 80
C        CHARACTERS; REPLACED FORMATTED ARRAY SUBROUTINE ARGUMENTS WITH
C        VARIABLES
C 2014-09-05  D. A. KEYSER
C           - CHANGES MADE IN ENTRY VWNCOM TO PREVENT ARRAY OVERFLOW IN
C        2ND ELEMENT OF AXIWND WHEN ENTRY IS CALLED OUT OF SUBROUTINE
C        MM2DVO WHERE NCMPVO IS PASSED IN WITH VALUE OF 1 AND DEBUGGING
C        IS TURNED ON AT RUN TIME (NOTE: MAY NOT BE CORRECT SOLUTION
C        BUT YIELDS SAME OUTPUT BOGUS WINDS AS WHEN THIS CHANGE IS NOT
C        MADE AND CODE RUNS W/O DEBUGGING TURNED ON AT RUN TIME  -->
C        THIS FIX ALLOWS CODE TO RUN TO COMPLETION WHEN DEBUGGING IS
C        TURNED ON AT RUN TIME).
C           - CHANGE IN SUBR. SURPRP: IF EITHER UOB OR VOB (OR BOTH)
C        ARE MISSING, SKIP THE PROCESSING OF INPUT PREPBUFR WIND REPORT
C        LEVEL (UOB AND/OR VOB CAN NOW BE MISSING FOR SURFACE WIND
C        REPORTS SINCE A RECENT IMPLEMENTATION ALLOWS REPORTS WITH ONLY
C        WIND SPEED OR ONLY WIND DIRECTION TO STORE THESE IN SOB AND
C        DDO, RESP. - PRIOR TO THIS FIX IN SYNDATA, MISSING VALUES FOR
C        UOB AND VOB WERE GENERATING NONSENSICAL BOGUS WINDS OR CAUSING
C        PROGRAM TO ABORT).
C           - PARAMETERS LDXDIM AND NDATMX (STORAGE LIMIT FOR NUMBER OF
C        OBSERVATIONS IN STORM VICINITY) INCREASED FROM 500 TO 1000 IN
C        SUBR. CMPSIT.  A TRAP REMAINS SET FOR ARRAYS EXCEEDING LDXDIM
C        IN ENTRY ANLCOM AND FOR ARRAYS EXCEEDING NDATMX IN ENTRY
C        OWNCOM.  HOWEVER, THE TRAP FOR LDXDIM HAD TO BE FIXED AS IT
C        WAS PREVIOUSLY INVOKED ONLY WHEN THE LIMIT WAS EXCEEDED BY 1,
C        TOO LATE FOR ARRAY OVERFLOW (AND PROGRAM TERMINATION WHEN
C        DEBUGGING IS TURNED ON AT RUN TIME).
C 2016-05-18  S. J. LORD
C        ADDRESSED UNINITIALIZED VARIABLES IN SUBR. TEMWT AND MAKVOR.
C        ADDITIONALLY REINSTATED WEIGHT CALCULATION IN SUBR. TEMWT.
C 2016-07-01  D. STOKES
C        REPLACED REWIND WITH CLOSE FOR REUSABLE READ/WRITE FILE IUNTFE 
C        AFTER IT IS UPDATED WITH INFORMATION FOR THE CURRENT STORM BY
C        ROUTINE FENBOG.  THIS PREVENTS INADVERTENT INPUT OF RESIDUAL
C        CONTENT FROM A PREVIOUS STORM WHILE PROCESSING THE INFORMATION
C        FOR THE CURRENT STORM (as can happen with some compilations).
C 2017-04-03  D. A. KEYSER
C           - PARAMETERS LDXDIM AND NDATMX (STORAGE LIMIT FOR NUMBER OF
C        OBSERVATIONS IN STORM VICINITY) INCREASED FROM 1000 TO 8000 IN
C        SUBR. CMPSIT.  LDXDIM INCREASED FROM 71 TO 8000 IN SUBROUTINE
C        MM2DVO, AND FROM 2500 TO 8000 IN SUBROUTINES AS2DVO, XSPLCM,
C        OUTPUTT, SL1GET, AD1EXX and SL1MBO. 
C        BENEFIT: There can be > 1000 obs in the storm vicinity. This
C                 change ensures that all obs are processed and
C                 eliminates partial processing of statistics in cases
C                 where code does not abort but there are > 1000 obs
C                 going into certain subroutines. The value for
C                 parameter LDXDIM is standardized throughout the code
C                 (it was already set to 8000 in many subroutines, but
C                 to 2500 in other subroutines and to 1000 in subr.
C                 CMPSIT before this change).
C           - ADDITIONAL TRAPS SET IN SUBROUTINES MM2DVO AND AS2DVO AND
C             IN ENTRIES FITOBS, STICKD, GETAMR AND GT1AMR TO CATCH
C             CASES WHERE NUMBER OF OBS WOULD EXCEED LDXDIM, AND IN
C             EMTRIES ANLCOM AND OPSCOM TO CATCH CASES WHERE NUMBER OF
C             OBS WOULD EXCEED NDATMX.  DIAGNOSTICS ARE PRINTED WHEN
C             LIMIT HIT.
C        BENEFIT: Prevents array overflow (and program termination when
C                 debugging is turned on at run time). (These traps
C                 should not be hit now since the limits for LDXDIM and
C                 NDATMX have been now been greatly increased).
C 2020-01-09  J. Dong -- In subroutine EDTPRP, changed the windowing
C        decade from 20 to 40 for cases when the year is represented
C        by 2 digits instead of 4. 
C 2020-10-09  X. Wu -- In subroutine EDTPRP, the distance threshold for
C        inner core dropsonde data reduced to 55km. A 32 m/s wind 
C        threshold was added.  This allows for more inner core data to
C        be assimilated in GFSv16.     
C 2022-??-??  C. Hill
C        Dynamic memory allocation introduced (2021-08-31) to permit BUFR
C        sonde processing.
C
C
C USAGE:
C   INPUT FILES:
C     UNIT 11  - TCVITALS RECORDS
C     UNIT 13  - NCEP DATE
C     UNIT 14  - LAND-SEA MASK
C     UNIT 15  - BOGDOMN WORKING FILE NULL)
C     UNIT 16  - STMTRK WORKING FILE (NULL)
C     UNIT 17  - RAWDAT WORKING FILE (NULL)
C     UNIT 21  - TCVITALS INFORMATION FROM FIRST GUESS
C     UNIT 25  - PREPBUFR FILE PRIOR TO ADDITION OF BOGUS DATA OR ANY
C              - MODIFICATIONS TO NON-BOGUS REPORTS
C     UNIT 30  - FIRST INPUT SPECTRAL (GLOBAL) SIGMA FIRST GUESS FILE;
C              - IF HOUR IN CENTER DATE FOR PREPBUFR FILE IS A MULTIPLE
C              - OF 3 THEN THIS FILE IS VALID AT THE CENTER DATE OF THE
C              - PREPBUFR FILE, IF THE HOUR IN CENTER DATE FOR PREPBUFR
C              - FILE IS NOT A MULTIPLE OF 3 THEN THIS FILE IS VALID AT
C              - THE CLOSEST TIME PRIOR TO THE CENTER DATE OF THE
C              - PREPBUFR FILE THAT IS A MULTIPLE OF 3
C     UNIT 31  - SECOND INPUT SPECTRAL (GLOBAL) SIGMA FIRST GUESS FILE;
C              - IF HOUR IN CENTER DATE FOR PREPBUFR FILE IS A MULTIPLE
C              - OF 3 THEN THIS FILE IS EMPTY, IF THE HOUR IN CENTER
C              - DATE FOR PREPBUFR FILE IS NOT A MULTIPLE OF 3 THEN
C              - THIS FILE IS VALID AT THE CLOSEST TIME AFTER THE
C              - CENTER DATE OF THE PREPBUFR FILE THAT IS A MULTIPLE OF
C              - 3
C     UNIT 32  - OBSERVATION ERROR FILE
C     UNIT 40  - WEIGHTS
C
C   OUTPUT FILES:
C     UNIT 06  - STANDARD OUTPUT PRINT
C     UNIT 19  - BGHISTRY.DIAG FILE
C     UNIT 22  - STKDATB WORKING FILE
C     UNIT 23  - FENVDTA WORKING FILE
C     UNIT 24  - BOGDAT WORKING FILE
C     UNIT 58  - BOGREPT FILE
C     UNIT 59  - DTHISTRY FILE
C     UNIT 61  - PREPBUFR FILE WITH POSSIBLE ADDITION OF BOGUS DATA
C              - AND/OR POSSIBLE MODIFICATIONS TO NON-BOGUS REPORTS
C     UNIT 70  - MATCOEF FILE
C     UNIT 71  - DUMCOEF FILE
C     UNIT 72  - RAWDAT WORKING FILE
C     UNIT 73  - STMTRK WORKING FILE
C     UNIT 74  - ALLDAT FILE
C     UNIT 80  - "PREVENT" EVENTS DATA FILTERING SUMMARY PRINT FILE
C     UNIT 89  - BOGDOMN WORKING FILE
C
C   SUBPROGRAMS CALLED:
C     UNIQUE:    - BOGMTH   GRABMO   SETMOD   SPMODL   TEMPLT   TEMWT
C                  OUTENV   OUTGES   REDSUB   SLDATE   FIXSLM
C                  GAULAT   BSSLZ1   SEARCH   TRKSUB   NEWVIT
C                  DECVAR   GRABVO   SETUP    SETVOR   MM3DVO
C                  MAKVOR   R15FND   OVRLAP   COMBIN   RITSPS
C                  RITCR1   RITCR2   TIMSUB   YTIME    SORTRL
C                  CIRCLE   RFAC     ZNEAR    CHGRES   UVTOZD
C                  RDSUBS   STISUB   ISECND   UVRTCN   UV2DS
C                  ATAN2DEG SINDEG_8 COSDEG_8 DISTSP_8 STDEV
C                  ABRT1    CMPSIT   MM2DVO   AS2DVO   CSWRL6
C                  FCN      ERRF     MAKHRD   FUNINC   SPLDAT
C                  IBM1     XDTSUB   YDTSUB   DIFSUB   PRDLOC
C                  IBM2     WTDAT    RWT      OUTSTT   GETSVF   OUTSV
C                  SLOSUB   STSPBC   IBM3     SLOCCO   IDSSUB   XBF
C                  YBF      MERCAT   IBM5     DOMCHK   COORDS
C                  DTIME    XTIME    WDWSP    BOGUS    LINT
C                  VFIND    DSKNMC   DPREP    PRFSUB   PRFMSC
C                  PRFKMD   MEANV    OUTSUB   QSATW    QSATI
C                  PCKPRW   UPKPRW   OUTSTK   OPNFIL   ENDFIL
C                  SPTDER   OUTREC   SETSCL   HEDCHK   CSGNLN
C                  SIMCON   SETSIM   RNKVRT   STASH    SIZE
C                  SHRINK   ALSAND   CONTST   DOIT     SLARGO
C                  SPLEFW   GAMSUB   SLIQBG   SLADDQ   ADEXXX
C                  CCOSUB   CC2SUB   MLXN9A   PASSUB   PASDSS
C                  ANRTOD   SLIMBO   SLISUB   SPLEFR   SPLINT
C                  SPTINO   MSKDMP   SPTIKA   INVMTX   IERINV
C                  XSPLCM   OUTPUTT  DSGRPH   PRNT     OVRSUB   STSBC1
C                  SL1OVR   ST1KPX   Y1BF     PR1FKM   IBM4     SL1RGO
C                  SL1GET   SL1QBG   SL1ADQ   AD1EXX   PAS1XS
C                  CL1ANS   PASD1R   SL1MBO   SP1LNT   SP1TNO
C                  EDTPRP   SURPRP   CHDIST   SPHERP   LEGENDR2
C     SYSTEM:    - GET_ENVIRONMENT_VARIABLE
C     LIBRARY:
C       W3NCO    - W3TAGB   W3TAGE   W3LOCDAT W3UTCDAT W3DIFDAT
C                  W3MOVDAT ERREXIT
C       W3EMC    - GBLEVENTS
C       BUFRLIB  - DATELEN  OPENBF   OPENMB   OPENMG   READMG
C                  READSB   UFBQCD   UFBCPY   UFBINT   WRITSB
C                  CLOSMG   CLOSBF   SETBMISS GETBMISS IBFMS
C
C   EXIT STATES:
C     COND =   0 - SUCCESSFUL RUN
C          =   4 - ERROR READING TCVITALS FILE
C          =  20 - FATAL ERROR (SEE STDOUT PRINT FOR MORE DETAILS)
C     COND =  60-79 - RESERVED FOR W3LIB ROUTINE GBLEVENTS (SEE
C                      GBLEVENTS DOCBLOCK)
C
C REMARKS: IMPORTANT INFORMATION REGARDING Y2K CONVERSION -
C            KEYSER - 12-03-1998
C
C          THE Y2K-COMPLIANT VERSION IS SET-UP TO READ RECORDS WITH
C          EITHER A 2-DIGIT YEAR STARTING IN COLUMN 20 OR A 4-DIGIT
C          YEAR STARTING IN COLUMN 20.  THIS WILL ALLOW THIS PROGRAM
C          TO RUN PROPERLY WHEN TCVITALS RECORDS TRANSITION TO A
C          4-DIGIT YEAR.
C
C            The following variables have been converted from a value
C              of "YYMMDD" to "YYYYMMDD":
C  (note: all occurrences of "DAY0" changed to "JDAY0")
C  (note: all occurrences of "DATEJ" changed to "IDATEJ")
C  (note: all occurrences of "DAYX" changed to "IDAYX")
C  (note: all occurrences of "DAY0Z" changed to "IDAYZ")
C  (note: all occurrences of "DAYMN" changed to "IDAYMN")
C  (note: all occurrences of "DAYMX" changed to "IDAYMX")
C  (note: all occurrences of "DAYSTM" changed to "IDAYST")
C  (note: all occurrences of "DAYOB" changed to "IDAYOB")
C  (This is because 32-bit words on IBM not large enough to hold
C    floating point version of YYYYMMDD.)
C               IDATEZ, IDTREQ, IDATE, IDATZZ, IVTVAR(1), JDAY0,
C               IDAYZZ, IDAYZ, IDATTK, IDAY0, ISRTDA, IDATEJ, IVALUE,
C               IDAYX, IDAYMN, IDAYMX, IDAYST, IDAYOB, HEAD_8(2)
C            The following variables have been converted from a value
C              of "YY" to "YYYY":
C               IYRREQ, IYRMNS, IYR, IYRWIN, IYZ, IYX, IYMN, IYRZ,
C               IY0, IYMX
C            The following variables have been converted from a value
C              of "YYMMDDHH" to "YYYYMMDDHH":
C               ICHECK, IDAFST, IDATE0, IDATBF
C            The following string variables have been modified to
C               contain a 4-digit year rather than a 2-digit year
C               in the date:
C               BASNID, MTITLE, BUFF, BUFFIN, BUFINZ
C            The following variables are related to the fractional
C               number of days since 365 days prior to 00Z on NCEP
C               date and were not changed:
C               DAY00 (renamed from DAY0 which had a double meaning,
C               see above), DAYMX0 (renamed from DAYMX which had a
C               double meaning, see above), DAYMN0 (renamed from DAYMN
C               which had a double meaning, see above), DAYZ, STMDAY,
C               SRTDAY, STDAY0, DAYPLS, DAYMNS, DAYYR, DAYA, DAY
C                (NOTE: The fractional number of days was based from
C                       12/31/1899 but 32-bit words on IBM are not
C                       large enough to hold this number.)
C            The following unit numbers contain either reads or writes
C               of one or more variables in the first four groups
C               above which have been modified to contain a 4-digit
C               year:
C                unit 02  - write JDAY0  (unformatted)
C                unit 13  - write IDATEJ (from I7 to I9)
C                "IDSPC"  - write IYMN   (from I2 to I4)
C                "IDSPC"  - write IYMX   (from I2 to I4)
C                "IDSPC"  - write IDAY0  (remains I8)
C                 (NOTE: "IDSPC" and "IDSPCZ" length increased from
C                         CHARACTER*121 to CHARACTER*125)
C                "IFILE"  - write MTITLE (from 100 char. to 102 char.)
C                "IOVITL" - read  BUFIN  (from  93 char. to  95 char.)
C                "IUNTBG" - write IDATE0 (from I8 to I10)
C                "IUNTBH" - write IDATBF (unformatted)
C                "IUNTBH" - write IDATE  (from I8 to I10)
C                "IUNTDO" - write IDAYZ  (from I7 to I9)
C                "IUNTFE" - read  MTITLE (from 100 char. to 102 char.)
C                "IUNTDH" - write IDATEZ (from I8 to I10)
C                "IUNTPV" - write JDAY0  (unformatted)
C                "IUNTTK" - write IDAYZ (unformatted)
C                "IUNTVO" - read  IDATEJ (unformatted)
C                "IUNIT"  - read  MTITLE (from 100 char. to 102 char.)
C                "IUNITB" - read  IDATEJ (from I7 to I9)
C                "MSKDA1" - read  IDAYX  (unformatted)
C                "MSKDA2" - read  IDAYST (unformatted)
C                "MSKDA3" - read  HEAD_8(2)(unformatted)
C                "MSKDA3" - write HEAD_8(2)(unformatted)
C                "MSKDA6" - read  IDAYX  (unformatted)
C                "MSKDA8" - read  IDAYX  (unformatted)
C                "MSKDA9" - write JDAY0  (from I7 to I9)
C                "MSKD16" - write JDAY0  (from I7 to I9)
C                "MSKZ"   - write JDAY0  (unformatted)
C
C Switches used to control processing:
C    DO_BOGUS (CHARACTER - obtained via call to system routine
C    GET_ENVIRONMENT_VARIABLE):
C      - Controls processing of type 110/210 bogus reports and
C        subsequent output into PREPBUFR file (although type 110 are
C        never generated)
C      - Either "YES" or "NO"
C      - Defaults to "YES"
C    MAK111 (LOGICAL - obtained via namelist "INPUT"):
C      - Controls processing of type 111 bogus reports and subsequent
C        output into PREPBUFR file
C      - Either "TRUE" or "FALSE"
C      - Defaults to "FALSE"
C    FLMASS (LOGICAL - obtained via namelist "INPUT"):
C      - Controls flagging of pressure quality marks on all levels for
C        all types of mass reports sufficiently close to all storms
C        currently in the TCVITALS list (see commented in subroutine
C        EDTPRP for definition of "sufficiently close") (these are then
C        encoded into output PREPBUFR file)
C      - Either "TRUE" or "FALSE"
C      - Defaults to "TRUE"
C      - NOTE: Hardwired to "FALSE" if DO_BOGUS is "NO"
C    FLBWND (LOGICAL - obtained via namelist "INPUT"):
C      - Controls flagging of wind quality marks on all levels for
C        dropwinsonde reports sufficiently close to all storms
C        currently in the TCVITALS list (see commented in subroutine
C        EDTPRP for definition of "sufficiently close") (these are then
C        encoded into output PREPBUFR file)
C      - Either "TRUE" or "FALSE"
C      - Defaults to "TRUE"
C
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS (IBM iDataPlex and Cray XC40)
C
C$$$
      PROGRAM SYNDAT_SYNDATA

      PARAMETER(KVDIM= 7)
      PARAMETER(KLDIM=12)
      PARAMETER (MAXSTM=70)
ccccc PARAMETER (MAXBPT=31,MAXPTS=MAXBPT*MAXBPT)
      PARAMETER (MAXBPT=50,MAXPTS=MAXBPT*MAXBPT)
      PARAMETER (IQUADX=4)

      LOGICAL OVRFLG,FSTBOG

      REAL(8)   BMISS,GETBMISS

      LOGICAL OUTFIL,QCFILE,ADVORT,APPREP,OKNBGR,VORDIV,SPCIFH,MNIBOG,
     1        NOGES,PREVEN,FLMASS,MAK111,FLBWND
      CHARACTER RUNID*6
      DIMENSION IPREQ(KLDIM),IVREQ(KVDIM),IPREQZ(KLDIM),IVREQZ(KLDIM),
     1          IPDUM(KLDIM),IVDUM(KVDIM)
      NAMELIST/INPUT/IDATEZ,IUTCZ,QCFILE,MWAVEZ,PTOPAZ,ADVORT,APPREP,
     1               IVFLTP,IVOTYP,RUNID,FRACST,IDTTRK,IHRMXT,OUTFIL,
     2               ERPOS0,OKNBGR,MODNAM,IHRWIN,VORDIV,SP1DWL,DIVFAC,
     3               IMFLTP,SPCIFH,DELTA,DELTAV,MNIBOG,FACRMW,RMXMNB,
     4               NOBWMN,NOGES,MODTYP,NPREQ,NVREQ,IPREQ,IVREQ,RLATMN,
     5               RLATMX,PREVEN,FLMASS,MAK111,FLBWND

      CHARACTER STMNAM*9,STMID*3,RSMC*4,DO_BOGUS*3

      LOGICAL FSTFLG

      DIMENSION STMNAM(MAXSTM),STMLAT(MAXSTM),STMLON(MAXSTM),
     1          STMDIR(MAXSTM),STMSPD(MAXSTM),IDATE(MAXSTM),
     2          IUTC(MAXSTM),RMAX(MAXSTM),PENV(MAXSTM),PCEN(MAXSTM),
     3          PTOP(MAXSTM),RSMC(MAXSTM),RMW(MAXSTM),VMAX(MAXSTM),
     4          R15NW(MAXSTM),R15NE(MAXSTM),R15SE(MAXSTM),R15SW(MAXSTM),
     5          STMID(MAXSTM),FSTFLG(MAXSTM),BLATMN(MAXSTM),
     6          BLATMX(MAXSTM),BLONMN(MAXSTM),BLONMX(MAXSTM),
     7          vmax_save(maxstm)

      DIMENSION RMXSTM(MAXSTM),RMXBOG(MAXSTM),IBMETH(MAXSTM),
     1          OVRFLG(MAXSTM),VTBOG(MAXSTM),RMXMNI(MAXSTM)

      DIMENSION RLATP(MAXPTS),RLONP(MAXPTS),WTP(MAXPTS)

      DIMENSION ENVBOG(MAXPTS,2),R15WND(IQUADX)

      COMMON/PREVSW/PREVEN
      COMMON/PROCSW/FLMASS,FLBWND,DO_BOGUS
      COMMON/T111SW/MAK111
      COMMON/BUFRLIB_MISSING/BMISS

      DATA MODTYP/1/,IMFLTP/1/,IVOTYP/1/,IVFLTP/3/,IEFLTP/2/,MXUNTE/1/

      DATA IOVITL/11/,IUNTMO/ 2/,IUNTDT/13/,IUNTSL/14/,IUNTDO/15/,
     1     IUNTTK/16/,IUNTPV/17/,IUNTBD/58/,IUNTBH/19/,IUNTDH/59/,
     2     IUNTGV/21/,IUNTVD/18/

      DATA IUNTFV/22/,IUNTFE/23/,IUNTRV/39/,IUNTBG/24/

      DATA IUNTPN/25/,IUNTPO/61/

      DATA SPCIFH/.FALSE./,MNIBOG/.FALSE./,IHRWIN/0/

C  DEGLAT: ONE DEGREE LATITUDE IN METERS
C  IOPTF : SEARCH OPTION FOR LOOKING FOR FIRST STORM

      DATA MWAVE/-99/,PTOPAL/-99.0/,DELTA/1.25/,DEGLAT/111.1775E3/,
     1     IOPTF/6/,QCFILE/.FALSE./,IONE/1/,DELTAV/40./,
     2     FSTBOG/.TRUE./,FRACST/1.0/,VTDFLT/5.0/,RMXMNB/200./,
     3     FACRMW/3.0/,NOBWMN/2/,NOGES/.FALSE./

      DATA IPREQ/1000,850,700,500,400,300,250,200,150,100,70,50/,
     1     IVREQ/6,4,5,3,2,1,7/,NPREQ/6/,NVREQ/1/

      DATA LSTORM/0/

C  *********************************************
C  *********************************************
C  ****                                     ****
C  ****        PROGRAM SYNDATA              ****
C  ****             "YOGI"                  ****
C  ****    A ('SMARTER THAN THE AVERAGE')   ****
C  ****    PROGRAM FOR BOGUSING VORTEX      ****
C  ****    CIRCULATIONS INTO NUMERICAL      ****
C  ****    WEATHER PREDICTION MODELS.       ****
C  ****                                     ****
C  *********************************************
C  *********************************************

C  CURRENT MODEL AND FILE TYPES ARE:

C  MODEL TYPE:

C    MODTYP= 0: MODEL INDEPENDENT BOGUSING

C    MODTYP= 1: SPECTRAL MODEL

C    MODTYP=-1: GRID POINT MODEL  *** NOT IMPLEMENTED ***

C    FILE TYPES:
C         IMFLTP=1: NCEP GLOBAL SPECTRAL MODEL, OPERATIONAL R40 PRESSURE
C                COEFFICIENT FILE == SEE SLVSP1 FOR VERTICAL LEVEL SETUP
C                                    INFORMATION
C                                 == SEE SVRSP1 FOR SETUP INFORMATION ON
C                                    VARIABLES
C         IMFLTP=2: NCEP GLOBAL SPECTRAL MODEL, OPERATIONAL T80 PRESSURE
C                COEFFICIENT FILE == SEE SLVSP2 FOR VERTICAL LEVEL SETUP
C                                    INFORMATION
C                                 == SEE SVRSP2 FOR SETUP INFORMATION ON
C                                    VARIABLES
C         IMFLTP>2: *** NOT IMPLEMENTED ***

C  CURRENT VORTEX AND FILE TYPES ARE:

C  VORTEX TYPE:

C    IVOTYP= 1: NON-DIVERGENT, AXISYMMETRIC

C    IVOTYP= 2: DIVERGENT, AXISYMMETRIC


C    FILE TYPES:
C         IVFLTP= 1: MATHUR 3-D POSTPROCESSED U, V, Z FILE
C                 == SEE SLVVO1 FOR SETUP INFORMATION ON VERTICAL LEVELS
C                 == SEE SVRVO1 FOR SETUP INFORMATION ON VARIABLES

C         IVFLTP= 2: MATHUR  2-D ITERATIVE VORTEX

C         IVFLTP= 3: SHAPIRO 2-D ITERATIVE VORTEX (RADIAL AND TANGENTIAL
C                    WIND ARE CREATED)

C  PRESET AND UPDATE SOME OPTIONS AND READ IN DATE/TIME

      CALL W3TAGB('SYNDAT_SYNDATA',2020,0283,1200,'NP22')

      MWAVEZ   = MWAVE
      PTOPAZ   = PTOPAL
      ADVORT   = .TRUE.
      FLMASS   = .TRUE.
      MAK111   = .FALSE.
      FLBWND   = .TRUE.
      DIVFAC   = 0.0
      READ(5,INPUT)
      WRITE(6,INPUT)
      CALL GET_ENVIRONMENT_VARIABLE('DO_BOGUS',DO_BOGUS)
      IF(DO_BOGUS.NE.'YES' .AND. DO_BOGUS.NE.'NO')  DO_BOGUS = 'YES'
      WRITE(6,'("DO_BOGUS = ",A)') DO_BOGUS

      IF(IDATEZ .LT. 0 .OR. IUTCZ .LT. 0)  THEN
         CALL SLDATE(IUNTDT,IDATEZ,IUTCZ,IOFFT)
      ELSE
         WRITE(6,431)
  431    FORMAT(/'******CURRENTLY IDATEZ OR IUTCZ MUST BE < 0 UPON ',
     1    'INPUT BECAUSE SUBR. SLDATE MUST BE CALLED TO GET BASE'/10X,
     2    'DATE FOR FRACTIONAL NUMBER OF DAYS CALCULATION'/)
         CALL ABRT1(' MAIN  ',431)
      END IF

      WRITE(6,1)  MNIBOG,RUNID
    1 FORMAT(//20X,'*****************************************'/
     1         20X,'*****************************************'/
     2         20X,'****   WELCOME TO SYNDATA ("YOGI")   ****'/
     3         20X,'****    A SMARTER-THAN-THE-AVERAGE   ****'/
     4         20X,'****       BOGUSING PROGRAM FOR      ****'/
     5         20X,'****       VORTEX CIRCULATIONS       ****'/
     6         20X,'****   MNIBOG=',L1,' RUNID=',A,9X,  '****'/
     7         20X,'*****************************************'/
     8         20X,'*****************************************'//
     9         ' ===> VERSION -- 09 Jan 2020'//)

C  On WCOSS should always set BUFRLIB missing (BMISS) to 10E8 to avoid
C   overflow when either an INTEGER*4 variable is set to BMISS or a
C   REAL*8 (or REAL*4) variable that is missing is NINT'd
C  -------------------------------------------------------------------
      CALL ISETPRM ( 'MXMSGL', 600000 )  ! CH 08/31/21
      CALL ISETPRM ( 'MAXSS',  600000 )  ! CH 08/31/21
ccccc CALL SETBMISS(10E10_8)
      CALL SETBMISS(10E8_8)
      BMISS=GETBMISS()
      CALL MAXOUT(50000)                 ! CH 08/31/21
      print'(1X)'
      print'(" BUFRLIB value for missing is: ",G0)', bmiss
      print'(1X)'

      IF(DO_BOGUS.EQ.'NO')  THEN
         IF(.NOT.FLBWND .AND. .NOT.MAK111)  THEN

C  Note that when DO_BOGUS is NO and MAK111 is FALSE, if FLBWND is
C   FALSE the program stops (normal r.c.) because it has nothing to do
C  -------------------------------------------------------------------

            PRINT *
            PRINT *, '#####NOTICE: DO_BOGUS IS "NO" AND MAK111 IS ',
     $       '"FALSE" AND FLBWND IS "FALSE" -- THIS PROGRAM HAS ',
     $       'NOTHING TO DO -- STOP NORMALLY'
            PRINT *
            CALL W3TAGE('SYNDAT_SYNDATA')
            STOP
         END IF

C  Note that when DO_BOGUS is NO, FLMASS is hardwired to FALSE because
C   the assumption is that the ONLY changes to the PREPBUFR file are
C   the flagging of dropwinsonde winds near storm(s) (if FLBWND = TRUE)
C   and/or the generation of type 111 bogus reports (if MAK111 = TRUE)
C   (i.e., mass reports near storms are not flagged)
C  --------------------------------------------------------------------

         PRINT *
         PRINT *, '--> NOTE: DO_BOGUS IS "NO", SO HARDWIRE FLMASS TO ',
     $    '"FALSE"'
         PRINT *
         FLMASS = .FALSE.
      END IF

      CALL RITCR1(IUNTBD,IUNTBH,IDATEZ,IUTCZ,RUNID)

      CALL VITLST(IOVITL)

C  LOOK FOR ALL STORMS AT THE DATE/TIME IN QUESTION

      CALL SEARCH(IDATEZ,IUTCZ,IHRWIN,MAXSTM,KSTORM,STMLAT,STMLON,
     1            STMDIR,STMSPD,RMAX,PENV,PCEN,PTOP,IDATE,IUTC,VMAX,RMW,
     2            R15NE,R15SE,R15SW,R15NW,PTOPAZ,IOVITL,IUNTBH,IERSRC,
     3            IERVIT,QCFILE,FSTFLG,RSMC,STMID,STMNAM,ihrreq)
      IF(IERSRC .NE. 0 .OR. IERVIT .NE. 0)  THEN
         IF(IERVIT .NE. 0)  WRITE(6,3) IERVIT
    3    FORMAT('******ERROR',I3,' HAS OCCURRED READING THE VITAL',
     1          ' STATISTICS FILE. SYNDATA IS TERMINATED')
         IF(IERSRC .NE. 0)  WRITE(6,4) IERSRC
    4    FORMAT('******SYNDATA IS TERMINATED DUE TO REASON=',I3)

C  WRITE THE HEADER RECORD FOR THE PREPBUFR FILE

         CALL W3TAGE('SYNDAT_SYNDATA')
         CALL ERREXIT(4)
      ENDIF

C-----------------------------------------------------------------------

C  CALCULATE THE RADIUS OF THE BOGUSING AREA FOR ALL STORMS.  THE CALL
C    TO FSTOCR DETERMINES IF THE STORM HAS HAD A PREVIOUS HISTORY OF
C    BOGUSING.  IF SO (IBMETH>=1), WE USE A SMALLER RADIUS FOR THE
C    BOGUSING AREA AND, LATER IN COMBIN, WE ELIMINATE ALL DATA BEYOND
C    RMAX.

      DO KST=1,KSTORM
C
         CALL FSTOCR(IOVITL,IOPTF,IDATEZ,IUTCZ,STMNAM(KST)//STMID(KST),
     1               IBMETH(KST),IERFST,FSTFLG(KST),QCFILE)

C  COPY IN THE RADIUS OF 15 M/S WINDS IN EACH QUADRANT

         R15WND(1)=R15NE(KST)
         R15WND(2)=R15SE(KST)
         R15WND(3)=R15SW(KST)
         R15WND(4)=R15NW(KST)

C  BOGUSING METHODS:

C  MNIBOG=T - A QUICK, MODEL-INDEPENDENT BOGUSING METHOD THAT IS
C             DESIGNED TO GIVE WINDS OUT TO SEVERAL MULTIPLES OF THE
C             RADIUS OF MAXIMUM WIND. MNIBOG SHOULD BE USED IN CASES
C             WHERE THE DATA DENSITY AROUND THE TROPICAL CYCLONE IS
C             RELATIVELY HIGH, SO THAT THE PURPOSE OF THE DATA IS TO
C             LOCATE THE VORTEX CENTER MORE ACCURATELY
C  VORDIV=T - VORTICITY AND DIVERGENCE ARE THE BOGUSING VARIABLES.  AT
C             THE STORM POSITION, VORTICITY AND CONVERGENCE MAXIMA ARE
C             DETERMINED FROM (SHAPIRO'S) VORTEX SUBROUTINE
C  VORDIV=F - THE "CLASSICAL" METHOD USING A WIND BOGUS THAT COVERS AT
C             LEAST THE AREA OF CLOSED CIRCULATION FOR THE VORTEX

C  SET UP INTERNAL PARAMETERS FOR MINI-BOGUSING

         IF(MNIBOG)  THEN
            MODTYP=0
            IBMETH(KST)=2
            RMXSTM(KST)=RMAX(KST)
            VTBOG(KST)=-99.0
            MWAVEZ=99
            SP1DWL=1.0

C  LOOK AT THE RESULTS OF THE GUESS SCAN PROGRAM AND UPDATE THE AREAL
C    COVERAGE OF THE BOGUS WINDS. FOR DETAILS, SEE SUBROUTINE BOGMTH.

            IF(.NOT. NOGES)  THEN
               CALL BOGMTH(IUNTGV,IUNTBH,MNIBOG,RMXMNB,STMLAT(KST),
     1                     STMLON(KST),VTBOG(KST),RMXMNI(KST),IDATEZ,
     2                     IBMETH(KST),STMNAM(KST),STMID(KST),ihrreq)

            ELSE
               RMXMNI(KST)=RMXMNB
            ENDIF

            WRITE(6,13) NOGES,FACRMW,RMXMNB,RMXMNI(KST)
   13 FORMAT(/'...MINI-BOGUSING PARAMETERS: NOGES=',L2,', FACRMW=',F5.1,
     1       ', ORIGINAL RMXMNB=',F7.1,', UPDATED RMXMNI=',F7.1)

         ELSE

C  FOR WIND BOGUSING:
C  LOOK AT THE RESULTS OF THE GUESS SCAN PROGRAM AND DECIDE ON THE
C    BOGUSING METHOD.  SEE DETAILS IN SUBROUTINE BOGMTH

            CALL BOGMTH(IUNTGV,IUNTBH,MNIBOG,RMAX(KST),STMLAT(KST),
     1                  STMLON(KST),VTBOG(KST),RMXSTM(KST),IDATEZ,
     2                  IBMETH(KST),STMNAM(KST),STMID(KST),ihrreq)
         ENDIF

         IF(.NOT. VORDIV)  THEN
            RMXBOG(KST)=RFAC(IBMETH(KST),RMXSTM(KST))

C  COPY THE RADIUS OF 15 M/S WINDS BACK OUT IN EACH QUADRANT

            R15NE(KST)=R15WND(1)
            R15SE(KST)=R15WND(2)
            R15SW(KST)=R15WND(3)
            R15NW(KST)=R15WND(4)

C  VORTICITY AND DIVERGENCE BOGUSING: OVERRIDE THE RESULTS OF BOGMTH

         ELSE
            IBMETH(KST)=2

C  CHANGE APPARENT BOGUSING METHOD FOR VERY WEAK CIRCULATIONS

            IF(PENV(KST)-PCEN(KST) .LT. 4.0)  IBMETH(KST)=2

            RMXSTM(KST)=RMAX(KST)
            RMXBOG(KST)=RFAC(IONE,RMXSTM(KST))
            IF(VTBOG(KST) .LT. 0.0)  VTBOG(KST)=VTDFLT
         ENDIF
      ENDDO

C-----------------------------------------------------------------------

      WRITE(6,51) (KS,STMNAM(KS)//STMID(KS),RMAX(KS),RMXSTM(KS),
     1             RMXBOG(KS),KS=1,KSTORM)
   51 FORMAT(/'...OBSERVED RMAX, REVISED RMAX, AND RADIUS OF ',
     1       'BOGUSING AREA ARE:'/(10X,I3,2X,A12,3X,3F8.1))

C  CHECK FOR OVERLAP IN BOGUSING AREA FOR ALL STORMS

      ISHAPE=1
      CALL OVRLAP(IUNTSL,IUNTBH,KSTORM,MAXPTS,ISHAPE,DELTA,STMLAT,
     1            STMLON,RMXBOG,RMAX,RLATP,RLONP,IBMETH,OVRFLG)

C  SET UP LEVELS AND VARIABLES TO BE BOGUSED

      CALL SETUP(MODTYP,IMFLTP,IVOTYP,IVFLTP,IPREQ,IPREQZ,IPDUM,NPREQ,
     1           IVREQ,IVREQZ,IVDUM,NVREQ)

      CALL GRABIM(IPREQ,NPREQ,IVREQ,NVREQ,NPREQM,NVREQM,PTOPAZ)

      CALL GRABIV(IVOTYP,IVFLTP,IPREQ,NPREQM,IVREQ,NVREQM,PTOPAZ)

C  FOR THE MODEL ENVIRONMENT:
C  PUT ALL NECESSARY MODEL INFORMATION IN THE ARRAY IN PREPARATION FOR
C    INTERPOLATING TO THE TEMPLATE POINTS AND HORIZONTAL AVERAGING.

      IF(.NOT. VORDIV)  THEN
         KLVLS=KLDIM
         CALL GRABEN(IUNTMO,MODTYP,IMFLTP,KLVLS,JVBOG)
      ENDIF

C-----------------------------------------------------------------------

C  DO ALL STORMS THAT DO NOT HAVE AN OVERLAP FLAG

      DO KST=1,KSTORM
         IF(OVRFLG(KST))  GO TO 1000

C  SET BOGUS DATA SEPARATION AS APPROPRIATE FOR THE STORM SIZE RMXCMB IS
C    THE MAXIMUM RADIUS FOR WHICH BOGUS DATA WILL BE ADDED TO THE
C    PREPBUFR FILE.  THE SEPARATION IS SET TO A MINIMUM OF 0.4 TIMES
C    RMXCMB.

         IF(MNIBOG)  THEN
CCC         CALL R15FND(R15WND,STMDIR(KST),RMXSTM(KST),R15AVG)

C**   3/29/92  CHANGED R15AVG TO RMXSTM IN THE FOLLOWING IF BLOCK.

            IF(RMW(KST) .GT. 0)  THEN
               RMXCMB=MIN(MAX(FACRMW*RMW(KST),RMXMNI(KST)),RMXSTM(KST))
            ELSE
               RMXCMB=MIN(RMXMNI(KST),RMXSTM(KST))
            ENDIF

         ELSE
            RMXCMB=RMXSTM(KST)
         ENDIF

         DELSTM=MIN(DELTA,RMXCMB*0.4E3/DEGLAT)

C  ******  BEGIN ENVIRONMENTAL WIND SECTION  ******

         IF(.NOT. VORDIV)  THEN

C  CONSTRUCT A TEMPLATE SET OF POINTS FOR AVERAGING OVER THE STORM
C    LOCATION

            ISHAPE=0
            DELAVG=MIN(DELSTM,1.0)
            CALL TEMPLT(ISHAPE,DELAVG,STMLAT(KST),STMLON(KST),
     1                  RMXSTM(KST),MAXPTS,MZZ,NZZ,RLATMN,RLATMX,RLONMN,
     2                  RLONMX,RLATP,RLONP,NPTS)
C SJL 4/12/16 added arguments in lower case
            CALL TEMWT(stmlat(kst),stmlon(kst),rmxstm(kst),RLATP,RLONP,
     1                 WTP,delavg,NPTS)

C  CALCULATE AVERAGE OF FILTERED ENVIRONMENTAL WIND OVER TEMPLATE POINTS

            WRITE(6,101) STMNAM(KST)//STMID(KST),RMXSTM(KST),PTOP(KST),
     1                   MNIBOG
            WRITE(IUNTBH,101) STMNAM(KST)//STMID(KST),RMXSTM(KST),
     1                        PTOP(KST),MNIBOG
  101 FORMAT(///' ...CALLING FAVWND FOR STORM ',A12,' FILTERED, ',
     1       'AVERAGE ENVIRONMENTAL WIND WILL BE CALCULATED.'/
     2       ' ...RMAX, PTOP,MNIBOG=',2F11.1,L2)
            CALL FAVWND(MODTYP,JVBOG,IUNTBH,PTOP(KST),RLONP,RLATP,WTP,
     1                  NPTS,MNIBOG)

C  PICK THE APPROPRIATE TRUNCATION IN HEIGHT AND WAVENUMBER SPACE THAT
C    AGREES WITH THE CURRENT STORM MOTION.  PROVISION IS MADE FOR A
C    PROPAGATION VECTOR THAT IS A DIFFERENCE BETWEEN THE ENVIRONMENTAL
C    FLOW AND THE OBSERVED STORM MOTION.

C**         UPROP=-1.0
C**         VPROP=1.0
            UPROP=0.0
            VPROP=0.0
            WRITE(6,201) STMNAM(KST)//STMID(KST),UPROP,VPROP,MNIBOG
            WRITE(IUNTBH,201) STMNAM(KST)//STMID(KST),UPROP,VPROP,MNIBOG
  201 FORMAT(///' ...CALLING SETFEN FOR STORM ',A12,' FILTERED, ',
     1       'ENVIRONMENTAL WIND THAT'/4X,'BEST FITS PERSISTENCE MINUS',
     2       ' UPROP,VPROP=',2F8.2,' WILL BE CALCULATED.'/4X,'MNIBOG=',
     3       L2)
            MWENV=MWAVEZ
            ITRNCZ=-1
            KLSTMZ=0
            CALL SETFEN(IUNTBH,STMDIR(KST),STMSPD(KST),UPROP,VPROP,
     1                  MWENV,ITRNCZ,KLSTMZ,MNIBOG)

C  CONSTRUCT A TEMPLATE SET OF POINTS FOR CALCULATING THE BOGUS
C    ENVIRONMENTAL WINDS.

            DELTAB=DELSTM
            ISHAPE=1
            ZLAT=ZNEAR(STMLAT(KST),DELTAB)
            ZLON=ZNEAR(STMLON(KST),DELTAB)
            CALL TEMPLT(ISHAPE,DELTAB,ZLAT,ZLON,RMXBOG(KST),MAXPTS,MMX,
     1                  NNY,RLATMN,RLATMX,RLONMN,RLONMX,RLATP,RLONP,
     2                  NPTS)

C  SET THE STORM NAME, DATE AND TIME

            CALL SETDTS(IDATEZ,IUTCZ,STMNAM(KST)//STMID(KST))

C  WRITE THE BOGUS AREA GEOMETRY TO BOGUS DOMAIN FILE

            IF(IBMETH(KST) .EQ. 1) THEN
               RMAXZ=RMXBOG(KST)
            ELSE
               RMAXZ=RMXSTM(KST)
            ENDIF

C  CONSTRUCT BOGUS ENVIRONMENTAL DATA AT ALL TEMPLATE POINTS

CCCC        IUNTFE=IUNTFE+1
            REWIND IUNTFE
            CALL FENBOG(IUNTFE,MMX,NNY,IBMETH(KST),RLATMN,RLATMX,RLONMN,
     1                  RLONMX,FRACST,ENVBOG,RLATP,RLONP,NPTS,MNIBOG,
     2                  modtyp)
            CLOSE(UNIT=IUNTFE,STATUS='KEEP')

            CALL RITCR2(IUNTBD,STMLAT(KST),STMLON(KST),RMAXZ,RLATMN,
     1                  RLATMX,STMNAM(KST),STMID(KST))

C  ******  END ENVIRONMENTAL WIND SECTION  ******

         ELSE

C  WHEN VORDIV=T, WE NEED THE FOLLOWING CALCULATIONS:
C  CONSTRUCT A TEMPLATE SET OF POINTS FOR CALCULATING THE BOGUS
C    ENVIRONMENTAL WINDS.
C  WRITE DOMAIN BOUNDARIES TO THE BORDER FILE

            DELTAB=DELSTM
            ISHAPE=1
            ZLAT=ZNEAR(STMLAT(KST),DELTAB)
            ZLON=ZNEAR(STMLON(KST),DELTAB)
            CALL TEMPLT(ISHAPE,DELTAB,ZLAT,ZLON,RMXSTM(KST),MAXPTS,MMX,
     1                  NNY,RLATMN,RLATMX,RLONMN,RLONMX,RLATP,RLONP,
     2                  NPTS)

            CALL RITCR2(IUNTBD,STMLAT(KST),STMLON(KST),RMXSTM(KST),
     1                  RLATMN,RLATMX,STMNAM(KST),STMID(KST))

        ENDIF

C  NOW, THE VORTEX:
C  CONSTRUCT A VORTEX FOR EACH STORM
C  **** IMPORTANT NOTE: FOR IVFLTP=1, THE VORTEX ALREADY EXISTS ON DISK
C                       (A SEPARATE FILE FOR EACH VORTEX)
C                       THE DATA ARE EXTRACTED IN MAKVOR USING ROUTINE
C                       MM3DVO.

C  COPY IN THE RADIUS OF 15 M/S WINDS IN EACH QUADRANT

         R15WND(1)=R15NE(KST)
         R15WND(2)=R15SE(KST)
         R15WND(3)=R15SW(KST)
         R15WND(4)=R15NW(KST)
         WRITE(6,307) VORDIV,IUNTVD,IUNTDH,SP1DWL,DIVFAC,IBMETH(KST),
     1                VTBOG(KST),NOBWMN
  307 FORMAT(/'...CALLING MAKVOR WITH VORDIV,IUNTVD,IUNTDH,SP1DWL,',
     1       'DIVFAC,IBMETH(KST),VTBOG(KST),NOBWMN='/4X,L2,2I4,F8.1,
     2       F6.2,I4,F8.2,I3)
         CALL MAKVOR(IDATEZ,IUTCZ,IUNTPN,IUNTPV,IUNTTK,IUNTDO,IUNTRV,
     1               IUNTBH,IUNTDH,IUNTVD,IOVITL,IVOTYP,IVFLTP,
     2               IBMETH(KST),DELTAB,DELTAV,SP1DWL,RLATMN,RLATMX,
     3               RLONMN,RLONMX,STMLAT(KST),STMLON(KST),STMDIR(KST),
     4               STMSPD(KST),RMXSTM(KST),PENV(KST),PCEN(KST),
     5               PTOP(KST),DIVFAC,PCENF,R15WND,VTBOG(KST),NOBWMN,
     6               VORDIV,STMID(KST),STMNAM(KST),ihrreq)

C  SKIP ALL REMAINING PROCEDURES FOR VORTICITY/DIVERGENCE BOGUSING

         IF(VORDIV)  GO TO 1000

         WRITE(6,407) IUNTFV,IUNTTK,IUNTDO,FSTBOG
  407 FORMAT(/'...CALLING PROVOR WITH PROCESSED VORTEX FILE=',I3,
     1        ' DUMMY TRACK FILE=',I3,' DUMMY DOMAIN FILE=',I3,
     2        ' FSTBOG=',L2)

         CALL PROVOR(IUNTFV,IUNTTK,IUNTDO,FSTBOG)
         FSTBOG=.FALSE.

C  COMBINE VORTEX AND ENVIRONMENTAL BOGUS DATA

         NNY2=2*NNY

C  SET RADIUS FOR MINI BOGUSING AREA

         LSTORM = LSTORM + 1

         WRITE(IUNTBG,6283) LSTORM
 6283 FORMAT(' START HERE FOR STORM',I3)
         CALL COMBIN(IEFLTP,IUNTFE,MXUNTE,IUNTFV,ADVORT,IUNTBG,RLATMN,
     1               RLATMX,RLONMN,RLONMX,ENVBOG,MMX,NNY2,STMLAT(KST),
     2               STMLON(KST),STMDIR(KST),STMSPD(KST),IDATE(KST),
     3               IUTC(KST),PCEN(KST),RMXCMB,IBMETH(KST))
         WRITE(IUNTBG,6284) LSTORM
 6284 FORMAT(' END HERE FOR STORM',I3)

         BLATMN(LSTORM) = RLATMN
         BLATMX(LSTORM) = RLATMX
         BLONMN(LSTORM) = RLONMN
         BLONMX(LSTORM) = RLONMX
         vmax_save(lstorm) = vmax(kst)

 1000    CONTINUE
      ENDDO

C-----------------------------------------------------------------------

      IF(APPREP.AND.LSTORM.GT.0)  THEN

         REWIND IUNTBG

C  COPY EXISTING PREPBUFR FILE TO A NEW VERSION AND ADD BOGUS DATA FROM
C   ALL STORMS AT ONCE {ALSO CAN FLAG EXISTING PRESSURE DATA IN THE
C   VICINITY OF THE STORM(S)}

         WRITE(6,971)
  971 FORMAT(/110('v')/110('v')/'...CALLING EDTPRP')
         CALL EDTPRP(BLATMN,BLATMX,BLONMN,BLONMX,RMW,STMLAT,STMLON,
     $               IUNTPN,IUNTPO,IUNTBG,LSTORM,vmax_save,stmnam)
         WRITE(6,972)
  972    FORMAT(/'...LEAVING EDTPRP'/110('a')/110('a')/)
      END IF

C-----------------------------------------------------------------------

      WRITE(6,2003)
 2003 FORMAT(////20X,'******************************************'/
     1           20X,'******************************************'/
     2           20X,'****                                  ****'/
     3           20X,'**** SUCCESSFUL COMPLETION OF SYNDATA ****'/
     4           20X,'****                                  ****'/
     5           20X,'******************************************'/
     6           20X,'******************************************')

      CALL W3TAGE('SYNDAT_SYNDATA')
      STOP
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE BOGMTH(IUNTGV,IUNTBH,MNIBOG,RMAXZ,STMLTZ,STMLNZ,VTBOGZ,
     1                  RMXSTZ,IDATEZ,IBMTHZ,STMNMZ,STMIDZ,ihrreq)

      PARAMETER (MAXSTM=70)

      CHARACTER STMNAM*9,STMID*3,RSMC*4

      LOGICAL FSTFLG

      REAL(8)  DISTSP_8

      DIMENSION STMNAM(MAXSTM),STMLAT(MAXSTM),STMLON(MAXSTM),
     1          STMDIR(MAXSTM),STMSPD(MAXSTM),IDATE(MAXSTM),
     2          IUTC(MAXSTM),RMAX(MAXSTM),PENV(MAXSTM),PCEN(MAXSTM),
     3          PTOP(MAXSTM),RSMC(MAXSTM),RMW(MAXSTM),VMAX(MAXSTM),
     4          R15NW(MAXSTM),R15NE(MAXSTM),R15SE(MAXSTM),R15SW(MAXSTM),
     5          STMID(MAXSTM),FSTFLG(MAXSTM)

      CHARACTER STMNMZ*(*),STMIDZ*(*)
      LOGICAL MNIBOG

      DATA IOPT/5/,IPRNT/0/,IHRWIN/0/

C  DECISION-MAKING PROGRAM FOR THE BOGUSING METHOD.
C    IBMETH=1: FIRST TIME STORM, NO CIRCULATION IN GUESS FIELD
C    IBMETH=2: >= SECOND TIME STORM, NO CIRCULATION IN GUESS FIELD
C    IBMETH=3: >= SECOND TIME STORM, DISPLACED CIRCULATION IN GUESS
C              FIELD LESS THAN OBSERVED RMAX (EXTENT OF STORM
C              CIRCULATION
C    IBMETH=4: > SECOND TIME STORM, DISPLACED CIRCULATION IN GUESS FIELD
C              GREATER THAN OBSERVED RMAX (EXTENT OF STORM CIRCULATION)

C  PRELIMINARIES

      WRITE(6,1) IUNTGV,STMNMZ//STMIDZ,IBMTHZ,RMAXZ
      WRITE(IUNTBH,1) IUNTGV,STMNMZ//STMIDZ,IBMTHZ,RMAXZ
    1 FORMAT(/'...ENTERING BOGMTH AND READING GESVIT FROM UNIT',I3,
     1       ' FOR STORM/ID,FIRST OCR.,OBS.RMAX=',/,4X,A,I3,F7.1)

C  LOOK FOR THE STORM IN THE VITALS STATISTICS FORMAT FILE PRODUCED BY
C    PROGRAM GESSCN.

      IDTREQ  =IDATEZ
      STMID(1)=STMIDZ
      CALL NEWVIT(IUNTGV,IPRNT,IOPT,IERVIT,MAXSTM,KSTORM,IDTREQ,IHRREQ,
     1            IHRWIN,IDATE,IUTC,STMLAT,STMLON,STMDIR,STMSPD,PCEN,
     2            PENV,RMAX,VMAX,RMW,R15NE,R15SE,R15SW,R15NW,PTOP,
     3            FSTFLG,STMNAM,STMID,RSMC)

      IF(KSTORM.LE.0)  THEN
         RMXSTZ=RMAXZ
         VTBOGZ=-99.0
         WRITE(6,11)  KSTORM,RMAXZ,VTBOGZ
         WRITE(IUNTBH,11)  KSTORM,RMAXZ,VTBOGZ
   11    FORMAT(/'...KSTORM=',I3,', WHICH MEANS THAT THE STORM COULD ',
     1          'NOT BE IDENTIFIED IN THE GUESS FIELD.'/4X,'RMAX IS ',
     2          'KEPT AT',F7.1,' KM. AND VTBOGZ=',F7.1)
         WRITE(6,641) IBMTHZ,RMAXZ,RMXSTZ,VTBOGZ
         WRITE(IUNTBH,641) IBMTHZ,RMAXZ,RMXSTZ,VTBOGZ
  641    FORMAT('...LEAVING BOGMTH WITH IBMTHZ,RMAXZ,RMXSTZ,VTBOGZ='/4X,
     1          I3,3F8.2)

      ELSE
         WRITE(6,7) KSTORM,STMLAT(KSTORM),STMLON(KSTORM)
         WRITE(IUNTBH,7) KSTORM,STMLAT(KSTORM),STMLON(KSTORM)
    7    FORMAT('...GESVIT FILE HAS PRODUCED',I3,' RECORDS WITH ',
     1          'LAT/LON=',2F8.2)
         IF(KSTORM .EQ. 1)  THEN
            WRITE(6,15)
            WRITE(IUNTBH,15)
   15       FORMAT('...CIRCULATION HAS BEEN FOUND IN THE GUESS FIELD.')

            GESERR=DISTSP_8(STMLAT(KSTORM),STMLON(KSTORM),STMLTZ,STMLNZ)
     1       * 1.E-3

            IF(MNIBOG)  THEN
               WRITE(6,17)  GESERR,RMAXZ
               WRITE(IUNTBH,17)  GESERR,RMAXZ
   17          FORMAT(/'...GUESS ERROR=',F8.1,' KM AND INITIAL MINI-',
     1                'BOGUSING AREA COVERAGE=',F8.1)
               IF(GESERR .GT. RMAXZ)  THEN
                  RMXSTZ=GESERR
                  WRITE(6,19)
                  WRITE(IUNTBH,19)
   19             FORMAT('...GUESS ERROR EXCEEDS AREA COVERAGE.  ',
     1                   'COVERAGE EXPANDED.')
               ELSE
                  RMXSTZ=RMAXZ
                  WRITE(6,21)
                  WRITE(IUNTBH,21)
   21             FORMAT('...GUESS ERROR LESS THAN AREA COVERAGE.  ',
     1                   'COVERAGE REMAINS THE SAME.')
               ENDIF

C  STANDARD WIND BOGUSING TECHNIQUE.

            ELSE
               IF(GESERR+RMAX(KSTORM) .LE. RMAXZ)  THEN
                  IBMTHZ=3
                  RMXSTZ=RMAXZ
               ELSE
                  IBMTHZ=4
                  RMXSTZ=RMAXZ
               ENDIF

               VTBOGZ=VMAX(KSTORM)
            ENDIF
            WRITE(6,41) IBMTHZ,RMAXZ,GESERR,RMAX(KSTORM),RMXSTZ,VTBOGZ
            WRITE(IUNTBH,41) IBMTHZ,RMAXZ,GESERR,RMAX(KSTORM),RMXSTZ,
     1                       VTBOGZ
   41       FORMAT('...LEAVING BOGMTH WITH IBMTHZ,RMAXZ,GESERR,',
     1             'RMAX(KSTORM),RMXSTZ,VTBOGZ=',/,4X,I3,5F8.2)

         ELSE
            WRITE(6,31)  KSTORM
   31       FORMAT(/'******KSTORM=',I4,', WHICH IS GREATER THAN ',
     1             'ALLOWED FROM GESSCN.')
            CALL ABRT1(' BOGMTH',31)
         ENDIF

      ENDIF

      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
C     *****************************
C     ****  SUBROUTINE GRABMO  ****
C     ****     ENTRY GRABIM    ****
C     ****     ENTRY GRABEN    ****
C     ****     ENTRY FAVWND    ****
C     ****     ENTRY SETFEN    ****
C     ****     ENTRY FENBOG    ****
C     ****     ENTRY FNDCTR    ****
C     *****************************
C
      SUBROUTINE GRABMO(IUNTMO,IUNTBH,MODTYP,IMFLTZ,JVARS,KLVLS,KLSTMZ,
     1                  ENVBOG,JVBOG,RLATP,RLONP,WTP,NPTS,PT,FRACST,
     2                  MWENVZ,ITRNCZ,IMETHZ,MNIBOG,iuntfe,mmx,nny,
     3                  rlatmn,rlatmx,rlonmn,rlonmx,ipreq,ivreq,klmax,
     4                  jvmax,dirstm,spdstm,uprop,vprop)

      PARAMETER(MAXBGK=10)
      PARAMETER(MAXBGV= 7)
      PARAMETER (MAXWVT=8)
      PARAMETER (MAXAVL=2*MAXBGK-1)

      PARAMETER (MDIM=35,NDIM=35)
      PARAMETER (KLDIM= 8)
      PARAMETER (KDTDIM=5)
      PARAMETER (KDXDIM=KDTDIM*KLDIM)

      CHARACTER MTITLE*102

      LOGICAL MNIBOG

      SAVE

      DIMENSION IPREQ(KLVLS),ILVL(MAXBGK),INDXP(MAXBGK),IVREQ(JVARS),
     1          IVAR(MAXBGV),INDXV(MAXBGV),IPREQZ(MAXBGK),
     2          IVREQZ(MAXBGV),IWVREQ(MAXWVT),IWVRQZ(MAXWVT)
      DIMENSION RLATP(NPTS),RLONP(NPTS),WTP(NPTS),
     1          STRWND(MAXWVT,MAXAVL,4),PWT(MAXAVL),ILVAV(MAXAVL),
     2          STRDIF(MAXWVT,MAXAVL,2)
      DIMENSION ENVBOG(NPTS,2),CORNR(4,2),ZCORN(4,2),IWVCRN(2),ITCRN(2)

      DIMENSION A(KDXDIM,MDIM,NDIM)

C  ****************************************************************
C  ****************************************************************
C  ****  IMPORTANT NOTE:  GRABEN IS CALLED ONCE AND FOR ALL    ****
C  ****  FOR SPECTRAL MODELS SINCE COEFFICIENTS ARE GLOBAL.    ****
C  ****  HOWEVER, FOR A LIMITED AREA MODEL, CALLS TO STORE     ****
C  ****  THE MODEL GRID POINTS INTO ARRAY MUST BE DONE ON      ****
C  ****  ON A STORM BY STORM BASIS.  IMPORTANT CHANGE:         ****
C  ****  8/22/90: ARRAY MADE LOCAL TO SUBROUTINE SPMODL/GPMODL ****
C  ****************************************************************
C  ****************************************************************
C
C  KEY TO REQUESTED INPUT LEVELS AND VARIABLES:
C
C       INPUT LEVELS ARE CURRENTLY A CHOICE OF MANDATORY PRESSURES
C         FROM 1000-100 KPA
C
C       INPUT VARIABLES ARE:
C
C         1) TEMPERATURE
C         2) RELATIVE HUMIDITY
C         3) HEIGHT
C         4) U WIND
C         5) V WIND
C         6) VORTICITY (TO GET ROTATIONAL WIND)
C         7) DIVERGENCE (TO GET DIVERGENT WIND)

      DATA IWVREQ/5,6,8,10,20,30,40,80/,NWVRQ1/1/,NWVRQ2/7/,IROMB/1/,
     1     ITRIA/0/,I40WV/40/,IWRITE/6/

C  THIS SUBROUTINE DIRECTS THE GRABBING OF THE PROPER INFORMATION FROM
C    THE APPROPRIATE FILE CONTAINING THE ENVIRONMENTAL FIELDS.  THERE
C    ARE SEVERAL STEPS:

C    FIRST: PERFORM SOME BASIC CHECKS FOR SPACE AVAILABILITY FOR BOTH
C           LEVELS AND NUMBER OF VARIABLES

C    SECOND: DETERMINE THE AVAILABILITY OF VARIOUS VERTICAL LEVELS AND
C            VARIABLES AND SET UP THE READING INDICES FOR EACH LEVEL
C            (INDXP) AND EACH VARIABLE (INDXV)

C    THIRD: PERFORM SOME BASIC SPACE CHECK ON MODEL HORIZONTAL STORAGE.
C           THEN READ THE ENVIRONMENTAL FIELD FILE AND PUT THE REQUIRED
C           INFORMATION INTO ARRAY.  THIS INFORMATION CAN BE EITHER
C           SPECTRAL COEFFICIENTS OR GRID POINT INFORMATION.
C           SUFFICIENT STORAGE MUST BE ALLOCATED IN THE CALLING PROGRAM.

C  ENTER THE MAXIMUM LEVEL TO BE CONSIDERED FOR ALL STORMS

C-----------------------------------------------------------------------

C  ++++++++++++++++++++++++
C  ++++  ENTRY GRABIM  ++++
C  ++++++++++++++++++++++++
C
      ENTRY GRABIM(IPREQ,KLVLS,IVREQ,JVARS,KLMAX,JVMAX,PT)

C  FOR PHYSICAL REASONS AS WELL AS COMPUTATIONAL EFFICIENCY, WE
C    CONSIDER ONLY A SINGLE LEVEL ABOVE THE LEVEL OF THE DEEPEST
C    CYCLONIC CIRCULATION (PT)

      DO KL=1,KLVLS
         NPREQ=KL
         IF(NINT(PT*10.) .GE. IPREQ(KL)*10)  GO TO 2
      ENDDO
    2 CONTINUE

      IF(NPREQ .NE. KLVLS)  THEN
      WRITE(6,3) NPREQ,IPREQ(NPREQ),KLVLS,IPREQ(KLVLS)
    3 FORMAT(/'...IN GRABIM, REQUESTED LEVELS HAVE BEEN TRUNCATED ',
     1       'TO CONFORM TO THE HEIGHT OF THE DEEPEST CYCLONIC ',
     2       'CIRCULATION.'/4X,'TRUNCATED, REQUESTED INDEX, PRESSURE ',
     3       'LEVEL ARE',4I5)
      ENDIF

C  STORE REQUESTED PRESSURE LEVELS AND VARIABLES LOCALLY.  THEN PERFORM
C    SOME BASIC CHECKS FOR SUFFICIENT SPACE, LEVELS THEN VARIABLES

C  STORE LEVELS TO BE BOGUSED HERE

      NP=0
      DO 5 NZ=1,NPREQ

      IF(NP .LE. MAXBGK)  THEN
      NP=NP+1
      IPREQZ(NP)=IPREQ(NZ)

      ELSE
      WRITE(6,4) KLVLS,NPREQ,NP
    4 FORMAT(/'******INSUFFICIENT STORAGE ALLOCATED FOR STORING ',
     1       'LOCATION INDICES IN GRABIM.',/,10X,'REQUESTED SPACE=',
     2       'KLVLS=',I5,' WHILE REQUIRED SPACE=NPREQ=',I5,/,10X,
     3       'LEVELS WILL BE REDUCED TO KLMAX=',I5,' ACCORDINGLY')
      GO TO 6
      ENDIF

    5 CONTINUE

    6 KLMAX=NP

C  STORE VARIABLES TO BE BOGUSED HERE

      NV=0
      DO 15 NZ=1,JVARS
      IF(NV .LE. MAXBGV)  THEN
      NV=NV+1
      IVREQZ(NV)=IVREQ(NZ)

      ELSE
      WRITE(6,14) JVARS,MAXBGV
   14 FORMAT(/'******INSUFFICIENT STORAGE ALLOCATED FOR STORING ',
     1       'LOCATION INDICES IN GRABIM.',/,10X,'REQUESTED SPACE=',
     2       'JVARS=',I5,' WHILE AVAILABLE SPACE=MAXBGV=',I5,/,10X,
     3       'THEREFORE, WE MUST TERMINATE THE PROGRAM')
      CALL ABRT1(' GRABIM',14)

      ENDIF

   15 CONTINUE

      JVMAX=NV

      klmaxx=klmax
      jvmaxx=jvmax

      RETURN

C-----------------------------------------------------------------------

C  ++++++++++++++++++++++++
C  ++++  ENTRY GRABEN  ++++
C  ++++++++++++++++++++++++

      ENTRY GRABEN(IUNTMO,MODTYP,IMFLTZ,KLVLS,JVBOG)

C  SET THE VERTICAL INDEXING FOR EACH MODEL AND FILE TYPE.  MODEL AND
C    FILE TYPES ARE CATALOGED IN SUBROUTINE SETMOD AND BELOW:

C    CURRENT MODEL AND FILE TYPES ARE:
C      MODTYP= 0: BOGUSING METHOD IS NOT MODEL DEPENDENT
C      MODTYP= 1: SPECTRAL MODEL

C    FILE TYPES:
C      IMFLTP=1: NCEP GLOBAL SPECTRAL MODEL, OPERATIONAL R40 PRESSURE
C                COEFFICIENT FILE == CALL SLVSP1 TO SET UP VERTICAL
C                                    LEVELS
C                                 == CALL SVRSP1 TO SET UP VARIABLES
C      IMFLTP=2: NCEP GLOBAL SPECTRAL MODEL, OPERATIONAL PRESSURE
C                COEFFICIENTS OF VORTICITY, DIVERGENCE
C                                 == CALL SLVSP2 TO SET UP VERTICAL
C                                    LEVELS
C                                 == CALL SVRSP2 TO SET UP VARIABLES
C      IMFLTP>2: NOT IMPLEMENTED

C      MODTYP=-1: GRID POINT MODEL  *** NOT IMPLEMENTED ***

      IMFLTP=IMFLTZ
      WRITE(6,31)  MODTYP,IMFLTP,KLVLS,NPREQ
   31 FORMAT(/'...ENTERING GRABEN, MODTYP,IMFLTP,KLVLS,NPREQ=',4I6)
      IF(MODTYP .EQ. 0 .OR. MODTYP .EQ. 1)  THEN
      IF(IMFLTP .EQ. 1)  THEN
        CALL SLVSP1(KLMAXx,IPREQZ,ILVL,INDXP,KLBOG)
        CALL SVRSP1(JVMAXx,IVREQZ,IVAR,INDXV,JVBOGZ)
      ELSE IF(IMFLTP .EQ. 2)  THEN
        CALL SLVSP2(KLMAXx,IPREQZ,ILVL,INDXP,KLBOG)
        CALL SVRSP2(JVMAXx,IVREQZ,IVAR,INDXV,JVBOGZ)
      ENDIF
      JVBOG=JVBOGZ

      ELSE IF(MODTYP .EQ. -1) THEN
      WRITE(6,51) MODTYP
   51 FORMAT(/'******MODTYP=',I5,' (GRID PT MODEL) IS NOT INSTALLED')
      CALL ABRT1(' GRABEN',51)
      ELSE
      WRITE(6,61) MODTYP
   61 FORMAT(/'******MODTYP=',I5,' (UNKNOWN MODEL) IS NOT INSTALLED')
      CALL ABRT1(' GRABEN',61)
      ENDIF
C
      WRITE(6,81) (KP,IPREQZ(KP),KP=1,KLMAXx)
   81 FORMAT(/'...REQUESTED PRESSURE LEVELS IN GRABEN ARE:'/(10X,2I5))
      WRITE(6,83) MODTYP,IMFLTP,(KP,ILVL(KP),INDXP(KP),KP=1,KLBOG)
   83 FORMAT(/'...FOR MODEL TYPE=',I3,' AND MODEL FILE TYPE=',I3,','/4X,
     1       'ACTUAL PRESSURE LEVELS AND INDICES IN GRABEN ARE:'/(10X,
     2       3I5))
      WRITE(6,87) (JV,IVREQZ(JV),JV=1,JVMAXx)
   87 FORMAT(/'...REQUESTED VARIABLES IN GRABEN ARE:'/(10X,2I5))
      WRITE(6,89) MODTYP,IMFLTP,(JV,IVAR(JV),INDXV(JV),JV=1,JVBOG)
   89 FORMAT(/'...FOR MODEL TYPE=',I3,' AND MODEL FILE TYPE=',I3,','/4X,
     1        'ACTUAL VARIABLES AND INDICES IN GRABEN ARE:'/(10X,3I5))

C  READ THE ENVIRONMENTAL FIELD FILE

      IF(MODTYP .EQ. 1)  THEN
      CALL MODL1(IUNTMO,KLBOG,JVBOG,
     1           MWAVE,INDXP,INDXV)
      IF(IMFLTP .EQ. 1) CALL RDSPP1(IUNTMO,KLBOG,JVBOG,
     1                              MWAVE,INDXP,INDXV)
      IF(IMFLTP .EQ. 2)
     1   CALL RDSPP2(IUNTMO,KLBOG,JVBOG,MWAVE,INDXP,INDXV)
      ENDIF

      KLVLS=KLBOG
      RETURN

C-----------------------------------------------------------------------

C  ++++++++++++++++++++++++
C  ++++  ENTRY FAVWND  ++++
C  ++++++++++++++++++++++++

      ENTRY FAVWND(MODTYP,JVBOG,IUNTBH,PT,RLONP,RLATP,WTP,NPTS,MNIBOG)

C  CHOSE WAVE NUMBER TRUNCATION

      ITRNC=ITRIA
      MWV=0
      DO 100 MW=NWVRQ1,NWVRQ2
      IF(IWVREQ(MW) .LE. MWAVE)  THEN
      MWV=MWV+1
      IWVRQZ(MWV)=IWVREQ(MW)
      ENDIF
  100 CONTINUE

      WRITE(6,101)  JVBOG,KLBOG,MODTYP,IMFLTP,NWVRQ1,NWVRQ2,MWV,MNIBOG,
     1              (IWVRQZ(MM),MM=1,MWV)
  101 FORMAT(/'...IN FAVWND, JVBOG,KLBOG,MODTYP,IMFLTP,NWVRQ1,NWVRQ2,',
     1       'MWV,MNIBOG,REQUESTED TRUNCS=',7I5,L2/10X,(10I5)//)

C  FIND INDEX FOR VORTICITY FIELD

      JVWND=-1
      DO 110 JV=1,JVBOG
      IF(IVAR(JV) .EQ. 6)  THEN
      JWNDVR=1
      JVWND=JV
      IPLUS=0
      ENDIF
  110 CONTINUE

      IF(JVWND .LT. 0)  THEN
      WRITE(6,111) JVBOG
  111 FORMAT(/'******VORTICITY FIELD COULD NOT BE FOUND. NOW WE LOOK',
     1       ' FOR INDEX OF TOTAL WIND, JVBOG=',I5)
      DO 120 JV=1,JVBOG
      IF(IVAR(JV) .EQ. 4)  THEN
      JWNDVR=2
      JVWND=JV
      IPLUS=1
      ENDIF
  120 CONTINUE

      IF(JVWND .LT. 0)  THEN
      WRITE(6,121) JVBOG,(IVAR(JV),JV=1,JVBOG)
  121 FORMAT(/'******SERIOUS ERROR AT #120 IN FAVWND: WIND INDEX ',
     1       ' COULD NOT BE FOUND. JVBOG,IVAR=',I5,/,(9X,10I5))
      CALL ABRT1(' FAVWND',120)
      ENDIF

      ENDIF

C  DETERMINE TOP LEVEL FOR EACH STORM

      DO 130 KL=1,KLBOG
      KLSTM=KL
      IF(NINT(PT*10.) .GE. ILVL(KL)*10)  GO TO 131
  130 CONTINUE
  131 CONTINUE
      IF(MNIBOG)  RETURN

C  LOOP OVER ALL LEVELS AND SPECTRAL TRUNCATIONS FOR ALL TEMPLATE POINTS

      DLEV1=0.5*REAL(ILVL(1)-ILVL(2))
      DO 160 KL=1,KLSTM
      IF(KL .LT. KLSTM)  DLEV2=0.5*REAL(ILVL(KL)-ILVL(KL+1))

      DO 150 MW=1,MWV

      UWND=0.0
      VWND=0.0

      DO 145 JWN=1,JWNDVR

      WT=0.0
      JVWNDZ=JVWND+JWN-1

      IF(MODTYP .EQ. 1)  THEN
      IF(JWN .EQ. 1)  THEN

c  && 4 comments
CC    WRITE(6,132) KL,JVWNDZ,ILVL(KL),IVAR(JVWNDZ),IWVRQZ(MW),IPLUS,
CC   1             ITRNC
CC132 FORMAT(/'...CALLING SETTRN FOR AVERAGE ENVIRONMENTAL WIND: ',
CC   1       'KL,JVWNDZ,LEVEL,IVAR,MWENV,IPLUS,ITRNC=',7I5)
      CALL SETTRN(KL,JVWNDZ,IWVRQZ(MW),IPLUS,ITRNC)
      ELSE
c  && 4 comments
CC    WRITE(6,134) KL,JVWNDZ,ILVL(KL),IVAR(JVWNDZ),IWVRQZ(MW),IPLUS,
CC   1             ITRNC
CC134 FORMAT(/'...CALLING SETRES FOR AVERAGE ENVIRONMENTAL WIND: ',
CC   1       'KL,JVWNDZ,LEVEL,IVAR,MWENV,IPLUS,ITRNC=',7I5)
      CALL SETRES(KL,JVWNDZ,IWVRQZ(MW),IPLUS,ITRNC)
      ENDIF
      ENDIF

      DO 140 NP=1,NPTS

      XX=RLONP(NP)
      YY=RLATP(NP)
      WT=WT+WTP(NP)

      IF(MODTYP .EQ. 1)  THEN
        IF(IVAR(JVWNDZ) .EQ. 6) THEN
        CALL UROSP1(XX,YY,JVWNDZ,KL,IWVRQZ(MW),ITRNC,UOUT)
        CALL VROSP1(XX,YY,JVWNDZ,KL,IWVRQZ(MW),ITRNC,VOUT)
        UWND=UWND+UOUT*WTP(NP)
        VWND=VWND+VOUT*WTP(NP)
        ELSE IF(IVAR(JVWNDZ) .EQ. 4) THEN
        CALL UVWSP1(XX,YY,JVWNDZ,KL,IWVRQZ(MW),IPLUS,ITRNC,UOUT)
        UWND=UWND+UOUT*WTP(NP)
        ELSE IF(IVAR(JVWNDZ) .EQ. 5) THEN
        CALL UVWSP1(XX,YY,JVWNDZ,KL,IWVRQZ(MW),IPLUS,ITRNC,VOUT)
        VWND=VWND+VOUT*WTP(NP)
        ELSE
        WRITE(6,137) JVWNDZ,IVAR(JVWNDZ),MODTYP
  137   FORMAT(/'******WIND INDEX NOT EQUAL TO 6 OR 4 IN FAVWND,',
     1         'JVWNDZ,IVAR(JVWNDZ),MODTYP=',/,10X,3I5)
        CALL ABRT1(' FAVWND',137)
        ENDIF
      ELSE
      ENDIF

c  && 2 comments
CC    WRITE(6,139) YY,XX,IWVRQZ(MW),ILVL(KL),UOUT,VOUT
CC139 FORMAT('...LAT,LON,WAVE,LEVEL,UOUT,VOUT=',2F10.2,2I5,2F10.3)

  140 CONTINUE

  145 CONTINUE
      UWND=UWND/WT
      VWND=VWND/WT
      STRWND(MW,KL,1)=UWND
      STRWND(MW,KL,2)=VWND
      CALL UV2DS(UWND,VWND,STRWND(MW,KL,3),STRWND(MW,KL,4))
      ILVAV(KL)=ILVL(KL)

  150 CONTINUE

      PWT(KL)=DLEV1+DLEV2
      DLEV1=DLEV2
  160 CONTINUE

C  PRESSURE WEIGHTED LAYER AVERAGES

      KLAVG=2*KLSTM-1
      DO 190 KLA=1,KLSTM-1

      DO 180 MW=1,MWV

      WT=0.0
      STRWND(MW,KLA+KLSTM,1)=0.0
      STRWND(MW,KLA+KLSTM,2)=0.0

      DO 170 KL=1,KLA+1
      WT=WT+PWT(KL)
      STRWND(MW,KLA+KLSTM,1)=STRWND(MW,KLA+KLSTM,1)+STRWND(MW,KL,1)*
     1                       PWT(KL)
      STRWND(MW,KLA+KLSTM,2)=STRWND(MW,KLA+KLSTM,2)+STRWND(MW,KL,2)*
     1                       PWT(KL)
  170 CONTINUE
      STRWND(MW,KLA+KLSTM,1)=STRWND(MW,KLA+KLSTM,1)/WT
      STRWND(MW,KLA+KLSTM,2)=STRWND(MW,KLA+KLSTM,2)/WT
      CALL UV2DS(STRWND(MW,KLA+KLSTM,1),STRWND(MW,KLA+KLSTM,2),
     1           STRWND(MW,KLA+KLSTM,3),STRWND(MW,KLA+KLSTM,4))
      ILVAV(KLA+KLSTM)=ILVL(1)*1000+ILVL(KLA+1)

  180 CONTINUE
  190 CONTINUE

      WRITE(6,191) (IWVRQZ(MW),MW=1,MWV)
  191 FORMAT(/20X,'U WIND AT TRUNCATED WAVE NUMBER VS. PRESSURE'/
     1       6X,'K',4X,'PRES',30X,'WAVE TRUNCATION',/,(15X,10I11,/))
      DO 195 KL=1,KLAVG
      WRITE(6,193)  KL,ILVAV(KL),(STRWND(MW,KL,1),MW=1,MWV)
  193 FORMAT(/3X,I3,I8,2X,10F11.3)
  195 CONTINUE

      WRITE(6,197) (IWVRQZ(MW),MW=1,MWV)
  197 FORMAT(///21X,'V WIND AT TRUNCATED WAVE NUMBER VS. PRESSURE'
     1       ,/,6X,'K',4X,'PRES',30X,'WAVE TRUNCATION',/,(15X,10I11,/))
      DO 200 KL=1,KLAVG
      WRITE(6,199) KL,ILVAV(KL),(STRWND(MW,KL,2),MW=1,MWV)
  199 FORMAT(/3X,I3,I8,2X,10F11.3)
  200 CONTINUE

      WRITE(6,217) (IWVRQZ(MW),MW=1,MWV)
      WRITE(IUNTBH,217) (IWVRQZ(MW),MW=1,MWV)
  217 FORMAT(/////,20X,'DIRECTION AT TRUNCATED WAVE NUMBER VS. ',
     1       'PRESSURE',/,6X,'K',4X,'PRES',30X,'WAVE TRUNCATION',/,
     2       (15X,10I11,/))
      DO 220 KL=1,KLAVG
      WRITE(6,219)  KL,ILVAV(KL),(STRWND(MW,KL,3),MW=1,MWV)
      WRITE(IUNTBH,219)  KL,ILVAV(KL),(STRWND(MW,KL,3),MW=1,MWV)
  219 FORMAT(/3X,I3,I8,2X,10F11.3)
  220 CONTINUE

      WRITE(6,221) (IWVRQZ(MW),MW=1,MWV)
      WRITE(IUNTBH,221) (IWVRQZ(MW),MW=1,MWV)
  221 FORMAT(///21X,'SPEED AT TRUNCATED WAVE NUMBER VS. PRESSURE'
     1       ,/,6X,'K',4X,'PRES',30X,'WAVE TRUNCATION',/,(15X,10I11,/))
      DO 230 KL=1,KLAVG
      WRITE(6,229) KL,ILVAV(KL),(STRWND(MW,KL,4),MW=1,MWV)
      WRITE(IUNTBH,229) KL,ILVAV(KL),(STRWND(MW,KL,4),MW=1,MWV)
  229 FORMAT(/3X,I3,I8,2X,10F11.3)
  230 CONTINUE
      RETURN

C-----------------------------------------------------------------------

C  ++++++++++++++++++++++++
C  ++++  ENTRY SETFEN  ++++
C  ++++++++++++++++++++++++

      ENTRY SETFEN(IUNTBH,DIRSTM,SPDSTM,UPROP,VPROP,MWENVZ,ITRNCZ,
     1             KLSTMZ,MNIBOG)

C  THIS ENTRY SELECTS THE LEVEL AND WAVE TRUNCATION INDICES THAT
C    CORRESPONDS CLOSEST TO THE ENVIRONMENTAL WIND. CURRENTLY THE
C    ALGORITHM PROCEEDS IN TWO STEPS:
C         1)  MINIMUM DIRECTION DIFFERENCE BETWEEN THE DEEPEST LAYER
C             MEAN WIND AND THE STORM MOTION IS FOUND
C         2)  A NEIGHBORHOOD OF + OR - 1 INDEX IN SPECTRAL TRUNCATION IS
C             SEARCHED FOR THE BEST AGREEMENT (MINIMUM MAGNITUDE OF
C             VECTOR DIFFERENCE) BETWEEN THE ENVIRONMENTAL WIND AND THE
C             STORM MOTION, WITHOUT SIGNIFICANT DEGRADATION IN DIRECTION
C             DIFFERENCE.

      CALL DS2UV(USTMZ,VSTMZ,DIRSTM,SPDSTM)
      USTM=USTMZ
      VSTM=VSTMZ

      IF(KLSTMZ .GT. 0)  KLSTM=KLSTMZ
      IF(ITRNCZ .GE. 0)  ITRNC=ITRNCZ

      WRITE(6,301) DIRSTM,SPDSTM,USTM,VSTM,UPROP,VPROP,KLSTM,MWV,MNIBOG
  301 FORMAT(/'...ENTERING SETFEN WITH DIRSTM,SPDSTM,USTM,VSTM,',
     1       'UPROP,VPROP,KLSTM,MWV,MNIBOG=',/,10X,6F11.4,2I5,L2)

      IF(MWENVZ .GT. 0)  GO TO 380

      USTM=USTM-UPROP
      VSTM=VSTM-VPROP
      CALL UV2DS(USTM,VSTM,DIRSTM,SPDSTM)

      WRITE(6,302) DIRSTM,SPDSTM,USTM,VSTM,UPROP,VPROP
      WRITE(IUNTBH,302) DIRSTM,SPDSTM,USTM,VSTM,UPROP,VPROP
  302 FORMAT(/'...AFTER ADJUSTING FOR PROPAGATION, DIRSTM,SPDSTM,',
     1       'USTM,VSTM,UPROP,VPROP=',/,10X,6F11.4)

C  STEP 1: FIND MINIMUM DIRECTION DIFFERENCE

C  *****  IMPORTANT NOTE: THE MINIMUM DIRECTION DIFFERENCE IS
C                         NOW SET FOR THE DEEPEST LAYER MEAN  ******

      KLADIR=KLAVG

      DIFSPD=1.E10
      DIFDIR=1.E10

      DO 320 KL=1,KLAVG
      DO 310 MW=1,MWV

C  DIFFERENCE IN SPEED BETWEEN ENVWIROMENTAL WIND AND STORM

      DIFSPZ=STRWND(MW,KL,4)-SPDSTM
      STRDIF(MW,KL,1)=DIFSPZ

      IF(ABS(DIFSPZ) .LT. DIFSPD)  THEN
      KLASPD=KL
      MWVSPD=MW
      DIFSPD=ABS(DIFSPZ)
      CALL UV2DS(STRWND(MW,KL,1),STRWND(MW,KL,2),DIRSSV,SPDSSV)
      ENDIF

C  DIFFERENCE IN DIRECTIONS

      CALL UV2DS(STRWND(MW,KL,1),STRWND(MW,KL,2),DIRENV,SPDENV)

      DIFDRZ=DIRENV-DIRSTM
      IF(ABS(DIFDRZ) .GT. 180.)  THEN
c && 5 comments
CC    WRITE(6,307) MW,KL,STRWND(MW,KL,1),STRWND(MW,KL,2),DIRENV,SPDENV,
CC   1             DIRSTM,DIFDRZ
CC307 FORMAT('...CALCULATING DIRECTION DIFFERENCE BETW ENV WIND AND',
CC   1       ' STORM MOTION >180 DEG, MW,KL,UENV,VENV,DIRENV,SPDENV,',
CC   2       'DIRSTM,DIFDRZ=',/,5X,2I5,6F11.4)

      IF(DIFDRZ .GT. 0.0)  THEN
        DIFDRZ=-(360.-DIFDRZ)
        ELSE
        DIFDRZ=  360.+DIFDRZ
      ENDIF

c && 2 comments
CC    WRITE(6,309) DIFDRZ
CC309 FORMAT('     ...RECALCULATING DIFDRZ (GT 180)=',F11.4)
      ENDIF

      STRDIF(MW,KL,2)=DIFDRZ
      IF(KL .EQ. KLAVG .AND. ABS(DIFDRZ) .LT. DIFDIR)  THEN
      MWVDIR=MW
      DIFDIR=ABS(DIFDRZ)
      CALL UV2DS(STRWND(MW,KL,1),STRWND(MW,KL,2),DIRDSV,SPDDSV)
      ENDIF

  310 CONTINUE
  320 CONTINUE

      WRITE(6,331) (IWVRQZ(MW),MW=1,MWV)
      WRITE(IUNTBH,331) (IWVRQZ(MW),MW=1,MWV)
  331 FORMAT(///20X,'SPEED DIFFERENCE (ENV-STM) AT TRUNCATED WAVE ',
     1       'NUMBER VS. PRESSURE'/6X,'K',4X,'PRES',30X,'WAVE ',
     2       'TRUNCATION'/(15X,10I11/))
      DO 335 KL=1,KLAVG
      WRITE(6,333)  KL,ILVAV(KL),(STRDIF(MW,KL,1),MW=1,MWV)
      WRITE(IUNTBH,333)  KL,ILVAV(KL),(STRDIF(MW,KL,1),MW=1,MWV)
  333 FORMAT(/3X,I3,I8,2X,10F11.3)
  335 CONTINUE

      WRITE(6,343) (IWVRQZ(MW),MW=1,MWV)
      WRITE(IUNTBH,343) (IWVRQZ(MW),MW=1,MWV)
  343 FORMAT(//21X,'DIRECTION DIFFERENCE (ENV-STM) AT TRUNCATED ',
     1       'WAVE NUMBER VS. PRESSURE',/,6X,'K',4X,'PRES',30X,
     2       'WAVE TRUNCATION',/,(15X,10I11,/))
      DO 345 KL=1,KLAVG
      WRITE(6,344) KL,ILVAV(KL),(STRDIF(MW,KL,2),MW=1,MWV)
      WRITE(IUNTBH,344) KL,ILVAV(KL),(STRDIF(MW,KL,2),MW=1,MWV)
  344 FORMAT(/3X,I3,I8,2X,10F11.3)
  345 CONTINUE

c && 7 comments
CC    WRITE(6,353) KLASPD,MWVSPD,IWVRQZ(MWVSPD),ILVAV(KLASPD)
CC353 FORMAT(/'...FOUND MINIMUM WIND SPEED DIFFERENCE AT KLASPD,',
CC   1       'MWVSPD=',2I5,',',/,4X,'WHICH CORRESPONDS TO A',/,5X,
CC   2       'WAVENUMBER AND HEIGHT OF',I5,' AND',I8)
CC    WRITE(6,354) SPDSSV,DIRSSV,SPDSTM,DIRSTM
CC354 FORMAT(/'...ENVIRONMENTAL WIND SPEED, DIR, AND STORM SPEED, DIR',
CC   1       ' FOR THIS CHOICE ARE:',/,10X,4F11.3,//)

      WRITE(IWRITE,299)
  299 FORMAT(//)
      WRITE(6,357) KLADIR,MWVDIR,IWVRQZ(MWVDIR),ILVAV(KLADIR)
      WRITE(IUNTBH,357) KLADIR,MWVDIR,IWVRQZ(MWVDIR),ILVAV(KLADIR)
  357 FORMAT(/'...FOUND MINIMUM DIRECTION DIFFERENCE OVER DEEPEST LAYER'
     1      ,' AT KLADIR, MWVDIR=',2I5,',',/,4X,'WHICH CORRESPONDS ',
     2       'TO A WAVENUMBER AND HEIGHT OF',I5,' AND',I8)
      WRITE(6,358) SPDDSV,DIRDSV,SPDSTM,DIRSTM
      WRITE(IUNTBH,358) SPDDSV,DIRDSV,SPDSTM,DIRSTM
  358 FORMAT(/'...ENVIRONMENTAL WIND SPEED, DIR, AND STORM SPEED, DIR',
     1       ' FOR THIS CHOICE ARE:',/,10X,4F11.3)

C  STEP 2: SCAN NEIGHBORHOOD FOR MINIMUM MAGNITUDE OF VECTOR ERROR

      MWV1=MAX(MWVDIR-1,1)
      MWV2=MIN(MWVDIR+1,MWV)
      ANGCRT=5.0
      MWVBST=MWVDIR
      MWVOPT=MWVDIR
      FNLDIR=STRWND(MWVOPT,KLADIR,3)
      FNLSPD=STRWND(MWVOPT,KLADIR,4)
      DFBSTD=SQRT((STRWND(MWVOPT,KLADIR,1)-USTM)**2+
     1            (STRWND(MWVOPT,KLADIR,2)-VSTM)**2)
      DIFOPT=DFBSTD

      DO 370 MW=MWV1,MWV2,2
      VESPD=SQRT((STRWND(MW,KLADIR,1)-USTM)**2+
     1           (STRWND(MW,KLADIR,2)-VSTM)**2)
      IF(VESPD .LT. DIFOPT)  THEN
      IF(ABS(STRDIF(MW,KLADIR,2)-STRDIF(MWVBST,KLADIR,2)) .LT. ANGCRT)
     1  THEN
      WRITE(6,361) IWVRQZ(MW),VESPD,DIFOPT
      WRITE(IUNTBH,361) IWVRQZ(MW),VESPD,DIFOPT
  361 FORMAT(/'...SMALLER VECTOR SPEED ERROR FOR TRUNCATION=',I5,
     1       ' NEW, OLD SPEED ERROR=',2F11.4)
      MWVSAV=MWVOPT
      MWVOPT=MW
      DIFOPT=VESPD
      FNLDIR=STRWND(MWVOPT,KLADIR,3)
      FNLSPD=STRWND(MWVOPT,KLADIR,4)
      WRITE(6,363) ANGCRT,MWVSAV,MWVOPT,STRDIF(MWVSAV,KLADIR,2),
     1             STRDIF(MWVOPT,KLADIR,2),STRDIF(MWVSAV,KLADIR,1),
     2             STRDIF(MWVOPT,KLADIR,1)
      WRITE(IUNTBH,363) ANGCRT,MWVSAV,MWVOPT,STRDIF(MWVSAV,KLADIR,2),
     1                 STRDIF(MWVOPT,KLADIR,2),STRDIF(MWVSAV,KLADIR,1),
     2                 STRDIF(MWVOPT,KLADIR,1)
  363 FORMAT(/'...FOUND BETTER SPEED AGREEMENT IN NEIGHBORING ',
     1       'SPECTRAL TRUNCATION WITHOUT SACRIFICING DIRECTION ',
     2       'AGREEMENT MORE THAN ',F6.1,' DEG.',/,6X,'OLD, ',
     3       'NEW TRUNC, OLD,NEW DIRECTION DIFFERENCE=',2I5,2F11.4,/,
     4        6X,'OLD, NEW SPEED DIFFERENCE=',2F11.4)
      ENDIF
      ENDIF
  370 CONTINUE

  380 IF(MWENVZ .LE. 0)  THEN
      IF(MWENVZ .EQ. 0)  WRITE(6,383)
  383 FORMAT(/'******WRONG OPTION (=0) FOR WAVELENGTH TRUNCATION, ',
     1       'DEFAULT OPTION OF OPTIMAL WAVELENGTH WILL BE USED.')
      WRITE(6,385) FNLSPD,FNLDIR,SPDSTM,DIRSTM,MWVOPT,IWVRQZ(MWVOPT),
     1             ILVAV(KLADIR)
      WRITE(IUNTBH,385) FNLSPD,FNLDIR,SPDSTM,DIRSTM,MWVOPT,
     1                  IWVRQZ(MWVOPT),ILVAV(KLADIR)
  385 FORMAT(/'...FINAL CHOICE OF ENVIRONMENTAL WIND SPEED,  DIR ',
     1       'COMPARED TO STORM SPEED, DIR:'/10X,4F11.3//'...THE FINAL',
     2       ' WAVENUMBER TRUNCATION IS FOR INDEX=',I3,','/4X,'WHICH ',
     3       'CORRESPONDS TO A WAVENUMBER AND HEIGHT OF',I5,' AND',I8)
      MWENV=IWVRQZ(MWVOPT)

      ELSE IF(MWENVZ .GT. 0)  THEN
      MWENV=MWENVZ
      WRITE(6,387) MWENV
CCCC  WRITE(IUNTBH,387) MWENV
  387 FORMAT(/'...SPECIFIED WAVENUMBER TRUNCATION IS:',I5//)
      RETURN
      ENDIF

      WRITE(IWRITE,1999)
 1999 FORMAT(//)
      RETURN

C-----------------------------------------------------------------------


C  ++++++++++++++++++++++++
C  ++++  ENTRY FENBOG  ++++
C  ++++++++++++++++++++++++

      ENTRY FENBOG(IUNTFE,MMX,NNY,IMETHZ,RLATMN,RLATMX,RLONMN,RLONMX,
     1             FRACST,ENVBOG,RLATP,RLONP,NPTS,MNIBOG,modtyp)

      WRITE(6,401)  MWENV,IMFLTP,IMETHZ,FRACST,KLSTM,JVBOGz,MNIBOG
  401 FORMAT(/'...ENTERING FENBOG TO CALCULATE ENVIRONMENTAL BOGUS',
     1       ' WITH WAVE TRUNCATION=',I4,'. IMFLTP=',I2/4X,'IMETHZ=',I2,
     2       ', FRACST=',F6.2,'KLSTM=',I3,' JVBOGz=',I3,' MNIBOG=',L2)

      ICALL=-1

C  SKIP SETUP CALCULATIONS FOR MINI BOGUSING

      IF(.NOT. MNIBOG)  THEN

C  SET UP CORNER POINTS FOR CALCULATING HEIGHT OFFSET

         DO 405 KK=1,2
            CORNR(2*KK-1,1)=RLATMX
            CORNR(2*KK  ,1)=RLATMN
  405    CONTINUE
         DO 410 KK=1,2
            CORNR(KK  ,2)=RLONMN
            CORNR(KK+2,2)=RLONMX
  410    CONTINUE
         IWVCRN(1)=I40WV
         IWVCRN(2)=MWENV
         ITCRN(1) =IROMB
         ITCRN(2) =ITRIA
      ENDIF

      DO 450 KL=1,KLSTM
      DO 440 JV=1,JVBOGz
         OFF1=0.0
         OFF2=0.0

C  SKIP SETUP CALCULATIONS FOR MINI BOGUSING

         IF(.NOT. MNIBOG)  THEN

C  WAVES FOR U, V WIND ARE 1 MORE THAN FOR SCALARS (VORT, DIV, Z, T, RH)

            IF((IVAR(JV).EQ.4 .OR. IVAR(JV).EQ.5).AND.IMFLTP.EQ.1) THEN
               IPLUS=1
            ELSE
               IPLUS=0
            ENDIF

C  CALCULATE HEIGHTS ON THE FOUR CORNERS OF THE DOMAIN FOR BOTH R40 AND
C    THE CHOSEN WAVENUMBER TRUNCATION, AVERAGE THEM AND CALCULATE AN
C    OFFSET TO BE APPLIED TO THE ENTIRE HEIGHT FIELD

            IF(IVAR(JV) .EQ. 3 .AND. IMFLTP .EQ. 1)  THEN
               DO 420 MWCORN=1,2
                  CALL SETTRN(KL,JV,IWVCRN(MWCORN),IPLUS,ITCRN(MWCORN))
                  CALL SETRES(KL,JV,IWVCRN(MWCORN),IPLUS,ITCRN(MWCORN))
                  DO 415 ICORN=1,4
                     CALL SCASP1(CORNR(ICORN,2),CORNR(ICORN,1),JV,KL,
     1                 IWVCRN(MWCORN),ITCRN(MWCORN),ZCORN(ICORN,MWCORN))
  415             CONTINUE
  420          CONTINUE

               AVGR40=0.0
               AVGMWV=0.0
               DO 425 KK=1,4
                  AVGR40=AVGR40+ZCORN(KK,1)
                  AVGMWV=AVGMWV+ZCORN(KK,2)
  425          CONTINUE
               AVGR40=0.25*AVGR40
               AVGMWV=0.25*AVGMWV
               OFFSET=AVGR40-AVGMWV
               OFF1=OFFSET
            ENDIF

            IF(KL .EQ. 1 .AND. JV .EQ. 1)  THEN
               WRITE(6,1403) KL,JV,ILVL(KL),IVAR(JV),MWENV,IPLUS,ITRNC,
     1                       NPTS
 1403 FORMAT(/'...CALLING SETTRN FOR ENVIRONMENTAL BOGUS: KL,JV,LEVEL,',
     1       'IVAR,MWENV,IPLUS,ITRNC,NPTS=',8I5)
               CALL SETTRN(KL,JV,MWENV,IPLUS,ITRNC)
            ELSE
               WRITE(6,1404) KL,JV,ILVL(KL),IVAR(JV),MWENV,IPLUS,ITRNC,
     1                       NPTS
 1404 FORMAT(/'...CALLING SETRES FOR ENVIRONMENTAL BOGUS: KL,JV,LEVEL,',
     1       'IVAR,MWENV,IPLUS,ITRNC,NPTS=',8I5)
               CALL SETRES(KL,JV,MWENV,IPLUS,ITRNC)
            ENDIF

         ENDIF

C  LOOP FOR ALL POINTS

         DO 430 NP=1,NPTS

            XX=RLONP(NP)
            YY=RLATP(NP)

C  SCALARS: Z, RH, T

            IF(IVAR(JV) .LE. 3)  THEN
               KVMX=1
               IF(IMFLTP .EQ. 1)  THEN
                  CALL SCASP1(XX,YY,JV,KL,MWENV,ITRNC,ENVBOG(NP,KVMX))
               ELSE IF(IMFLTP .EQ. 2)  THEN
                  CALL SCASP1(XX,YY,JV,KL,MWENV,ITRNC,ENVBOG(NP,KVMX))
               ENDIF
               IF(IVAR(JV) .EQ. 3)  ENVBOG(NP,KVMX)=ENVBOG(NP,KVMX)+OFF1
               WRITE(6,409) NP,JV,ILVL(KL),XX,YY,ENVBOG(NP,KVMX)
  409 FORMAT('...ENVIRONMENTAL BOGUS, NP,JV,LEVEL,XX,YY,ENVBOG=',3I5,
     1       3F11.4)

C  U WIND:  IMFLTP=1 (U,V COEFFS)
C           IMFLTP=2 (VORT, DIV. COEFFS) - THE TOTAL (U,V) WIND IS
C                    CONSTRUCTED IN TWO PIECES.  THE FIRST PIECE IS THE
C                    ROTATIONAL PART, THE SECOND PART IS THE DIVERGENT
C                    PART.

C  SET ENVIRONMENTAL WIND EQUAL TO SOME FACTOR OF THE STORM SPEED

            ELSE IF(IMETHZ .EQ. 2) THEN
               KVMX=2
               ENVBOG(NP,1)=USTM*FRACST
               ENVBOG(NP,2)=VSTM*FRACST
               OFF1=0.0
               OFF2=0.0

            ELSE IF(IMETHZ .GT. 2) THEN
               KVMX=2
               ENVBOG(NP,1)=USTM*FRACST
               ENVBOG(NP,2)=VSTM*FRACST
               OFF1=0.0
               OFF2=0.0

            ELSE
               IF(IVAR(JV) .EQ. 4)  THEN
                  KVMX =2
                  IF(IMFLTP .EQ. 1)  THEN
                     CALL UVWSP1(XX,YY,JV,KL,MWENV,IPLUS,ITRNC,
     1                           ENVBOG(NP,KVMX-1))
                  ELSE IF(IMFLTP .EQ. 2)  THEN
                     CALL UVRSP2(XX,YY,JV,KL,MWENV,ITRNC,
     1                           ENVBOG(NP,KVMX-1),ENVBOG(NP,KVMX))
                  ENDIF
c && 2 comments
ccc               WRITE(6,409) NP,JV,ILVL(KL),XX,YY,ENVBOG(NP,KVMX-1)
ccc               WRITE(6,409) NP,JV,ILVL(KL),XX,YY,ENVBOG(NP,KVMX  )

C  V WIND: SEE COMMENTS PERTAINING TO U WIND ABOVE

               ELSE IF(IVAR(JV) .EQ. 5)  THEN

                  IF(IMFLTP .EQ. 1)  THEN
                     CALL UVWSP1(XX,YY,JV,KL,MWENV,IPLUS,ITRNC,
     1                           ENVBOG(NP,KVMX))
                  ELSE IF(IMFLTP .EQ. 2)  THEN
                     CALL UVDSP2(XX,YY,JV,KL,MWENV,ITRNC,
     1                           ENVBOG(NP,KVMX-1),ENVBOG(NP,KVMX))
                  ENDIF
c && 2 comments
ccc               WRITE(6,409) NP,JV,ILVL(KL),XX,YY,ENVBOG(NP,KVMX-1)
ccc               WRITE(6,409) NP,JV,ILVL(KL),XX,YY,ENVBOG(NP,KVMX  )

C  ROTATIONAL WIND

               ELSE IF(IVAR(JV) .EQ. 6)  THEN
                  KVMX=2
                  IF(IMFLTP .EQ. 1)  THEN
                     CALL UROSP1(XX,YY,JV,KL,MWENV,ITRNC,
     1                           ENVBOG(NP,KVMX-1))
                     CALL VROSP1(XX,YY,JV,KL,MWENV,ITRNC,
     1                           ENVBOG(NP,KVMX))
                  ELSE IF(IMFLTP .EQ. 2)  THEN
                     ENVBOG(NP,KVMX-1)=0.0
                     ENVBOG(NP,KVMX  )=0.0
                     CALL UVRSP2(XX,YY,JV,KL,MWENV,ITRNC,
     1                           ENVBOG(NP,KVMX-1),ENVBOG(NP,KVMX))
                  ENDIF
c && 2 comments
ccc               WRITE(6,409) NP,JV,ILVL(KL),XX,YY,ENVBOG(NP,KVMX-1)
ccc               WRITE(6,409) NP,JV,ILVL(KL),XX,YY,ENVBOG(NP,KVMX)

C  DIVERGENT WIND

               ELSE IF(IVAR(JV) .EQ. 7)  THEN
                  KVMX=2
                  IF(IMFLTP .EQ. 1)  THEN
                     CALL UDVSP1(XX,YY,JV,KL,MWENV,ITRNC,
     1                           ENVBOG(NP,KVMX-1))
                     CALL VDVSP1(XX,YY,JV,KL,MWENV,ITRNC,
     1                           ENVBOG(NP,KVMX))
                  ELSE IF(IMFLTP .EQ. 2)  THEN
                     ENVBOG(NP,KVMX-1)=0.0
                     ENVBOG(NP,KVMX  )=0.0
                     CALL UVDSP2(XX,YY,JV,KL,MWENV,ITRNC,
     1                           ENVBOG(NP,KVMX-1),ENVBOG(NP,KVMX))
                  ENDIF
c && 2 comments
ccc               WRITE(6,409) NP,JV,ILVL(KL),XX,YY,ENVBOG(NP,KVMX-1)
ccc               WRITE(6,409) NP,JV,ILVL(KL),XX,YY,ENVBOG(NP,KVMX)
               ELSE
                  WRITE(6,429) JV,IVAR(JV)
  429 FORMAT(/'******VARIABLE CANNOT BE DERIVED FROM ENVIRONMENTAL',
     1       ' FIELDS, JV, IVAR(JV)=',2I5)
               ENDIF
            ENDIF

  430    CONTINUE

c && 5 comments
cc       DO KV=1,KVMX
cc          WRITE(6,431) KV,(ENVBOG(NP,KV),NP=1,NPTS)
cc431 FORMAT(/'...ENVBOG HAS BEEN STORED IN FENBOG, KV,ENVBOG=',I5,/,
cc   1       (10F12.5))
cc       ENDDO

C  CONSTRUCT FILE HEADER AND WRITE TO DISK FOR ALL VARIABLES.
C    NOTE: U,V WIND DONE TOGETHER

         IF(IVAR(JV) .NE. 4)  THEN

c && 3 comments
cc          WRITE(6,437) MMX,NNY,RLONMN,RLONMX,RLATMN,RLATMX
cc437 FORMAT(/'...READY TO WRITE ENVBOG ARRAY, MMX,NNY,RLONMN,RLONMX,',
cc   1       'RLATMN,RLATMX=',/,5X,2I6,4F11.4)
            IF(MODTYP .EQ. 0 .OR. MODTYP .EQ. 1)  THEN

               CALL HDRSPP(KL,JV,MWENV,RLATMN,RLATMX,RLONMN,
     1               RLONMX,OFF1,OFF2,MTITLE,NCHAR)
               IF(IMFLTP .EQ. 1)  THEN

                  ICALL=ICALL+1
                  CALL OUTENV(IUNTFE,ICALL,ENVBOG,MMX,NNY,KVMX,MTITLE,
     1                        NCHAR)

               ELSE IF(IMFLTP .EQ. 2)  THEN
                  WRITE(6,439)  IUNTFE
  439 FORMAT(/'...ENVIRONMENTAL FIELDS WRITTEN TO UNIT=',I3,' IN ',
     1       'CHARACTER FORMAT USING OUTGES.')

C  TEMPORARY OUTPUT FORMAT

                  CALL OUTGES(IUNTFE,NPTS,ENVBOG,MTITLE)
               ENDIF

C  RESERVED FOR OTHER MODEL TYPES

            ELSE
            ENDIF

         ENDIF

  440 CONTINUE
  450 CONTINUE

      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$

C  *****************************
C  ****  SUBROUTINE SETMOD  ****
C  ****     ENTRY SETDTS    ****
C  ****     ENTRY SVRSP1    ****
C  ****     ENTRY SLVSP1    ****
C  ****     ENTRY SVRSP2    ****
C  ****     ENTRY SLVSP2    ****
C  ****     ENTRY HDRSPP    ****
C  *****************************

      SUBROUTINE SETMOD(KLMAX,IPREQ,ILVL,INDXP,KLBOG,JVMAX,IVREQ,IVAR,
     1                  INDXV,JVBOG,idatez,iutcz,stmnmz,klz,jvz,mwenv,
     2                  rlatmn,rlatmx,rlonmn,rlonmx,off1,off2,mtitle,
     3                  nchar)

C**DEB  PARAMETER(KDIM=#PLEVS)  PL1 PARAMETERS ARE A POSSIBILITY HERE
      PARAMETER(KDIMS1=12)
      PARAMETER(JDIMS1= 7)
      PARAMETER(KDIMS2=12)
      PARAMETER(JDIMS2= 7)

      CHARACTER STMNAM*(12),STMNMZ*(*),INFL1*2,INFL2*2,MTITLE*102,ANAL*6

      SAVE

      DIMENSION IPREQ(KLMAX),ILVL(KLMAX),INDXP(KLMAX),IVREQ(JVMAX),
     1          IVAR(JVMAX),INDXV(JVMAX)

      DIMENSION IPFL1(KDIMS1),IVFL1(JDIMS1),INFL1(JDIMS1),IPFL2(KDIMS2),
     1          IVFL2(JDIMS2),INFL2(JDIMS2)

      DIMENSION INDXVS(JDIMS1),INDXPS(KDIMS1)

      LOGICAL FOUND

      DATA IPFL1/1000,850,700,500,400,300,250,200,150,100,70,50/,
     1     IVFL1/3,4,5,6,7,2,1/,
     2     INFL1/'Z ','$ ','$ ','$R','$D','RH','T '/

      DATA IPFL2/1000,850,700,500,400,300,250,200,150,100,70,50/,
     1     IVFL2/3,6,7,4,5,2,1/,
     2     INFL2/'Z ','$R','$D','$ ','$ ','RH','T '/
      DATA ANAL/' FANAL'/,NCHARZ/102/

C  THIS SET OF ENTRIES IN SUBROUTINE SETMOD CONTAINS MODEL SPECIFIC
C    INFORMATION ABOUT THE FILE STRUCTURES.  CURRENT MODEL AND FILE
C    TYPES ARE:
C      MODTYP= 0: MODEL INDEPENDENT METHOD DEFAULTS TO SPECTRAL MODEL
C                 STRUCTURE FOR CONVENIENCE
C      MODTYP= 1: SPECTRAL MODEL
C      MODTYP=-1: GRID POINT MODEL

C    FILE TYPES:
C      IMFLTP=1: NCEP GLOBAL SPECTRAL MODEL, OPERATIONAL R40 PRESSURE
C                COEFFICIENT FILE == CALL SLVSP1 FOR VERTICAL LEVELS
C                                  == CALL SVRSP1 FOR VARIABLES
C      IMFLTP=2: NCEP GLOBAL SPECTRAL MODEL, OPERATIONAL PRESSURE
C                COEFFICIENTS OF VORTICITY, DIVERGENCE
C                                 == CALL SLVSP2 FOR VERTICAL LEVELS
C                                 == CALL SVRSP2 FOR VARIABLES
C      IMFLTP>2: NOT IMPLEMENTED

C-----------------------------------------------------------------------

C  ++++++++++++++++++++++++
C  ++++  ENTRY SETDTS  ++++
C  ++++++++++++++++++++++++

      ENTRY SETDTS(IDATEZ,IUTCZ,STMNMZ)

      IDATE =IDATEZ
      IUTC  =IUTCZ
      STMNAM=STMNMZ
      RETURN

C-----------------------------------------------------------------------

C  ++++++++++++++++++++++++
C  ++++  ENTRY SLVSP1  ++++
C  ++++++++++++++++++++++++

      ENTRY SLVSP1(KLMAX,IPREQ,ILVL,INDXP,KLBOG)

      IMFLTP=1
      KL=0
      DO 40 KP=1,KLMAX
      FOUND=.FALSE.
      DO 20 KLF=1,KDIMS1
      IF(IPREQ(KP) .EQ. IPFL1(KLF))   THEN
      FOUND=.TRUE.
      KL=KL+1
      ILVL(KL)=IPFL1(KLF)
      INDXP (KL)=KLF
      INDXPS(KL)=KLF
      ENDIF
   20 CONTINUE

      IF(.NOT. FOUND)  THEN
      WRITE(6,21) IPREQ(KP)
   21 FORMAT('###### PRESSSURE LEVEL',I3,' NOT AVAILABLE IN FILE.')
      IPREQ(KP)=-IPREQ(KP)
      ENDIF

   40 CONTINUE
      KLBOG=KL
      RETURN

C-----------------------------------------------------------------------

C  ++++++++++++++++++++++++
C  ++++  ENTRY SLVSP2  ++++
C  ++++++++++++++++++++++++

      ENTRY SLVSP2(KLMAX,IPREQ,ILVL,INDXP,KLBOG)

      IMFLTP=2
      KL=0
      DO 140 KP=1,KLMAX
      FOUND=.FALSE.
      DO 120 KLF=1,KDIMS2
      IF(IPREQ(KP) .EQ. IPFL2(KLF))   THEN
      FOUND=.TRUE.
      KL=KL+1
      ILVL(KL)=IPFL2(KLF)
      INDXP (KL)=KLF
      INDXPS(KL)=KLF
      ENDIF
  120 CONTINUE

      IF(.NOT. FOUND)  THEN
      WRITE(6,121) IPREQ(KP)
  121 FORMAT('###### PRESSSURE LEVEL',I3,' NOT AVAILABLE IN FILE.')
      IPREQ(KP)=-IPREQ(KP)
      ENDIF

  140 CONTINUE
      KLBOG=KL
      RETURN

C-----------------------------------------------------------------------

C  ++++++++++++++++++++++++
C  ++++  ENTRY SVRSP1  ++++
C  ++++++++++++++++++++++++

      ENTRY SVRSP1(JVMAX,IVREQ,IVAR,INDXV,JVBOG)

      IMFLTP=1
      JV=0
      DO 240 JJ=1,JVMAX
      FOUND=.FALSE.
      DO 220 JLF=1,JDIMS1
      IF(IVREQ(JJ) .EQ. IVFL1(JLF))   THEN
      FOUND=.TRUE.
      JV=JV+1
      IVAR(JV)=IVFL1(JLF)
      INDXV (JV)=JLF
      INDXVS(JV)=JLF
      ENDIF
  220 CONTINUE

      IF(.NOT. FOUND)  THEN
      WRITE(6,221) IVREQ(JJ)
  221 FORMAT('###### VARIABLE',I3,' NOT AVAILABLE IN FILE.')
      IVREQ(JJ)=-IVREQ(JJ)
      ENDIF

  240 CONTINUE
      JVBOG=JV
      RETURN

C-----------------------------------------------------------------------

C  ++++++++++++++++++++++++
C  ++++  ENTRY SVRSP2  ++++
C  ++++++++++++++++++++++++

      ENTRY SVRSP2(JVMAX,IVREQ,IVAR,INDXV,JVBOG)

      IMFLTP=2
      JV=0
      DO 340 JJ=1,JVMAX
      FOUND=.FALSE.
      DO 320 JLF=1,JDIMS2
      IF(IVREQ(JJ) .EQ. IVFL2(JLF))   THEN
      FOUND=.TRUE.
      JV=JV+1
      IVAR(JV)=IVFL2(JLF)
      INDXV (JV)=JLF
      INDXVS(JV)=JLF
      ENDIF
  320 CONTINUE

      IF(.NOT. FOUND)  THEN
      WRITE(6,321) IVREQ(JJ)
  321 FORMAT('###### VARIABLE',I3,' NOT AVAILABLE IN FILE.')
      IVREQ(JJ)=-IVREQ(JJ)
      ENDIF

  340 CONTINUE
      JVBOG=JV
      RETURN

C-----------------------------------------------------------------------

C  ++++++++++++++++++++++++
C  ++++  ENTRY HDRSPP  ++++
C  ++++++++++++++++++++++++

      ENTRY HDRSPP(KLZ,JVZ,MWENV,RLATMN,RLATMX,RLONMN,RLONMX,OFF1,OFF2,
     1             MTITLE,NCHAR)

      NCHAR=NCHARZ
      MTITLE=' '

      IF(IMFLTP .EQ. 1)  THEN
      MTITLE(1:2)=INFL1(INDXVS(JVZ))
      WRITE(MTITLE(9:12),201) IPFL1(INDXPS(KLZ))
  201 FORMAT(I4)
      ELSE IF(IMFLTP .EQ. 2)  THEN
      MTITLE(1:2)=INFL2(INDXVS(JVZ))
      WRITE(MTITLE(9:12),201) IPFL2(INDXPS(KLZ))
      ENDIF

      MTITLE(13:14)='MB'
      WRITE(MTITLE(16:24),202) IDATE
  202 FORMAT(I9)
      WRITE(MTITLE(26:29),203) IUTC
  203 FORMAT(I4)
      WRITE(MTITLE(31:42),204) STMNAM
  204 FORMAT(A)
      WRITE(MTITLE(47:52),205) ANAL
  205 FORMAT(A6)
      MTITLE(54:56)='MW='
      WRITE(MTITLE(57:59),206) MWENV
  206 FORMAT(I3)
      IRLTMN = NINT(RLATMN*10.)
      RLTMN = IRLTMN*0.1
      IRLTMX = NINT(RLATMX*10.)
      RLTMX = IRLTMX*0.1
      IRLNMN = NINT(RLONMN*10.)
      RLNMN = IRLNMN*0.1
      IRLNMX = NINT(RLONMX*10.)
      RLNMX = IRLNMX*0.1
      WRITE(MTITLE(61:84),207) RLTMN,RLTMX,RLNMN,RLNMX
  207 FORMAT(4F6.1)
      MTITLE(86:92)='OFF1/2='
      IOFF1 = NINT(OFF1*10.)
      ROFF1 = IOFF1*0.1
      IOFF2 = NINT(OFF2*10.)
      ROFF2 = IOFF2*0.1
      WRITE(MTITLE(93:102),208) ROFF1,ROFF2
  208 FORMAT(2F5.1)
c && 5 comments
CC    WRITE(6,211)  KLZ,JVZ,IDATE,IUTC,STMNAM,ANAL,MWENV,RLATMN,RLATMX,
CC   1              RLONMN,RLONMX,MTITLE
CC211 FORMAT(/'...WRITING FILE HEADER, KLZ,JVZ,IDATE,IUTC,STMNAM,',
CC   1       'ANAL,MWENV,RLATMN,RLATMX,RLONMN,RLONMX,MTITLE=',/,5X,
CC   2       2I5,I9,I6,2X,A12,2X,A6,I5,4F11.4,/,5X,A)
      RETURN

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$

C  *****************************
C  ****  SUBROUTINE SPMODL  ****
C  ****     ENTRY MODL1     ****
C  ****     ENTRY RDSPP1    ****
C  ****     ENTRY RDSPP2    ****
C  ****     ENTRY SETTRN    ****
C  ****     ENTRY SETRES    ****
C  ****     ENTRY SCASP1    ****
C  ****     ENTRY UVWSP1    ****
C  ****     ENTRY UROSP1    ****
C  ****     ENTRY VROSP1    ****
C  ****     ENTRY UDVSP1    ****
C  ****     ENTRY VDVSP1    ****
C  ****     ENTRY UVWSP2    ****
C  ****     ENTRY UROSP2    ****
C  ****     ENTRY VROSP2    ****
C  ****     ENTRY UDVSP2    ****
C  ****     ENTRY VDVSP2    ****
C  *****************************

      SUBROUTINE SPMODL(IUNIT,KLBOG,JVBOG,MWAVE,INDXP,INDXV,KLZ,JVZ,MWV,
     1                  IPLUS,IRO,XX,YY,SCOUT,UVOUT,UOUT,VOUT)

C  PARAMETERS FROM H. L. PAN (L3V1.MAP.MAPSORC(PRS)): OPERATIONAL
C    PRESSURE COEFFICIENT FILE FROM GLOBAL SPECTRAL MODEL

CCCC  PARAMETER(NSPACE=3600)
      PARAMETER(MAXBGK=10)
      PARAMETER(MAXBGV= 7)

      PARAMETER (NSPACE=3600)

      PARAMETER (MAXZWV=40,IROMB=1,MAXUWV=MAXZWV+1,
     2           MZWVD=(MAXZWV+1)*(MAXZWV+2)/2*(1-IROMB)+
     3                (MAXZWV+1)*(MAXZWV+1)*IROMB, MZWVD2=MZWVD*2,
     4           MUWVD=(MAXUWV+1)*(MAXUWV+2)/2*(1-IROMB)+
     5                (MAXUWV+1)*(MAXUWV+1)*IROMB, MUWVD2=MUWVD*2)
      PARAMETER(KDIM=12,KDIMQ=6)

      SAVE

      REAL(8)  COSDEG_8

      DIMENSION WAVE1(MUWVD2),WAVE2(MUWVD2),WAVE3(MUWVD2),WAVEX(MUWVD2),
     1          WAVEZ(MUWVD2),QIMER(MUWVD),FER(MUWVD),IDTSP(4),
     2          fac(MUWVD)  ! dak 7/3/05: fix bounds-check error
      DIMENSION INDXP(KLBOG),INDXV(JVBOG),ARRAY(NSPACE,MAXBGV,MAXBGK)

      LOGICAL UVSAVE,VDSAVE
      CHARACTER LAB(4)*8

      DATA ER/6371.0E3/
cc dak 7/3/05      DATA FAC/0.0/
      DATA fac/muwvd*0.0/ !dak 7/3/05: fix bounds-check error

C-----------------------------------------------------------------------

      ENTRY MODL1(IUNIT,KLBOG,JVBOG,MWAVE,INDXP,INDXV)

C  FILE READER AND SELECTOR FOR OPERATIONAL PRESSURE COEFFICIENT FILE
C    FROM NCEP GLOBAL SPECTRAL MODEL

      MWAVE=MAXZWV
      MENDZ1=MAXZWV+1

C  OVERHEAD CHORES

      ERIV=1.0/ER
      ERSQ=ER*ER
      IF(MAXUWV.NE.MAXZWV) THEN
      MUMAX=(MAXUWV+1)*MAXUWV*2
      ELSE
      MUMAX=MUWVD2
      ENDIF

      WRITE(6,11) IUNIT,MZWVD2,MAXZWV,MUWVD2,MUMAX
   11 FORMAT(////,25X,'*** EXTRACTING SPECTRAL COEFFICIENTS FROM',
     1       ' NCEP GLOBAL SPECTRAL MODEL, PRESSURE COEFFICIENT ',
     2       ' FILE ***',/,30X,'IUNIT,MZWVD2,MAXZWV,',
     3       'MUWVD2,MUMAX=',5I7,//)

      MSPACE=MAX(MZWVD2,MUMAX)
      IF(MSPACE .GT. NSPACE)  THEN
      WRITE(6,21) NSPACE,MSPACE
   21 FORMAT(/'******INSUFFICIENT STORAGE ALLOCATED FOR STORING ',
     1       'VARIABLES IN RDSPP1.',/,10X,'NSPACE=',I5,' WHILE ',
     2       'AVAILABLE SPACE=MSPACE=',I5,/,10X,' THEREFORE, ',
     3       'WE MUST TERMINATE THE PROGRAM.')
      CALL ABRT1(' MODL1 ',21)
      ENDIF

C  SKIP HEADER RECORDS

      READ(IUNIT)  LAB
c && 2 comments
CC    WRITE(6,23) LAB
CC 23 FORMAT(/'...INPUT LABEL=',A8,2X,2Z16,2X,A8)
      READ(IUNIT)  FHOUR,IDTSP
      WRITE(6,25) IDTSP,FHOUR
   25 FORMAT('...INPUT DATA DATE, TIME AND FORECAST HOUR:',/,4X,4I5,
     1       F7.1)

      RETURN

C-----------------------------------------------------------------------

C  ++++++++++++++++++++++++
C  ++++  ENTRY RDSPP1  ++++
C  ++++++++++++++++++++++++

      ENTRY RDSPP1(IUNIT,KLBOG,JVBOG,MWAVE,INDXP,INDXV)

C  READ TRIPLET COEFFICIENTS OF Z,U,V
C    PICK UP WHAT'S NEEDED BY LEVEL AND VARIABLE

      KK=1
      DO 100 K=1,KDIM

      READ(IUNIT) (WAVE1(NM),NM=1,MZWVD2)
      READ(IUNIT) (WAVE2(NM),NM=1,MUMAX)
      READ(IUNIT) (WAVE3(NM),NM=1,MUMAX)

      IF(K .EQ. INDXP(KK))  THEN

      UVSAVE=.FALSE.
      VDSAVE=.FALSE.
      DO 80 JV=1,JVBOG

C  HEIGHT

      IF(INDXV(JV) .EQ. 1)  THEN

      ARRAY(1:MZWVD2,JV,KK)=WAVE1(1:MZWVD2)

      WRITE(6,31) JV,KK,K,(WAVE1(NM),NM=1,10)
   31 FORMAT(/'...PICKING UP HEIGHT COEF, STORAGE INDICES JV, KK=',2I5,
     1       ' LEVEL INDEX=',I5,' WAVES(1-10)=',/,5X,10E12.4)

C  U WIND

      ELSE IF(INDXV(JV) .EQ. 2)  THEN

      ARRAY(1:MUMAX,JV,KK)=WAVE2(1:MUMAX)

      UVSAVE=.TRUE.
      WRITE(6,41) JV,KK,K,(WAVE2(NM),NM=1,10)
   41 FORMAT(/'...PICKING UP U WIND COEF, STORAGE INDICES JV, KK=',2I5,
     1       ' LEVEL INDEX=',I5,' WAVES(1-10)=',/,5X,10E12.4)

C  V WIND

      ELSE IF(INDXV(JV) .EQ. 3)  THEN

      IF(.NOT. UVSAVE)  THEN
      WRITE(6,47) JV,KK,K
   47 FORMAT(/'******TRYING TO SAVE V WHEN U NOT SAVED, JV,KK,K=',3I5,/,
     1       15X,'WE IGNORE THIS INPUT')
      GO TO 80
      ENDIF

      ARRAY(1:MUMAX,JV,KK)=WAVE3(1:MUMAX)

      UVSAVE=.FALSE.
      WRITE(6,51) JV,KK,K,(WAVE3(NM),NM=1,10)
   51 FORMAT(/'...PICKING UP V WIND COEF, STORAGE INDICES JV, KK=',2I5,
     1       ' LEVEL INDEX=',I5,' WAVES(1-10)=',/,5X,10E12.4)

C  ROTATIONAL WIND (VORTICITY COEFFS)

      ELSE IF(INDXV(JV) .EQ. 4)  THEN

      VDSAVE=.TRUE.
      CALL UVTOZD(WAVE2,WAVE3,WAVE1,WAVEX,MENDZ1,IROMB,ER,MZWVD2,MUMAX)

      ARRAY(1:MUMAX,JV,KK)=WAVE1(1:MUMAX)

      WRITE(6,61) JV,KK,K,(WAVE1(NM),NM=1,10)
   61 FORMAT(/'...PICKING UP VORT COEFF, STORAGE INDICES JV, KK=',2I5,
     1       ' LEVEL INDEX=',I5,' WAVES(1-10)=',/,5X,10E12.4)

C  DIVERGENT WIND (DIVERGENCE COEFFS)

      ELSE IF(INDXV(JV) .EQ. 5)  THEN

      IF(.NOT. VDSAVE)
     1 CALL UVTOZD(WAVE2,WAVE3,WAVE1,WAVEX,MENDZ1,IROMB,ER,MZWVD2,MUMAX)
      VDSAVE=.TRUE.

      ARRAY(1:MUMAX,JV,KK)=WAVEX(1:MUMAX)

      WRITE(6,71) JV,KK,K,(WAVEX(NM),NM=1,10)
   71 FORMAT(/'...PICKING UP DIVG COEFF, STORAGE INDICES JV, KK=',2I5,
     1       ' LEVEL INDEX=',I5,' WAVES(1-10)=',/,5X,10E12.4)
      ENDIF

   80 CONTINUE

C  TERMINATE STORING LEVELS SINCE ARRAY IS FULL FOR LEVELS

        IF(KK .EQ. KLBOG)  THEN
        KZZ=K+1
        WRITE(6,87) KZZ,KDIM
   87   FORMAT(/'...STORING IS NOW TERMINATED FOR HEIGHT AND WINDS. ',
     1         'INDICES',I3,' TO',I3,' WILL BE SKIPPED.')
        DO 90 KS=KZZ,KDIM
        READ(IUNIT)
        READ(IUNIT)
        READ(IUNIT)
   90   CONTINUE
        GO TO 200

        ELSE
        KK=KK+1
        ENDIF
      ENDIF
  100 CONTINUE

C  RELATIVE HUMIDITY

  200 KK=1
      DO 250 JV=1,JVBOG

      IF(INDXV(JV) .EQ. 6)  THEN
      DO 230 K=1,KDIMQ
      READ(IUNIT) (WAVE1(NM),NM=1,MZWVD2)

      IF(K .EQ. INDXP(KK))  THEN

      ARRAY(1:MZWVD2,JV,KK)=WAVE1(1:MZWVD2)

      WRITE(6,211) JV,KK,K,(WAVE1(NM),NM=1,10)
  211 FORMAT(/'...PICKING UP RELH COEFF, STORAGE INDICES JV, KK=',2I5,
     1       ' LEVEL INDEX=',I5,' WAVES(1-10)=',/,5X,10E12.4)

C  TERMINATE STORING LEVELS SINCE ARRAY IS FULL FOR LEVELS

        IF(KK .EQ. KLBOG)  THEN
        KZZ=K+1
        WRITE(6,217) KZZ,KDIMQ
  217   FORMAT(/'...STORING IS NOW TERMINATED FOR RELATIVE HUMIDITY. ',
     1         'K INDICES',I3,' TO',I3,' WILL BE SKIPPED.')
        DO 220 KS=KZZ,KDIMQ
        READ(IUNIT)
  220   CONTINUE
        GO TO 300

        ELSE
        KK=KK+1
        ENDIF

      ENDIF
  230 CONTINUE

      ELSE
        IF(JV .EQ. JVBOG .AND. KK .EQ. 1)  THEN
        DO 240 KSK=1,KDIMQ
        READ(IUNIT)
  240   CONTINUE
        ENDIF
      ENDIF
  250 CONTINUE

C  TEMPERATURE ***NOTE: HISTORICAL CASES PRIOR TO JAN. 1990 HAVE
C                       STORED VIRTUAL TEMPERATURE ***

  300 KK=1
      DO 350 JV=1,JVBOG

      IF(INDXV(JV) .EQ. 7)  THEN
      DO 330 K=1,KDIM
      READ(IUNIT) (WAVE1(NM),NM=1,MZWVD2)

      IF(K .EQ. INDXP(KK))  THEN

      ARRAY(1:MZWVD2,JV,KK)=WAVE1(1:MZWVD2)

      WRITE(6,311) JV,KK,K,(WAVE1(NM),NM=1,10)
  311 FORMAT(/'...PICKING UP TEMP COEFF, STORAGE INDICES JV, KK=',2I5,
     1       ' LEVEL INDEX=',I5,' WAVES(1-10)=',/,5X,10E12.4)

C  TERMINATE STORING LEVELS SINCE ARRAY IS FULL FOR LEVELS

        IF(KK .EQ. KLBOG)  THEN
        KZZ=K+1
        WRITE(6,317) KZZ,KDIM
  317   FORMAT(/'...STORING IS NOW TERMINATED FOR TEMPERATURE. ',
     1         ' K INDICES',I3,' TO',I3,' WILL BE SKIPPED.')
        DO 320 KS=KZZ,KDIM
        READ(IUNIT)
  320   CONTINUE
        GO TO 400

        ELSE
        KK=KK+1
        ENDIF

      ENDIF
  330 CONTINUE

      ELSE
        IF(JV .EQ. JVBOG .AND. KK .EQ. 1)  THEN
        DO 340 KSK=1,KDIM
        READ(IUNIT)
  340   CONTINUE
        ENDIF
      ENDIF
  350 CONTINUE

  400 CONTINUE

      RETURN

C-----------------------------------------------------------------------

C  ++++++++++++++++++++++++
C  ++++  ENTRY RDSPP2  ++++
C  ++++++++++++++++++++++++

      ENTRY RDSPP2(IUNIT,KLBOG,JVBOG,MWAVE,INDXP,INDXV)

C  READ ALL LEVELS OF Z, THEN ALL LEVELS OF VORT/DIV PAIRS PICK UP
C    WHAT'S NEEDED BY LEVEL AND VARIABLE

C  HEIGHT

      KK=1
      DO 1200 JV=1,JVBOG
      IF(INDXV(JV) .EQ. 1)  THEN
      DO 1100 K=1,KDIM
      READ(IUNIT) (WAVE1(NM),NM=1,MZWVD2)

      IF(K .EQ. INDXP(KK))  THEN

      ARRAY(1:MZWVD2,JV,KK)=WAVE1(1:MZWVD2)

      WRITE(6,1051) JV,KK,K,(WAVE1(NM),NM=1,10)
 1051 FORMAT(/'...PICKING UP HEIGHT COEF, STORAGE INDICES JV, KK=',
     1       2I5,' LEVEL INDEX=',I5,' WAVES(1-10)=',/,5X,10E12.4)

C  TERMINATE STORING LEVELS SINCE ARRAY IS FULL FOR LEVELS

        IF(KK .EQ. KLBOG)  THEN
        KZZ=K+1
        WRITE(6,1071) KZZ,KDIM
 1071   FORMAT(/'...STORING IS NOW TERMINATED FOR HEIGHT. ',
     1         'INDICES',I3,' TO',I3,' WILL BE SKIPPED.')
        DO 1080 KS=KZZ,KDIM
        READ(IUNIT)
 1080   CONTINUE
        GO TO 1210

        ELSE
        KK=KK+1
        ENDIF

      ENDIF
 1100 CONTINUE

      ELSE
        IF(JV .EQ. JVBOG .AND. KK .EQ. 1)  THEN
        DO 1130 KS=1,KDIM
        READ(IUNIT)
 1130   CONTINUE
        ENDIF
      ENDIF
 1200 CONTINUE

C  VORTICITY AND DIVERGENCE

 1210 KK=1
      DO 1300 K=1,KDIM

      READ(IUNIT) (WAVE2(NM),NM=1,MZWVD2)
      READ(IUNIT) (WAVE3(NM),NM=1,MZWVD2)

      IF(K .EQ. INDXP(KK))  THEN

      VDSAVE=.FALSE.
      DO 1280 JV=1,JVBOG

C  VORTICITY

      IF(INDXV(JV) .EQ. 2)  THEN

      ARRAY(1:MZWVD2,JV,KK)=WAVE2(1:MZWVD2)

      WRITE(6,1241) JV,KK,K,(WAVE2(NM),NM=1,10)
 1241 FORMAT(/'...PICKING UP VORTICITY COEF, STORAGE INDICES JV, ',
     1       'KK=',2I5,' LEVEL INDEX=',I5,' WAVES(1-10)=',/,5X,10E12.4)

C  DIVERGENCE

      ELSE IF(INDXV(JV) .EQ. 3)  THEN

      ARRAY(1:MZWVD2,JV,KK)=WAVE3(1:MZWVD2)

      WRITE(6,1251) JV,KK,K,(WAVE3(NM),NM=1,10)
 1251 FORMAT(/'...PICKING UP DIVERGENCE COEF, STORAGE INDICES JV, ',
     1       'KK=',2I5,' LEVEL INDEX=',I5,' WAVES(1-10)=',/,5X,10E12.4)

C  U AND V WINDS REQUIRE BOTH VORTICITY AND DIVERGENCE COEFFS

      ELSE IF(INDXV(JV) .EQ. 4 .OR. INDXV(JV) .EQ. 5)  THEN

      IF(.NOT. VDSAVE)  THEN

      ARRAY(1:MZWVD2,JV  ,KK)=WAVE2(1:MZWVD2)
      ARRAY(1:MZWVD2,JV+1,KK)=WAVE3(1:MZWVD2)

      WRITE(6,1261) JV,KK,K,(WAVE2(NM),NM=1,10),(WAVE3(NM),NM=1,10)
 1261 FORMAT(/'...STORING BOTH VORT AND DIV COEFFS FOR U,V: STORAGE ',
     1       'INDICES JV, KK=',2I5,' LEVEL INDEX=',I5,' WAVES(1-10)=',/,
     2       (5X,10E12.4))
      VDSAVE=.TRUE.
      ENDIF

      ENDIF
 1280 CONTINUE

C  TERMINATE STORING LEVELS SINCE ARRAY IS FULL FOR LEVELS

        IF(KK .EQ. KLBOG)  THEN
        KZZ=K+1
        WRITE(6,1287) KZZ,KDIM
 1287   FORMAT(/'...STORING IS NOW TERMINATED FOR HEIGHT AND WINDS. ',
     1         'INDICES',I3,' TO',I3,' WILL BE SKIPPED.')
        DO 1290 KS=KZZ,KDIM
        READ(IUNIT)
        READ(IUNIT)
 1290   CONTINUE
        GO TO 1310

        ELSE
        KK=KK+1
        ENDIF
      ENDIF
 1300 CONTINUE

C  RELATIVE HUMIDITY

 1310 KK=1
      DO 1450 JV=1,JVBOG

      IF(INDXV(JV) .EQ. 6)  THEN
      DO 1430 K=1,KDIMQ
      READ(IUNIT) (WAVE1(NM),NM=1,MZWVD2)

      IF(K .EQ. INDXP(KK))  THEN

      ARRAY(1:MZWVD2,JV,KK)=WAVE1(1:MZWVD2)

      WRITE(6,1411) JV,KK,K,(WAVE1(NM),NM=1,10)
 1411 FORMAT(/'...PICKING UP RELH COEFF, STORAGE INDICES JV, KK=',2I5,
     1       ' LEVEL INDEX=',I5,' WAVES(1-10)=',/,5X,10E12.4)

C  TERMINATE STORING LEVELS SINCE ARRAY IS FULL FOR LEVELS

        IF(KK .EQ. KLBOG)  THEN
        KZZ=K+1
        WRITE(6,1417) KZZ,KDIMQ
 1417   FORMAT(/'...STORING IS NOW TERMINATED FOR RELATIVE HUMIDITY. ',
     1         'K INDICES',I3,' TO',I3,' WILL BE SKIPPED.')
        DO 1420 KS=KZZ,KDIMQ
        READ(IUNIT)
 1420   CONTINUE
        GO TO 1500

        ELSE
        KK=KK+1
        ENDIF

      ENDIF
 1430 CONTINUE

      ELSE
        IF(JV .EQ. JVBOG .AND. KK .EQ. 1)  THEN
        DO 1440 KSK=1,KDIMQ
        READ(IUNIT)
 1440   CONTINUE
        ENDIF
      ENDIF
 1450 CONTINUE

C  TEMPERATURE ***NOTE: HISTORICAL CASES PRIOR TO JAN. 1990 HAVE
C                       STORED VIRTUAL TEMPERATURE ***

 1500 KK=1
      DO 1550 JV=1,JVBOG

      IF(INDXV(JV) .EQ. 7)  THEN
      DO 1530 K=1,KDIM
      READ(IUNIT) (WAVE1(NM),NM=1,MZWVD2)

      IF(K .EQ. INDXP(KK))  THEN

      ARRAY(1:MZWVD2,JV,KK)=WAVE1(1:MZWVD2)

      WRITE(6,1511) JV,KK,K,(WAVE1(NM),NM=1,10)
 1511 FORMAT(/'...PICKING UP TEMP COEFF, STORAGE INDICES JV, KK=',2I5,
     1       ' LEVEL INDEX=',I5,' WAVES(1-10)=',/,5X,10E12.4)

C  TERMINATE STORING LEVELS SINCE ARRAY IS FULL FOR LEVELS

        IF(KK .EQ. KLBOG)  THEN
        KZZ=K+1
        WRITE(6,1517) KZZ,KDIM
 1517   FORMAT(/'...STORING IS NOW TERMINATED FOR TEMPERATURE. ',
     1         ' K INDICES',I3,' TO',I3,' WILL BE SKIPPED.')
        DO 1520 KS=KZZ,KDIM
        READ(IUNIT)
 1520   CONTINUE
        GO TO 1600

        ELSE
        KK=KK+1
        ENDIF

      ENDIF
 1530 CONTINUE

      ELSE
        IF(JV .EQ. JVBOG)  THEN
        DO 1540 KSK=1,KDIM
        READ(IUNIT)
 1540   CONTINUE
        ENDIF
      ENDIF
 1550 CONTINUE

 1600 CONTINUE

      RETURN

C-----------------------------------------------------------------------

C  ++++++++++++++++++++++++
C  ++++  ENTRY SETTRN  ++++
C  ++++++++++++++++++++++++

      ENTRY SETTRN(KLZ,JVZ,MWV,IPLUS,IRO)

      MENDZ1=MWV+1
      NM =0
      DO 2020 MM=1,MENDZ1
      M=MM-1
      NEND1=MENDZ1
      IF(IRO.EQ.1) NEND1=MM+MENDZ1-1
      DO 2010 NN=MM,NEND1
      N=NN-1
      X1=-REAL(N*(N+1))
      X4=0.
      IF(N.NE.0) X4=ERSQ/X1
      NM=NM+1
      FER   (NM)=X4*ERIV
      QIMER (NM)=X4*ERIV*REAL(M)
 2010 CONTINUE
 2020 CONTINUE

C-----------------------------------------------------------------------

C  ++++++++++++++++++++++++
C  ++++  ENTRY SETRES  ++++
C  ++++++++++++++++++++++++

      ENTRY SETRES(KLZ,JVZ,MWV,IPLUS,IRO)
      CALL CHGRES(MWAVE+IPLUS,IROMB,ARRAY(1,JVZ,KLZ),MWV+IPLUS,
     1            IRO,WAVEZ)
      RETURN

C-----------------------------------------------------------------------

C  ++++++++++++++++++++++++
C  ++++  ENTRY SCASP1  ++++
C  ++++++++++++++++++++++++

      ENTRY SCASP1(XX,YY,JVZ,KLZ,MWV,IRO,SCOUT)

      CALL SPHERP(WAVEZ,MWV,IRO,0,0,FAC,YY,XX,SCOUT)
      RETURN

C-----------------------------------------------------------------------

C  ++++++++++++++++++++++++
C  ++++  ENTRY UVWSP1  ++++
C  ++++++++++++++++++++++++

      ENTRY UVWSP1(XX,YY,JVZ,KLZ,MWV,IPLUS,IRO,UVOUT)

      IF(ABS(YY).NE.90.) THEN
        COSLIV=1./COSDEG_8(YY)
      ELSE
        COSLIV=0.
      ENDIF

      CALL SPHERP(WAVEZ,MWV+IPLUS,IRO,0,0,FAC,YY,XX,UVOUT)
      UVOUT=UVOUT*COSLIV
      RETURN

C-----------------------------------------------------------------------

C  ++++++++++++++++++++++++
C  ++++  ENTRY UROSP1  ++++
C  ++++++++++++++++++++++++

      ENTRY UROSP1(XX,YY,JVZ,KLZ,MWV,IRO,UOUT)

      IF(ABS(YY).NE.90.) THEN
        COSLIV=1./COSDEG_8(YY)
      ELSE
        COSLIV=0.
      ENDIF

      CALL SPHERP(WAVEZ,MWV,IRO,1,1,FER,YY,XX,UOUT)
      UOUT=UOUT*COSLIV
      RETURN

C-----------------------------------------------------------------------

C  ++++++++++++++++++++++++
C  ++++  ENTRY VROSP1  ++++
C  ++++++++++++++++++++++++

      ENTRY VROSP1(XX,YY,JVZ,KLZ,MWV,IRO,VOUT)

      CALL SPHERP(WAVEZ,MWV,IRO,0,-1,QIMER,YY,XX,VOUT)
      VOUT=VOUT*COSLIV
      RETURN

C-----------------------------------------------------------------------

C  ++++++++++++++++++++++++
C  ++++  ENTRY UDVSP1  ++++
C  ++++++++++++++++++++++++

      ENTRY UDVSP1(XX,YY,JVZ,KLZ,MWV,IRO,UOUT)

      IF(ABS(YY).NE.90.) THEN
        COSLIV=1./COSDEG_8(YY)
      ELSE
        COSLIV=0.
      ENDIF

      CALL SPHERP(WAVEZ,MWV,IRO,0,-1,QIMER,YY,XX,UOUT)
      UOUT=UOUT*COSLIV
      RETURN

C-----------------------------------------------------------------------

C  ++++++++++++++++++++++++
C  ++++  ENTRY VDVSP1  ++++
C  ++++++++++++++++++++++++

      ENTRY VDVSP1(XX,YY,JVZ,KLZ,MWV,IRO,VOUT)

      CALL SPHERP(WAVEZ,MWV,IRO,1,1,FER,YY,XX,VOUT)
      VOUT=-VOUT*COSLIV
      RETURN

C-----------------------------------------------------------------------

C  ++++++++++++++++++++++++
C  ++++  ENTRY UVRSP2  ++++
C  ++++++++++++++++++++++++

      ENTRY UVRSP2(XX,YY,JVZ,KLZ,MWV,IRO,UOUT,VOUT)

      IF(ABS(YY).NE.90.) THEN
        COSLIV=1./COSDEG_8(YY)
      ELSE
        COSLIV=0.
      ENDIF

      CALL SPHERP(WAVEZ,MWV,IRO,1,1,FER,YY,XX,UOUT)
      UOUT=UOUT*COSLIV
      CALL SPHERP(WAVEZ,MWV,IRO,0,-1,QIMER,YY,XX,VOUT)
      VOUT=VOUT*COSLIV
c && 2 comments
CC    WRITE(6,1193) MWV,IRO,UOUT,VOUT
C1193 FORMAT('...MWV,IRO,ROTATIONAL U,V=',2I3,2F12.3)
      RETURN

C-----------------------------------------------------------------------

C  ++++++++++++++++++++++++
C  ++++  ENTRY UVDSP2  ++++
C  ++++++++++++++++++++++++

      ENTRY UVDSP2(XX,YY,JVZ,KLZ,MWV,IRO,UOUT,VOUT)

      IF(ABS(YY).NE.90.) THEN
        COSLIV=1./COSDEG_8(YY)
      ELSE
        COSLIV=0.
      ENDIF

      CALL SPHERP(WAVEZ,MWV,IRO,0,-1,QIMER,YY,XX,UOUTZ)
      UOUT=UOUT+UOUTZ*COSLIV
      CALL SPHERP(WAVEZ,MWV,IRO,1,1,FER,YY,XX,VOUTZ)
      VOUT=VOUT-VOUTZ*COSLIV
c && 2 comments
CC    WRITE(6,1197) MWV,IRO,UOUTZ,VOUTZ,UOUT,VOUT
C1197 FORMAT('...MWV,IRO, DIVERGENT,TOTAL U,V=',2I3,4F12.3)
      RETURN

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$

      SUBROUTINE TEMPLT(ISHAPE,DELTA,RLATCZ,RLONCZ,RMAXTP,JPTSMX,MXZ,
     1                  NXZ,RLATMN,RLATMX,RLONMN,RLONMX,RLATP,RLONP,JPT)

      SAVE

      DIMENSION RLATP(JPTSMX),RLONP(JPTSMX),WTP(JPTSMX)

      REAL(8)  DISTSP_8

C  DEGLAT IS ONE DEGREE LATITUDE IN METERS

      DATA SQRT2/1.41421/,DEGLAT/111.17E3/

C  DELTA IS DISTANCE BETWEEN EQUALLY-SPACED LAT/LON POINTS IN DEGREES
C  ISHAPE=0 IS FOR A SET OF POINTS JUST LARGER THAN A CIRCLE
C  ISHAPE=1 IS FOR POINTS WITHIN A RECTANGLE
C  ISHAPE=2 IS FOR POINTS COMPLETELY COVERING A RECTANGLE
C  RMAXTP IS IN KM

      HYPOT=DELTA*SQRT2*0.5*DEGLAT
      RMAXM=RMAXTP*1000.
      RLATC=RLATCZ
      RLONC=RLONCZ
      RADD =0.0
      IF(ISHAPE .EQ. 2)  RADD =DELTA*1000.
      WRITE(6,9) ISHAPE,DELTA,RLATC,RLONC,RMAXTP
    9 FORMAT(///' ...ENTERING TEMPLT WITH ISHAPE,DELTA,RLATC,RLONC,',
     1       'RMAXTP=',I5,4F11.4)

      JPT=0
      MX=0
      NY=0
      MPTSX=NINT(SQRT(REAL(JPTSMX)))
      NPTSX=MPTSX

C  SEARCH OUTWARD FOR BOX THAT CIRCUMSCRIBES RMAXTP.  THE OUTERMOST
C    POINT WILL BE <= RMAXTP FOR ISHAPE=0,1 AND > RMAXTP FOR ISHAPE=2

   10 CONTINUE
      MX=MX+1
      RLONZ=RLONC+MX*DELTA
      RD=DISTSP_8(RLATC,RLONC,RLATC,RLONZ)
      IF(RD .LE. RMAXM+RADD)  GO TO 10

   20 CONTINUE
      NY=NY+1
      RLATZ=RLATC+NY*DELTA
      RD=DISTSP_8(RLATC,RLONC,RLATZ,RLONC)
      IF(RD .LE. RMAXM+RADD)  GO TO 20

      WRITE(6,21)  MX,NY
   21 FORMAT(/'...IN TEMPLT, VALUES OF MX, NY=',2I5)

      MPTS=2*MX+1
      NPTS=2*NY+1
      IF(MPTS .GT. MPTSX)  THEN
      MX=(MPTSX-1)/2
      WRITE(6,31)  MPTS,MPTSX,MX
   31 FORMAT(/'******MAXIMUM VALUE OF LONGITUDINAL POINTS EXCEEDED',
     1       ' FOR TEMPLATE.  MPTS, MPTS=',2I5,/,15X,'MPTS SET TO',
     2       ' MAXIMUM AND MX RECALCULATED TO BE',I5)
      MPTS=MPTSX
      ENDIF

      IF(NPTS .GT. NPTSX)  THEN
      NY=(NPTSX-1)/2
      WRITE(6,41)  NPTS,NPTSX,NY
   41 FORMAT(/'******MAXIMUM VALUE OF LATITUDINAL POINTS EXCEEDED',
     1       ' FOR TEMPLATE.  NPTS, NPTS=',2I5,/,15X,'NPTS SET TO',
     2       ' MAXIMUM AND NY RECALCULATED TO BE',I5)
      MPTS=MPTSX
      ENDIF

C  STORE ALL POINTS BEGINNING AT THE ANCHOR POINT ON THE NORTHWEST
C    CORNER OF THE BOX.  POINTS OUTSIDE THE CIRCLE OF RADIUS RMAXTP ARE
C    CONSIDERED IF A BOX OF DIMENSION DELTA WOULD INTERSECT THE RMAXTP
C    CIRCLE.  HOWEVER, THEY ARE GIVEN LESSER WEIGHT THAN FOR INSIDE THE
C    CIRCLE (=1.0).  WEIGHTS ARE ASSIGNED IN SUBROUTINE TEMWT.

      RLATA=RLATC+(NY+1)*DELTA
      RLONA=RLONC-(MX+1)*DELTA

      DO NNY=1,NPTS
         RLATZ=RLATA-NNY*DELTA

         DO MMX=1,MPTS
            RLONZ=RLONA+MMX*DELTA
            RD=DISTSP_8(RLATC,RLONC,RLATZ,RLONZ)

            IF(RD-RMAXM .GT. HYPOT .AND. ISHAPE .EQ. 0)  GO TO 50
            JPT=JPT+1
            RLATP(JPT)=RLATZ
            RLONP(JPT)=RLONZ
c && 2 comments
CC          WRITE(6,49) JPT,RLATC,RLONC,RLATZ,RLONZ
CC 49 FORMAT('...STORING JPT,RLATC,RLONC,RLATZ,RLONZ',/,5X,I5,4F11.4)
   50       CONTINUE
         END DO
      END DO

      IF(ISHAPE .EQ. 0)  WRITE(6,51) JPT
   51 FORMAT(/'...THE NUMBER OF TEMPLATE POINTS FOR AVERAGING',
     1       ' OVER THE CIRCULAR AREA IS:',I5)
      IF(ISHAPE .EQ. 1)  WRITE(6,53) JPT
   53 FORMAT(/'...THE NUMBER OF TEMPLATE POINTS FOR BOGUSING',
     1       ' OVER THE RECTANGULAR AREA IS:',I5)

      IF(JPT .GT. JPTSMX)  THEN
      WRITE(6,57) JPT,JPTSMX
   57 FORMAT(/'******IN TEMPLT, # OF POINTS=',I6,' EXCEEDS AVAILABLE ',
     1       'SPACE=',I6,'. AN OVERWRITING ERROR HAS OCCURRED.',/,7X,
     2       'THE CURRENT OPTION IS TO CONTINUE, BUT SOME GARBAGE ',
     3       'MAY RESULT.')
      JPT=JPTSMX
      ENDIF

      MXZ=MPTS
      NXZ=NPTS
      RLATMN= 100.
      RLATMX=-100.
      RLONMN= 361.
      RLONMX=-361.

      DO 70 NP=1,MXZ*NXZ
      RLATMN=MIN(RLATMN,RLATP(NP))
      RLATMX=MAX(RLATMX,RLATP(NP))
      RLONMN=MIN(RLONMN,RLONP(NP))
      RLONMX=MAX(RLONMX,RLONP(NP))
   70 CONTINUE

      RETURN

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    TEMWT       ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: STI        DATE: 2016-05-18
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C 2016-05-18  S. J. LORD
C        Added arguments (delta,rlatc,rlonc,rmaxtp), data statement,
C        hypot calculation, and reinstated weight calculation.
C        Uninitialized variables addressed.
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$

C SJL 4/13/16 added arguments in lower case
      SUBROUTINE TEMWT(rlatc,rlonc,rmaxtp,RLATP,RLONP,WTP,delta,JPTSMX)

      SAVE

      DIMENSION RLATP(JPTSMX),RLONP(JPTSMX),WTP(JPTSMX)

      REAL(8)  DISTSP_8
C SJL 4/13/16 (3 lines)
      DATA SQRT2/1.41421/,DEGLAT/111.17E3/

      HYPOT=DELTA*SQRT2*0.5*DEGLAT
      RMAXM=RMAXTP*1000.
      DO 100 NP=1,JPTSMX
      RD=DISTSP_8(RLATC,RLONC,RLATP(NP),RLONP(NP))

      IF(RD .LE. RMAXM)  THEN
      WTP(NP)=1.0
      ELSE
c fixit??
cc dak 7/3/05    WTP(NP)=1.0-(RD-RMAXM)/HYPOT
C      wtp(np)=1.0  ! dak 7/3/05: HYPOT was never defined!!
C SJL 4/13/16 reinstate weight calculation
      WTP(NP)=1.0-(RD-RMAXM)/HYPOT
      ENDIF
c && 4 comments
CC    WRITE(6,99) JPTSMX,NP,RLATC,RLONC,RLATP(NP),RLONP(NP),WTP(NP)
CC   1           ,RD,RMAXM,HYPOT
CC 99 FORMAT('  ...JPTSMX,NP,RLATC,RLONC,RLATP(NP),RLONP(NP),WTP(NP)',
CC   1      ',RD,RMAXM,HYPOT=',/,5X,2I5,8F12.4)
  100 CONTINUE
      RETURN

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$

C  *****************************
C  ****  SUBROUTINE OUTENV  ****
C  *****************************

      SUBROUTINE OUTENV(IFILE,ICALL,FIELD,MXX,NXX,KXX,MTITLE,NCHAR)

      SAVE

      DIMENSION FIELD(MXX,NXX*KXX)
      CHARACTER MTITLE*(*)

C  WRITE A DUMMY HEADER RECORD TO ENSURE CONSISTENCY WITH THE MAP
C    LAUNCHER FORMAT

      IF(ICALL .EQ. 0)  THEN

      IDUM=1
  
      WRITE(IFILE) MXX,IDUM,(FIELD(MM,1),MM=1,MXX)
      ENDIF

      NXXX=NXX*KXX

      WRITE(6,1) IFILE,MXX,NXX,KXX,NXXX,NCHAR,MTITLE(1:NCHAR)
    1 FORMAT(/'...ENTERING OUTENV WITH IFILE,MXX,NXX,KXX,NXXX,',
     1       'NCHAR,MTITLE=',6I5,/,4X,A)

      WRITE(IFILE) MXX,NXXX,((FIELD(MM,NN),MM=1,MXX),NN=1,NXXX),
     1             MTITLE,NCHAR

c && 6 comments
CC    WRITE(6,7)
CC  7 FORMAT(/'...FIELD ARRAY PRINTOUT IN OUTENV')
CC    DO NN=1,NXXX
CC    WRITE(6,9) NN,(FIELD(MM,NN),MM=1,MXX)
CC  9 FORMAT(/I4/(1X,10F12.5))
CC    ENDDO

      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$

C  *****************************
C  ****  SUBROUTINE OUTGES  ****
C  *****************************

      SUBROUTINE OUTGES(IUNTFE,NPTS,FIELD,MTITLE)

      CHARACTER MTITLE*(*)

      DIMENSION FIELD(2*NPTS)

      WRITE(IUNTFE,1) MTITLE
    1 FORMAT(A)
      WRITE(IUNTFE,3) (FIELD(NP),NP=1,2*NPTS)
    3 FORMAT(10F10.2)

      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    REDSUB      READS VARIOUS BOGUSING FILE FORMATS
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: 1991-06-06
C
C ABSTRACT: READS ENVIRONMENTAL DATA ARRAYS AND BOGUS DATA RECORDS
C   FOR TROPICAL CYCLONE BOGUSING.  THERE ARE TWO ENTRIES: READA FOR
C   ENVIRONMENTAL ARRAYS AND READBG FOR BOGUSING RECORDS.  ARGUMENTS
C   FOR EACH ENTRY ARE LISTED UNDER USAGE.  ENVIRONMENTAL ARRAYS ARE
C   IN A GENERIC "MAP LAUNCHER" FORMAT, WHILE BOGUS RECORDS ARE
C   CHARACTER RECORDS.  OUTPUT IS ONE ARRAY OR ONE RECORD AT A TIME.
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD
C
C USAGE:    CALL READA(IUNIT,MZ,NZ,F,KL,IV,IEND)
C           CALL READBG(IUNITB,RLATBG,RLONBG,KL,ZZ,UU,VV,IEND)
C   INPUT ARGUMENT LIST:
C     IUNIT    - READ UNIT FOR THE ENVIRONMENTAL ARRAYS
C     IUNITB   - READ UNIT FOR THE BOGUS DATA
C     MZ       - ZONAL (X) DIMENSION OF THE ENVIRONMENTAL ARRAY
C     NZ       - MERIDIONAL (Y) DIMENSION OF THE ENVIRONMENTAL ARRAY
C              - NOTE: THE Y DIMENSION IS DOUBLED WHEN READING A
C              - VECTOR VARIABLE (WIND)
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     F        - ENVIRONMENTAL ARRAY
C     KL       - LEVEL INDEX FOR VARIABLE RETURNED. MANDATORY
C              - PRESSURE LEVELS ARE ASSUMED WITH KL=1 FOR 1000 MB AND
C              - KL=10 FOR 100 MB.
C     IV       - IDENTIFIER FOR ARRAY RETURNED AS FOLLOWS:
C              - IV=1: TEMPERATURE
C              - IV=2: RELATIVE HUMIDITY
C              - IV=3: GEOPOTENTIAL HEIGHT
C              - IV=4: WIND, BOTH U AND V IN ARRAY F
C              - IV=6: RELATIVE VORTICITY
C     ZZ       - BOGUS VALUE OF GEOPOTENTIAL HEIGHT
C     UU       - BOGUS VALUE OF ZONAL WIND
C     VV       - BOGUS VALUE OF MERIDIONAL WIND
C     IEND     - END OF FILE MARKER. =1 IF EOF, =0 OTHERWISE
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     DDNAME1  - GENERIC NAME & CONTENT
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     DDNAME2  - GENERIC NAME & CONTENT AS ABOVE
C     FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$

      SUBROUTINE REDSUB(IUNIT,IUNITB,MZ,NZ,F,KL,IV,IEND,RLATBG,RLONBG,
     1                  ZZ,UU,VV)

      PARAMETER (MAXBGK=10)
      CHARACTER MTITLE*102
      LOGICAL FIRST

      COMMON/OVRHED/ITYP,PRES(MAXBGK)

      SAVE

      DIMENSION F(MZ,NZ),PLEV(MAXBGK)

      DATA PLEV/1000.,850.,700.,500.,400.,300.,250.,200.,150.,100./,
     1     EPS/0.1/,FIRST/.TRUE./

C-----------------------------------------------------------------------

      ENTRY READAG(IUNIT,MZ,NZ,F,KL,IV,IEND)

C  THIS ENTRY READS A MAP LAUNCHER FORMAT FILE OF GRIDDED FIELDS WHICH
C    ARE OF LIMITED AREA OR GLOBAL IN EXTENT, BUT HAVE CONSTANT LAT/LON
C    SPACING.

      IF(FIRST)  THEN
      FIRST=.FALSE.
      PRES=PLEV
      ENDIF

      IEND=0
      READ(IUNIT,END=30) IMAX,JMAX,((F(I,J),I=1,IMAX),J=1,JMAX),
     1               MTITLE,NCHAR
      if(nchar.le.0) then
         print *
         print *
         print *, '%%%%%% nchar = 0!!!! - this should not happen'
         print *
         print *
      else
         WRITE(6,6) IMAX,JMAX,MTITLE(1:NCHAR)
    6    FORMAT(///' ...IN READA, IMAX,JMAX,MTITLE=',2I5/4X,A)
      end if

C  DIVIDE MTITLE INTO VARIABLE AND PRESSURE LEVEL

      IF(MTITLE(1:1) .EQ. 'Z') THEN
      IV=3
      ELSE IF(MTITLE(1:1) .EQ. 'T') THEN
      IV=1
      ELSE IF(MTITLE(1:2) .EQ. 'RH') THEN
      IV=2
      ELSE IF(MTITLE(1:1) .EQ. '$') THEN
      IV=4
      ELSE IF(MTITLE(1:3) .EQ. 'VOT') THEN
      IV=6
      ENDIF
      WRITE(6,9) IV
    9 FORMAT('...IV=',I5)

      WRITE(6,11) MTITLE(9:12)
   11 FORMAT('...MTITLE(9:12)=',A)
      READ(MTITLE(9:12),13) IPRES
   13 FORMAT(I4)
      WRITE(6,15) IPRES
   15 FORMAT('...IPRES=',I5)
      DO 20 K=1,MAXBGK
      KL=K
      IF(ABS(REAL(IPRES)-PRES(K)) .LT. EPS) RETURN
   20 CONTINUE
      WRITE(6,21) PP
   21 FORMAT('******COULD NOT FIND PRESSURE LEVEL IN READA, PP=',
     1       F10.2)
      CALL ABRT1(' READAG',21)

   30 IEND=1
      RETURN

C-----------------------------------------------------------------------

C  ENTRY FOR READING BOGUS DATA AND IDENTIFYING VERTICAL LEVEL THE BOGUS
C    DATA IS READ IN THE FORMAT OF THE LORD/OOYAMA HRD ANALYSIS FORMAT
C    (EBCDIC/ASCII CHARACTERS)

      ENTRY READBG(IUNITB,RLATBG,RLONBG,KL,ZZ,UU,VV,IEND)
      IEND=0
      READ(IUNITB,51,END=100) ITYP,IDATEJ,ITIME,RLATBG,RLONBG,PP,
     1           RMISS,RMISS,ZZ,UU,VV
   51 FORMAT(I2,1X,I9,1X,I4,1X,2(F7.3,1X),3(F6.1,1X),F7.1,
     1       2(F6.1,1X))
c && 3 comments
CC    WRITE(6,52) RLATBG,RLONBG,PP,ZZ,UU,VV
CC 52 FORMAT('...READING BOGUS POINTS AT RLATBG,RLONBG,PP,ZZ,UU,VV=',
CC   1       3F10.2,3F12.3)

      DO 60 K=1,MAXBGK
      KL=K
      IF(ABS(PP-PRES(K)) .LT. EPS) RETURN
   60 CONTINUE
      WRITE(6,61) PP
   61 FORMAT('******COULD NOT FIND PRESSURE LEVEL IN READBG, PP=',
     1       F10.2)
      CALL ABRT1(' READBG',61)

  100 IEND=1
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    SLDATE      RETRIEVES DATE FROM SYSTEM AND DATE FILE
C   PRGMMR: D. A. KEYSER     ORG: W/NMC22    DATE: 1998-06-05
C
C ABSTRACT: RETRIEVES DATE FROM SYSTEM AND FROM A DATE FILE, AND
C   OBTAINS THE DIFFERENCE BETWEEN THE TWO.  CONSTRUCTS SLORD DATE
C   FORMAT.
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD
C 1998-06-05  D. A. KEYSER - Y2K/F90 COMPLIANCE
C
C USAGE:    CALL SLDATE(IUNTDT,IDATEZ,IUTCZ,IOFFTM)
C   INPUT ARGUMENT LIST:
C     IUNTDT   - UNIT NUMBER FOR FILE CONTAINING DATE LABEL
C
C   OUTPUT ARGUMENT LIST:
C     IDATEZ   - SLORD DATE FORMAT FOR DATE (YYYYMMDD)
C     IUTCZ    - SLORD DATE FORMAT FOR DATE (HHMM)
C     IOFFTM   - OFFSET (HOURS *100) BETWEEN SYSTEM DATE AND
C              - FILE DATE (SYSTEM DATE MINUS FILE DATE)
C
C   INPUT FILES:
C     UNIT "IUNTDT" - FILE CONTAINING NCEP DATE IN 6X,I4,3I2 FORMAT
C                   - (YYYYMMDDHH)
C
C   OUTPUT FILES:
C     UNIT 06  - STANDARD OUTPUT
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE SLDATE(IUNTDT,IDATEZ,IUTCZ,IOFFTM)

      CHARACTER USRDAT*32

      SAVE

      DIMENSION IDAT(8),JDAT(8),KDAT(8),RINC(5),RINC2(5)

      COMMON/BDATE/LDAT(8)

      EQUIVALENCE (IDAT(1),JW3YR),(IDAT(2),JW3MO),(IDAT(3),JW3DA),
     2            (IDAT(5),JW3HR),(IDAT(6),JW3MIN),(IDAT(7),JW3SEC)

      DATA ISTYR/7/,ISTMO/11/,ISTDA/13/,ISTHR/15/,ITWO/2/IFOUR/4/

      READ(IUNTDT,1) USRDAT
    1 FORMAT(A32)
      WRITE(6,3) USRDAT
    3 FORMAT(/'...',A32,'...')

C OBTAIN CURRENT SYSTEM DATE - IDAT (UTC)

      CALL W3UTCDAT(IDAT)

C DECODE THE DATE LABEL INTO JDAT (UTC)

      JDAT = 0
      READ(USRDAT(ISTYR:ISTYR+IFOUR-1),'(I4)') JDAT(1)
      READ(USRDAT(ISTMO:ISTMO+ITWO-1),11) JDAT(2)
      READ(USRDAT(ISTDA:ISTDA+ITWO-1),11) JDAT(3)
      READ(USRDAT(ISTHR:ISTHR+ITWO-1),11) JDAT(5)
   11 FORMAT(I2)

C THIS IS THE TIME ZONE OFFSET (SAME AS FOR IDAT)

      JDAT(4) = IDAT(4)

      JDAT(6) = 0

C COMBINE YEAR, MONTH, DAY, HOUR, MINUTE TO SLORD FORMAT (YYYYMMDD)

      IDATEZ=JDAT(1)*10000+JDAT(2)*100+JDAT(3)
      IUTCZ =JDAT(5)*100+JDAT(6)

C OBTAIN TIME DIFFERENCE (CURRENT TIME - LABEL TIME) IN HOURS * 100

      CALL W3DIFDAT(IDAT,JDAT,2,RINC)
      IOFFTM=NINT(RINC(2)*100.)

C OBTAIN BASE DATE FROM WHICH FRACTIONAL NUMBER OF DAYS WILL BE
C  DETERMINED (ALWAYS 365 DAYS EARLIER THAN 00Z ON NCEP DATE) - LDAT

      RINC2 = 0.
      RINC2(1) = -365.
      KDAT = 0
      KDAT(1:3) = JDAT(1:3)
      CALL W3MOVDAT(RINC2,KDAT,LDAT)

      WRITE(6,5) JW3YR,JW3MO,JW3DA,JW3HR,JW3MIN,JW3SEC,IOFFTM
    5 FORMAT(/'...CURRENT DATE/TIME FROM W3UTCDAT CALL IS:',/,
     1       'JW3YR=',I5,' JW3MO=',I3,' JW3DA=',I3,' JW3HR=',I5,
     2       ' JW3MIN=',I5,' JW3SEC=',I5,' OFFTIM=',I8)
      WRITE(6,35) LDAT(1),LDAT(2),LDAT(3),LDAT(5),LDAT(6)
   35 FORMAT(/'...BASE DATE FROM WHICH FRACTIONAL NUMBER OF DAYS WILL',
     $ ' BE CALCULATED IS:',I5,4I3/)

      WRITE(6,13) IDATEZ,IUTCZ
   13 FORMAT('...IN SLDATE, IDATEZ,IUTCZ=',I10,2X,I4)

      RETURN

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    FIXSLM      MODIFIES SEA-LAND MASK
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: 1992-04-08
C
C ABSTRACT: MODIFIES NCEP GAUSSIAN GRID SEA-LAND MASK.  CONVERTS
C   SOME SMALL ISLANDS TO OCEAN POINTS.  PROGRAM IS DEPENDENT
C   ON MODEL RESOLUTION.
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD
C 1992-04-08  S. J. LORD  CONVERTED TO T126 FROM T80
C
C USAGE:    CALL FIXSLM(LONF,LATG2,RLON,RLAT,SLMASK)
C   INPUT ARGUMENT LIST:
C     LONF     - NUMBER OF LONGITUDINAL POINTS, FIRST INDEX OF SLMASK
C     LATG2    - NUMBER OF LATITUDINAL POINTS, SECOND INDEX OF SLMASK
C     RLON     - LONGITUDES
C     RLAT     - LATITUDES
C     SLMASK   - SEA-LAND MASK ON GAUSSIAN GRID
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     SLMASK   - SEA-LAND MASK ON GAUSSIAN GRID
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     FT06F001 - STANDARD PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE FIXSLM(LONF,LATG2,RLON,RLAT,SLMASK)

      PARAMETER (MAXSLM=35)

      SAVE

      DIMENSION RLAT(LATG2),RLON(LONF),SLMASK(LONF,LATG2),IPT(MAXSLM),
     1          JPT(MAXSLM)

      DATA NOCEAN/21/,
C  INDONESIAN ARCHIPELAGO,NEW CALEDONIA
     1     IPT/133,135,129,177,
C  YUCATAN
     2         290,291,292,289,290,291,289,290,291,
C  CUBA
     3         299,300,301,302,303,303,304,305,14*0.0/,
C  INDONESIAN ARCHIPELAGO,NEW CALEDONIA
     1     JPT/106,105,106,118,
C  YUCATAN
     2         3*73,3*74,3*75,
C  CUBA
     3         3*72,2*73,3*74,14*0.0/

c && 2 comments
CC    WRITE(6,7)
CC  7 FORMAT('...CONVERTING LAND TO OCEAN, NPT,IPT,RLON,JPT,RLAT=')
      DO 10 NPT=1,NOCEAN
      SLMASK(IPT(NPT),JPT(NPT))=0.0
c && 2 comments
CC    WRITE(6,9) NPT,IPT(NPT),RLON(IPT(NPT)),JPT(NPT),RLAT(JPT(NPT))
CC  9 FORMAT(5X,2I5,F10.3,I5,F10.3)
   10 CONTINUE

      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    GAULAT      CALCULATES GAUSSIAN GRID LATITUDES
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: 1991-06-06
C
C ABSTRACT: CALCULATES GAUSSIAN GRID LATITUDES
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD - COPIED FROM KANAMITSU LIBRARY
C
C USAGE:    CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C   INPUT ARGUMENT LIST:
C     INARG1   - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C     INARG2   - TYPE.  EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     WRKARG   - GENERIC DESCRIPTION, ETC., AS ABOVE.
C     OUTARG1  - EXPLAIN COMPLETELY IF ERROR RETURN
C     ERRFLAG  - EVEN IF MANY LINES ARE NEEDED
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     DDNAME1  - GENERIC NAME & CONTENT
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     DDNAME2  - GENERIC NAME & CONTENT AS ABOVE
C     FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE GAULAT(GAUL,K)

      IMPLICIT REAL(8) (A-H,O-Z)
      DIMENSION A(500)
ccc dak 7/3/05      REAL GAUL(1)
      real gaul(k) ! dak 7/3/05: fix bounds-check error

      SAVE

      ESP=1.D-14
      C=(1.D0-(2.D0/3.14159265358979D0)**2)*0.25D0
      FK=K
      KK=K/2
      CALL BSSLZ1(A,KK)
      DO 30 IS=1,KK
      XZ=COS(A(IS)/SQRT((FK+0.5D0)**2+C))
      ITER=0
   10 PKM2=1.D0
      PKM1=XZ
      ITER=ITER+1
      IF(ITER.GT.10) GO TO 70
      DO 20 N=2,K
      FN=N
      PK=((2.D0*FN-1.D0)*XZ*PKM1-(FN-1.D0)*PKM2)/FN
      PKM2=PKM1
      PKM1=PK
   20 CONTINUE
      PKM1=PKM2
      PKMRK=(FK*(PKM1-XZ*PK))/(1.D0-XZ**2)
      SP=PK/PKMRK
      XZ=XZ-SP
      AVSP=ABS(SP)
      IF(AVSP.GT.ESP) GO TO 10
      A(IS)=XZ
   30 CONTINUE
      IF(K.EQ.KK*2) GO TO 50
      A(KK+1)=0.D0
      PK=2.D0/FK**2
      DO 40 N=2,K,2
      FN=N
      PK=PK*FN**2/(FN-1.D0)**2
   40 CONTINUE
   50 CONTINUE
      DO 60 N=1,KK
      L=K+1-N
      A(L)=-A(N)
   60 CONTINUE

      RADI=180./(4.*ATAN(1.))
      GAUL(1:K)=ACOS(A(1:K))*RADI
C && 2 comments
CC    PRINT *,'GAUSSIAN LAT (DEG) FOR JMAX=',K
CC    PRINT *,(GAUL(N),N=1,K)

      RETURN
   70 WRITE(6,6000)
 6000 FORMAT(//5X,'ERROR IN GAULAT'//)
      CALL ABRT1(' GAULAT',6000)
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    BSSLZ1      CALCULATES BESSEL FUNCTIONS
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: 1991-06-06
C
C ABSTRACT: CALCULATES BESSEL FUNCTIONS
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD - COPIED FROM KANAMITSU LIBRARY
C
C USAGE:    CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C   INPUT ARGUMENT LIST:
C     INARG1   - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C     INARG2   - TYPE.  EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     WRKARG   - GENERIC DESCRIPTION, ETC., AS ABOVE.
C     OUTARG1  - EXPLAIN COMPLETELY IF ERROR RETURN
C     ERRFLAG  - EVEN IF MANY LINES ARE NEEDED
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     DDNAME1  - GENERIC NAME & CONTENT
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     DDNAME2  - GENERIC NAME & CONTENT AS ABOVE
C     FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE BSSLZ1(BES,N)

      IMPLICIT REAL(8) (A-H,O-Z)
      DIMENSION BES(N)
      DIMENSION BZ(50)

      DATA PI/3.14159265358979D0/
      DATA BZ         / 2.4048255577D0, 5.5200781103D0,
     $  8.6537279129D0,11.7915344391D0,14.9309177086D0,18.0710639679D0,
     $ 21.2116366299D0,24.3524715308D0,27.4934791320D0,30.6346064684D0,
     $ 33.7758202136D0,36.9170983537D0,40.0584257646D0,43.1997917132D0,
     $ 46.3411883717D0,49.4826098974D0,52.6240518411D0,55.7655107550D0,
     $ 58.9069839261D0,62.0484691902D0,65.1899648002D0,68.3314693299D0,
     $ 71.4729816036D0,74.6145006437D0,77.7560256304D0,80.8975558711D0,
     $ 84.0390907769D0,87.1806298436D0,90.3221726372D0,93.4637187819D0,
     $ 96.6052679510D0,99.7468198587D0,102.888374254D0,106.029930916D0,
     $ 109.171489649D0,112.313050280D0,115.454612653D0,118.596176630D0,
     $ 121.737742088D0,124.879308913D0,128.020877005D0,131.162446275D0,
     $ 134.304016638D0,137.445588020D0,140.587160352D0,143.728733573D0,
     $ 146.870307625D0,150.011882457D0,153.153458019D0,156.295034268D0/
      NN=N
      IF(N.LE.50) GO TO 12
      BES(50)=BZ(50)
      DO 5 J=51,N
      BES(J)=BES(J-1)+PI
    5 CONTINUE
      NN=49
   12 CONTINUE
      BES(1:NN)=BZ(1:NN)

      RETURN

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    SEARCH      SEARCHES FOR TCVITALS RECORDS
C   PRGMMR: D. A. KEYSER     ORG: NP22       DATE: 1998-10-28
C
C ABSTRACT: SEARCHES FOR TCVITALS (TROPICAL CYCLONE VITAL
C   STATISTICS) RECORDS ON A SPECIFIED DATE/TIME.
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD
C 1998-10-28  D. A. KEYSER - Y2K/F90 COMPLIANCE
C
C USAGE:    CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C   INPUT ARGUMENT LIST:
C     INARG1   - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C     INARG2   - TYPE.  EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     WRKARG   - GENERIC DESCRIPTION, ETC., AS ABOVE.
C     OUTARG1  - EXPLAIN COMPLETELY IF ERROR RETURN
C     ERRFLAG  - EVEN IF MANY LINES ARE NEEDED
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     DDNAME1  - GENERIC NAME & CONTENT
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     DDNAME2  - GENERIC NAME & CONTENT AS ABOVE
C     FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE SEARCH(IDATEZ,IUTCZ,IHRWIN,MAXSTM,KSTORM,STMLAT,STMLON,
     1                  STMDIR,STMSPD,RMAX,PENV,PCEN,PTOP,IDATE,IUTC,
     2                  VMAX,RMW,R15NE,R15SE,R15SW,R15NW,PT,IOVITL,
     3                  IUNTBH,IERSRC,IERVIT,QCFILE,FSTFLG,RSMC,STMID,
     4                  STMNAM,ihrreq)

      CHARACTER STMNMZ*9

      LOGICAL QCFILE

      INTEGER  JDAT(8),KDAT(8)

      REAL(8)  COSDEG_8

      DIMENSION  RINC(5),RINC2(5)

      SAVE

      CHARACTER STMNAM*9,STMID*3,RSMC*4

      LOGICAL FSTFLG

      DIMENSION STMNAM(MAXSTM),STMLAT(MAXSTM),STMLON(MAXSTM),
     1          STMDIR(MAXSTM),STMSPD(MAXSTM),IDATE(MAXSTM),
     2          IUTC(MAXSTM),RMAX(MAXSTM),PENV(MAXSTM),PCEN(MAXSTM),
     3          PTOP(MAXSTM),RSMC(MAXSTM),RMW(MAXSTM),VMAX(MAXSTM),
     4          R15NW(MAXSTM),R15NE(MAXSTM),R15SE(MAXSTM),R15SW(MAXSTM),
     5          STMID(MAXSTM),FSTFLG(MAXSTM)

      COMMON/BDATE/LDAT(8)

C  FACSPD IS CONVERSION FACTOR FOR R(DEG LAT)=V(M/S)*T(FRAC DAY)*FACSPD
C  FIVMIN IS FIVE MINUTES IN UNITS OF FRACTIONAL DAYS

      DATA IPRNT/0/,FACSPD/0.77719/,FIVMIN/3.4722E-3/

C  THIS SUBROUTINE DIRECTS THE SEARCH FOR ALL STORMS AT A SPECIFIED
C    DATE AND TIME.  IT RETURNS THE NAMES OF ALL STORMS THAT EXIST
C    TOGETHER WITH LATITUDE, LONGITUDE, DIRECTION, SPEED, RADIUS OF
C    OUTERMOST CLOSED ISOBAR, ENVIRONMENTAL AND CENTRAL PRESSURE.  THE
C    FILE QUERIED IS THE SECOND GENERATION VITAL STATISTICS FILE.

      IRDVI=0
      IDATZZ=IDATEZ
      IUTCZZ=IUTCZ
      WRITE(6,5) IDATEZ,IUTCZ,IHRWIN,QCFILE
    5 FORMAT(///21X,57('*')/21X,'****',49X,'****'/21X,'**** FINDING ',
     1       'ALL STORMS ON DATE=',I9,'; UTC=',I5,' ****',/,21X,'****',
     2       16X,'WINDOW=',I4,' HOURS',16X,'****',/,21X,'****  A "@" ',
     3       'SIGN INDICATES AN EXTRAPOLATED POSITION  ****',/,21X,
     4       '****',7X,'THE FILE IS QUALITY CONTROLED:',L2,'.',9X,'****'
     5       /21X,'****',49X,'****'/21X,57('*')//)

   10 IOPT=1
      IDTREQ=IDATZZ
      IHRREQ=IUTCZZ

      CALL NEWVIT(IOVITL,IPRNT,IOPT,IERVIT,MAXSTM,KSTORM,IDTREQ,IHRREQ,
     1            IHRWIN,IDATE,IUTC,STMLAT,STMLON,STMDIR,STMSPD,
     2            PCEN,PENV,RMAX,VMAX,RMW,R15NE,R15SE,R15SW,R15NW,
     3            PTOP,FSTFLG,STMNAM,STMID,RSMC)

      IF(KSTORM .GT. 0)  THEN

      WRITE(6,13)
      WRITE(IUNTBH,13)
   13 FORMAT(/5X,'NAME',7X,'SID',1X,'FST',1X,'YYYYMMDD',2X,'HHMM',3X,
     1       'LAT',3X,'LONG',3X,'DIR',3X,'SPD',3X,'PCEN',3X,'PENV',4X,
     2       'RMAX',2X,'PTOP',3X,'VMAX',3X,'RMW',3X,'R15NE',2X,
     3       'R15SE',2X,'R15SW',2X,'R15NW'/)
      DO KST=1,KSTORM
      STMNMZ=STMNAM(KST)
      IF(IRDVI .GT. 0 .OR. IHRWIN .GT. 0)  THEN

C  FOR A NON-ZERO TIME WINDOW, MAKE SURE TIME AND POSITION ARE ADJUSTED
C    TO THE REQUESTED TIME

      IF(IHRWIN .GT. 0)  THEN
      CALL ZTIME(IDATEZ,IUTCZ,IYR,IMO,IDA,IHR,IMIN)
      KDAT = 0
      KDAT(1) = IYR
      KDAT(2) = IMO
      KDAT(3) = IDA
      CALL W3DIFDAT(KDAT,LDAT,1,RINC)
      JDY = NINT(RINC(1))
      CALL FLDAY(JDY,IHR,IMIN,DAYZ)
      CALL ZTIME(IDATE(KST),IUTC(KST),IYR,IMO,IDA,IHR,IMIN)
      KDAT = 0
      KDAT(1) = IYR
      KDAT(2) = IMO
      KDAT(3) = IDA
      CALL W3DIFDAT(KDAT,LDAT,1,RINC)
      JDY = NINT(RINC(1))
      CALL FLDAY(JDY,IHR,IMIN,DAYA)
      DT=DAYZ-DAYA
      ENDIF

      CALL DS2UV(USTM,VSTM,STMDIR(KST),STMSPD(KST))
      STMLON(KST)=STMLON(KST)+USTM*DT*FACSPD/COSDEG_8(STMLAT(KST))
      STMLAT(KST)=STMLAT(KST)+VSTM*DT*FACSPD
      IDATE(KST)=IDATEZ
      IUTC(KST) =IUTCZ
      IF(ABS(DT) .GT. FIVMIN)  STMNMZ(9:9)='@'
      ENDIF

      WRITE(6,17) KST,STMNMZ,STMID(KST),FSTFLG(KST),IDATE(KST),
     1            IUTC(KST),STMLAT(KST),STMLON(KST),STMDIR(KST),
     2            STMSPD(KST),PCEN(KST),PENV(KST),RMAX(KST),
     3            PTOP(KST),VMAX(KST),RMW(KST),R15NE(KST),
     4            R15SE(KST),R15SW(KST),R15NW(KST)
      WRITE(IUNTBH,17) KST,STMNMZ,STMID(KST),FSTFLG(KST),IDATE(KST),
     1                 IUTC(KST),STMLAT(KST),STMLON(KST),STMDIR(KST),
     2                 STMSPD(KST),PCEN(KST),PENV(KST),RMAX(KST),
     3                 PTOP(KST),VMAX(KST),RMW(KST),R15NE(KST),
     4                 R15SE(KST),R15SW(KST),R15NW(KST)
   17 FORMAT(I3,2X,A9,2X,A3,2X,L1,2X,I8,2X,I4,1X,F5.1,2F7.1,F5.1,1X,
     1       2F7.1,1X,2F6.1,2X,F5.1,5F7.1)
      ENDDO
      print *, ' '
      print *, ' '

C  OPTION 1: SET TOP OF ALL STORMS TO A CONSTANT PRESSURE.

      IF(NINT(PT*10.) .GT. 0)  THEN
      PTOP(1:KSTORM)=PT
      WRITE(6,27) PT
   27 FORMAT(/'...NOTE THAT ALL STORMS ARE FORCED TO A MAXIMUM ',
     1       'TOP LEVEL OF',F7.0,' HPA.')

C  OPTION 2: FIND THE DEEPEST CYCLONIC CIRCULATION OF ALL STORMS.
C            ****IMPORTANT NOTE: WE ASSUME THERE ARE NO MISSING
C                                VALUES (MISSING CODE=-99.0) ****

      ELSE
      PT=1.E10
      DO KST=1,KSTORM
         PT=MIN(PT,PTOP(KST))
      ENDDO
      WRITE(6,31) PT
   31 FORMAT(/'...PRESSURE LEVEL OF DEEPEST CYCLONIC CIRCULATION IS',
     1       F7.0,' HPA.')
      ENDIF

C  ***  NORMAL RETURN ***

      IERSRC=0
      RETURN

      ELSE

C  IN THE CASE WHERE NO STORMS CAN BE FOUND, AND THE WINDOW IS ZERO, WE
C    GO BACK IN TIME ONE HALF A CYCLE (6 H).

        IF(IRDVI .GT. 0 .OR. IHRWIN .GT. 0) THEN
        WRITE(6,33)
   33   FORMAT(/'******WE HAVE TRIED TO FIND STORMS BUT FAILED.',
     1         ' THEREFORE WE ARE TERMINATING THIS PROGRAM')
        IERSRC=33
        RETURN
        ENDIF

      IRDVI=1
      WRITE(6,41)
   41 FORMAT(/'******THERE WERE NO STORMS FOUND AT THE ORIGINALLY',
     1       ' REQUESTED TIME')

      CALL ZTIME(IDATZZ,IUTCZZ,IYR,IMO,IDA,IHR,IMIN)
      KDAT = 0
      KDAT(1) = IYR
      KDAT(2) = IMO
      KDAT(3) = IDA
      CALL W3DIFDAT(KDAT,LDAT,1,RINC)
      JDY = NINT(RINC(1))
      CALL FLDAY(JDY,IHR,IMIN,DAYZ)

c && 3 comments
CC    WRITE(6,61) IDATZZ,IUTCZZ,IYR,IMO,IDA,IHR,IMIN,JDY,DAYZ
CC 61 FORMAT(' DEBUGGING DATE/TIME, IDATZZ,IUTCZZ,IYR,IMO,IDA,IHR,',
CC   1       'IMIN,JDY,DAYZ=',I11,I9,6I5,F11.3)

      DT=0.25
      DAY00=DAYZ-DT

      RINC2 = 0.
      RINC2(1) = DAY00+FIVMIN
      CALL W3MOVDAT(RINC2,LDAT,JDAT)
      IYR = JDAT(1)
      JMO = JDAT(2)
      JDA = JDAT(3)
      JHR = JDAT(5)
      JMN = JDAT(6)

      WRITE(6,71) IYR,JMO,JDA,JHR,JMN
   71 FORMAT(' CALLING W3MOVDAT IYR,JMO,JDA=',5I5)

      IDATZZ=IYR*10000+JMO*100+JDA
      IUTCZZ=JHR*100+JMN

      IHRSUB=NINT(DT*24.)
      WRITE(6,81) IHRSUB,IDATZZ,IUTCZZ
   81 FORMAT(/3X,'...DATE/TIME AFTER SUBTRACTING',I4,' HOURS=',
     1       I11,I9,' WE WILL NOW SEARCH FOR STORMS AT THIS DATE/TIME.')
      GO TO 10
      ENDIF

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    TRKSUB      DETERMINES OBS. TROP. CYCLONE TRACKS
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: 1991-06-06
C
C ABSTRACT: CONTAINS VARIOUS ENTRY POINTS TO DETERMINE TROPICAL
C   CYCLONE TRACKS, CALCULATE STORM RELATIVE COORDINATE, DETERMINES
C   FIRST OCCURRENCE OF A PARTICULAR STORM.
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD
C
C USAGE:    CALL TRKSUB(IOVITL,IOPTZ,IDATTK,DAY00,DAYMN0,DAYMX0,DAYOFF,
C    1                  STMDR0,STMSP0,IERSET,IUTCTK,IFSTZ,FSTFGZ,
C    2                  QCFILE,RLON,RLAT,DAYZ,IHOWFR,ANGLE,STMNTK)
C           CALL SETTRK(IOVITL,IOPTZ,IDATTK,DAY00,DAYMN0,DAYMX0,DAYOFF,
C    1                  STMDR0,STMSP0,STMNTK,IERSET,ihrreq)
C
C   INPUT ARGUMENT LIST:
C     DAY00    - FRACTIONAL NUMBER OF DAYS SINCE 365 DAYS PRIOR TO
C              - 00Z ON NCEP DATE
C     DAYMX0   - FRACTIONAL NUMBER OF DAYS SINCE 365 DAYS PRIOR TO
C              - 00Z ON NCEP DATE
C     DAYMN0   - FRACTIONAL NUMBER OF DAYS SINCE 365 DAYS PRIOR TO
C              - 00Z ON NCEP DATE
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     WRKARG   - GENERIC DESCRIPTION, ETC., AS ABOVE.
C     OUTARG1  - EXPLAIN COMPLETELY IF ERROR RETURN
C     ERRFLAG  - EVEN IF MANY LINES ARE NEEDED
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     DDNAME1  - GENERIC NAME & CONTENT
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     DDNAME2  - GENERIC NAME & CONTENT AS ABOVE
C     FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$

      SUBROUTINE TRKSUB(IOVITL,IOPTZ,IDATTK,DAY00,DAYMN0,DAYMX0,DAYOFF,
     1                  STMDR0,STMSP0,IERSET,IUTCTK,IFSTZ,FSTFGZ,QCFILE,
     2                  RLON,RLAT,DAYZ,IHOWFR,ANGLE,STMNTK)

      PARAMETER(NSTM=70,NSTM1=NSTM+1,MAXSTM=NSTM)

      LOGICAL NOMIN,NOMAX,EXTRPB,EXTRPF,FSTFGZ,QCFILE,FIRST
      CHARACTER STMNTK*(*)

      SAVE

      DIMENSION  JDAT(8),RINC(5)

      REAL(8)  COSDEG_8,DISTSP_8

      INTEGER(8) IDAFST_8,ICHECK_8

      CHARACTER STMNAM*9,STMID*3,RSMC*4

      LOGICAL FSTFLG

      DIMENSION STMNAM(MAXSTM),STMLAT(MAXSTM),STMLON(MAXSTM),
     1          STMDIR(MAXSTM),STMSPD(MAXSTM),IDATE(MAXSTM),
     2          IUTC(MAXSTM),RMAX(MAXSTM),PENV(MAXSTM),PCEN(MAXSTM),
     3          PTOP(MAXSTM),RSMC(MAXSTM),RMW(MAXSTM),VMAX(MAXSTM),
     4          R15NW(MAXSTM),R15NE(MAXSTM),R15SE(MAXSTM),R15SW(MAXSTM),
     5          STMID(MAXSTM),FSTFLG(MAXSTM)

      PARAMETER (MAXTPC= 3)

      DIMENSION STMTPC(0:MAXTPC)

      CHARACTER SHALO*1,MEDIUM*1,DEEP*1,STMTPC*1,EXE*1

      DIMENSION TRKLTZ(0:NSTM1),TRKLNZ(0:NSTM1),TRKDRZ(0:NSTM1),
     1          TRKSPZ(0:NSTM1),TRKRMX(0:NSTM1),TRKPCN(0:NSTM1),
     2          TRKPEN(0:NSTM1),TRKVMX(0:NSTM1),TRKDPT(0:NSTM1)

      DIMENSION STMDAY(0:NSTM1),SRTDAY(NSTM),IDASRT(0:NSTM1),
     1          SRTLAT(NSTM),SRTLON(NSTM),SRTDIR(NSTM),SRTSPD(NSTM),
     2          ISRTDA(NSTM),ISRTUT(NSTM),SRTRMX(NSTM),SRTPCN(NSTM),
     3          SRTPEN(NSTM),SRTVMX(NSTM),SRTDPT(NSTM)

      COMMON/BDATE/LDAT(8)

      EQUIVALENCE (TRKLTZ(1),STMLAT(1)),(TRKLNZ(1),STMLON(1)),
     1            (TRKDRZ(1),STMDIR(1)),(TRKSPZ(1),STMSPD(1)),
     2            (TRKRMX(1),RMAX  (1)),(TRKPCN(1),PCEN  (1)),
     3            (TRKPEN(1),PENV  (1)),(TRKVMX(1),VMAX  (1)),
     4            (TRKDPT(1),PTOP  (1))

      DATA SHALO/'S'/,MEDIUM/'M'/,DEEP/'D'/,EXE/'X'/

      EQUIVALENCE (STMTPC(0), EXE),(STMTPC(1),SHALO),(STMTPC(2),MEDIUM),
     1            (STMTPC(3),DEEP)

C  FIVMIN IS FIVE MINUTES IN UNITS OF FRACTIONAL DAYS
C  FACSPD IS CONVERSION FACTOR FOR R(DEG LAT)=V(M/S)*T(FRAC DAY)*FACSPD
C  FIRST CONTROLS PRINTOUT FOR ENTRY FSTOCR

      DATA IPRNT/0/,FIVMIN/3.4722E-3/,FACSPD/0.77719/,FIRST/.TRUE./

C-----------------------------------------------------------------------

      ENTRY SETTRK(IOVITL,IOPTZ,IDATTK,DAY00,DAYMN0,DAYMX0,DAYOFF,
     1             STMDR0,STMSP0,STMNTK,IERSET,ihrreq)

      IERSET=0
      IOPT=IOPTZ
      IDTREQ=IDATTK
      IF(IOPT .EQ. 5)  THEN
      STMID (1)=STMNTK(1:3)
      ELSE IF(IOPT .EQ. 6)  THEN
      STMNAM(1)=STMNTK(1:9)
      ELSE
      WRITE(6,1) IOPT
    1 FORMAT(/'******ILLEGAL OPTION IN SETTRK=',I4)
      IERSET=1
      RETURN
      ENDIF

      WRITE(6,6) IOPT,STMNTK,DAY00,DAYMN0,DAYMX0,IDTREQ,IHRREQ
    6 FORMAT(/'...ENTERING SETTRK, WITH IOPT=',I2,'. LOOKING ',
     1       'FOR ALL FIXES FOR ',A,' WITH CENTRAL TIME=',F12.2,/,5X,
     2       'MIN/MAX TIMES=',2F12.2,' AND REQUESTED DATE/TIME=',I9,I8)

      CALL NEWVIT(IOVITL,IPRNT,IOPT,IERVIT,MAXSTM,KSTORM,IDTREQ,IHRREQ,
     1            IHRWIN,IDATE,IUTC,STMLAT,STMLON,STMDIR,STMSPD,PCEN,
     2            PENV,RMAX,VMAX,RMW,R15NE,R15SE,R15SW,R15NW,PTOP,
     3            FSTFLG,STMNAM,STMID,RSMC)

C  CONVERT FIX TIMES TO FLOATING POINT JULIAN DAY

      DO KST=1,KSTORM
      CALL ZTIME(IDATE(KST),IUTC(KST),IYR,IMO,IDA,IHR,IMIN)
      JDAT = 0
      JDAT(1) = IYR
      JDAT(2) = IMO
      JDAT(3) = IDA
      CALL W3DIFDAT(JDAT,LDAT,1,RINC)
      JDY = NINT(RINC(1))
      CALL FLDAY(JDY,IHR,IMIN,STMDAY(KST))
      STMDAY(KST)=STMDAY(KST)+DAYOFF

c && 4 comments
CC    WRITE(6,16) IDATE(KST),IUTC(KST),IYR,IMO,IDA,IHR,IMIN,JDY,
CC   1            STMDAY(KST)
CC 16 FORMAT('...STORM FIX TIMES ARE: IDATE,IUTC,IYR,IMO,IDA,IHR,',
CC   1       'IMIN,JDY,STMDAY',/,4X,8I8,F15.5)

      ENDDO

      CALL SORTRL(STMDAY(1:NSTM1),IDASRT(1:NSTM1),KSTORM)

c && 2 comments
CC    WRITE(6,26) (STMDAY(KST),IDASRT(KST),KST=1,KSTORM)
CC 26 FORMAT(/'...SORTED STORM DAYS AND INDEX ARE:',/,(5X,F15.5,I6))

C  PICK OUT TIMES AND LOCATIONS FROM SORTED LIST OF STORM DAYS

      NOMIN=.TRUE.
      NOMAX=.TRUE.
      EXTRPB=.FALSE.
      EXTRPF=.FALSE.
      KSRTMN=-1
      KSRTMX=-1

      KSRT = 0
      DO KSRT0=1,KSTORM
         KSRT = KSRT + 1

         IF(NINT(STMDAY(KSRT)*1000.) .GT. NINT(DAYMN0*1000.) .AND.
     $    NOMIN)  THEN
            NOMIN=.FALSE.
            KSRTMN=KSRT-1
         ENDIF

         IF(NINT(STMDAY(KSRT)*1000.) .GT. NINT(DAYMX0*1000.) .AND.
     $    NOMAX)  THEN
            NOMAX=.FALSE.
            KSRTMX=KSRT
         ENDIF

      ENDDO

      IF(KSRTMN .LE. 0)  THEN
         IF(KSRTMN.EQ.-1)  THEN

C  THERE IS ONLY ONE RECORD FOR THIS PARTICULAR STORM (IT MAY OR MAY
C   NOT BE EARLIER THAN THE WINDOW MINIMUM TIME).  THERE MAY BE AN
C   ERROR (UNLIKELY IF THIS CODE IS READING A TCVITALS FILE).
C   IRREGARDLESS, ALLOW EXTRAPOLATION OF THE OBSERVED MOTION BACK IN
C   TIME TO THE MINIMUM TIME ESTABLISHED BY THE TIME WINDOW.

            WRITE(6,241) KSTORM,KSRT,DAYMN0,(STMDAY(KST),KST=1,KSTORM)
  241 FORMAT(/'######THERE IS ONLY ONE RECORD FOR THIS STORM (IT IS AT',
     1       ' OR EARLIER THAN WINDOW MINIMUM).'/7X,'THERE MAY BE AN ',
     2       'ERROR (UNLIKELY IF THIS CODE IS READING A TCVITALS FILE)',
     3       ' - EXTRAPOLATE.'/7X,'KSTORM,KSRT,DAYMN0,STMDAY=',2I4,
     4       F13.3,/,(5X,10F12.3))
         ELSE

C  WE HAVEN'T BEEN ABLE TO FIND A STMDAY EARLIER THAN THE MINIMUM TIME
C    ESTABLISHED BY THE TIME WINDOW FOR A PARTICULAR STORM.  EITHER
C    THIS IS THE FIRST (AND MAYBE ONLY) TIME THIS STORM HAS BEEN RUN OR
C    THERE MAY BE AN ERROR (UNLIKELY IF THIS CODE IS READING A TCVITALS
C    FILE).  IRREGARDLESS, ALLOW EXTRAPOLATION OF THE OBSERVED MOTION
C    BACK IN TIME TO THE MINIMUM TIME ESTABLISHED BY THE TIME WINDOW.

            WRITE(6,41) KSTORM,KSRT,DAYMN0,(STMDAY(KST),KST=1,KSTORM)
   41 FORMAT(/'######CANNOT FIND ANY STORM RECORDS EARLIER THAN WINDOW',
     1       ' MINIMUM.'/7X,'THIS IS THE FIRST (AND MAYBE ONLY) RECORD',
     2       ' FOR THIS STORM OR THERE MAY BE AN ERROR (UNLIKELY IF'/7X,
     3       'THIS CODE IS READING A TCVITALS FILE) - EXTRAPOLATE. ',
     4       'KSTORM,KSRT,DAYMN0,STMDAY=',2I4,F13.3,/,(5X,10F12.3))
         END IF
         DT=STMDAY(1)-DAYMN0
         IF(DT .LE. 0.333333)  THEN

C  ... WE COME HERE IF THE EARLIEST STMDAY IS LESS THAN 8-HOURS LATER
C       THAN THE MINIMUM TIME ESTABLISHED BY THE TIME WINDOW.  IN THIS
C       CASE WE SET AN ERROR FLAG.
c fixit?? - I (dak) don't see the significance of this

            WRITE(6,841)
  841 FORMAT(/'######IN ADDITION TO ABOVE, EARLIEST STORM IS NO MORE ',
     1       'THAN 8-HRS LATER THAN WINDOW MINIMUM.'/7X,'SET IERSET=41')
            IERSET=41
         ENDIF

         EXTRPB=.TRUE.
         KSRTMN=0
         ISRT=IDASRT(1)
         IDASRT(KSRTMN)=0
         STMDAY(KSRTMN)=DAYMN0
         TRKDRZ(KSRTMN)=STMDIR(ISRT)
         TRKSPZ(KSRTMN)=STMSPD(ISRT)
         CALL DS2UV(USTM,VSTM,STMDIR(ISRT),STMSPD(ISRT))
         TRKLTZ(KSRTMN)=STMLAT(ISRT)-VSTM*DT*FACSPD
         TRKLNZ(KSRTMN)=STMLON(ISRT)-USTM*DT*FACSPD/
     1    COSDEG_8(STMLAT(ISRT))
         TRKRMX(KSRTMN)=RMAX(ISRT)
         TRKPCN(KSRTMN)=PCEN(ISRT)
         TRKPEN(KSRTMN)=PENV(ISRT)
         TRKVMX(KSRTMN)=VMAX(ISRT)
         TRKDPT(KSRTMN)=PTOP(ISRT)
         WRITE(6,39) ISRT,KSRTMN,STMDAY(KSRTMN),TRKDRZ(KSRTMN),
     1               TRKSPZ(KSRTMN),USTM,VSTM,DT,TRKLTZ(KSRTMN),
     2               TRKLNZ(KSRTMN),STMLAT(ISRT),STMLON(ISRT)
   39 FORMAT(/'...EXTRAPOLATING FIX BACKWARDS IN TIME: ISRT,KSRTMN,',
     1       '(STMDAY,TRKDRZ,TRKSPZ(KSRTMN)),USTM,VSTM,DT,',/,41X,
     2       '(TRKLTZ,TRKLNZ(KSRTMN)),(STMLAT,STMLON(ISRT))=',/,
     3       40X,2I3,6F12.3,/,43X,4F12.3)
      ENDIF

      IF(KSRTMX .LE. 0)  THEN

C  WE HAVEN'T BEEN ABLE TO FIND A STMDAY LATER THAN THE MAXIMUM TIME
C    ESTABLISHED BY THE TIME WINDOW FOR A PARTICULAR STORM.  EITHER
C    THIS IS THE LAST (AND MAYBE ONLY) RECORD FOR THIS STORM OR THERE
C    MAY BE AN ERROR (UNLIKELY IF THIS CODE IS READING A TCVITALS
C    FILE).  IRREGARDLESS, ALLOW EXTRAPOLATION OF THE OBSERVED MOTION
C    AHEAD IN TIME TO THE MAXIMUM TIME ESTABLISHED BY THE TIME WINDOW.

         WRITE(6,51) KSTORM,KSRT,DAYMX0,(STMDAY(KST),KST=1,KSTORM)
   51 FORMAT(/'######CANNOT FIND ANY STORM RECORDS LATER THAN WINDOW ',
     1       'MAXIMUM.'/7X,'THIS IS THE LAST (AND MAYBE ONLY) RECORD ',
     2       'FOR THIS STORM OR THERE MAY BE AN ERROR (UNLIKELY IF ',
     3       'THIS CODE IS READING'/7X,'A TCVITALS FILE) - ',
     4       'EXTRAPOLATE. KSTORM,KSRT,DAYMX0,STMDAY=',2I4,F13.3,/,
     5       (5X,10F12.3))
         DT=DAYMX0-STMDAY(KSTORM)
         IF(DT .LE. 0.333333)  THEN

C  ... WE COME HERE IF THE LATEST STMDAY IS LESS THAN 8-HOURS EARLIER
C       THAN THE MAXIMUM TIME ESTABLISHED BY THE TIME WINDOW.  IN THIS
C       CASE WE SET AN ERROR FLAG.
c fixit?? - I (dak) don't see the significance of this

            WRITE(6,851)
  851 FORMAT(/'######IN ADDITION TO ABOVE, LATEST STORM IS NO MORE ',
     1       'THAN 8-HRS EARLIER THAN WINDOW MAXIMUM.'/7X,'SET ',
     2       'IERSET=51')
            IERSET=51
         ENDIF

         EXTRPF=.TRUE.
         KSRTMX=KSTORM+1
         ISRT=IDASRT(KSTORM)
         IDASRT(KSRTMX)=KSTORM+1
         STMDAY(KSRTMX)=DAYMX0
         TRKDRZ(KSRTMX)=STMDIR(ISRT)
         TRKSPZ(KSRTMX)=STMSPD(ISRT)
         CALL DS2UV(USTM,VSTM,TRKDRZ(ISRT),TRKSPZ(ISRT))
         TRKLTZ(KSRTMX)=STMLAT(ISRT)+VSTM*DT*FACSPD
         TRKLNZ(KSRTMX)=STMLON(ISRT)+USTM*DT*FACSPD/
     1    COSDEG_8(STMLAT(ISRT))
         TRKRMX(KSRTMX)=RMAX(ISRT)
         TRKPCN(KSRTMX)=PCEN(ISRT)
         TRKPEN(KSRTMX)=PENV(ISRT)
         TRKVMX(KSRTMX)=VMAX(ISRT)
         TRKDPT(KSRTMX)=PTOP(ISRT)
         WRITE(6,49) ISRT,STMDAY(KSRTMX),TRKDRZ(KSRTMX),TRKSPZ(KSRTMX),
     1               USTM,VSTM,DT,TRKLTZ(KSRTMX),TRKLNZ(KSRTMX),
     2               STMLAT(ISRT),STMLON(ISRT)
   49 FORMAT(/'...EXTRAPOLATING FIX FORWARDS IN TIME: ISRT,',
     1       '(STMDAY,TRKDIR,TRKSPD(KSRTMX)),USTM,VSTM,DT,',/,41X,
     2       '(TRKLTZ,TRKLNZ(KSRTMX)),(STMLAT,STMLON(ISRT))=',/,
     3       40X,I3,6F12.3,/,43X,4F12.3)

      ENDIF

      KK=1
      KST0=-1
      TIMMIN=1.E10

C  PUT ALL FIXES THAT DEFINE THE TIME WINDOW INTO ARRAYS SORTED BY TIME.
C    FIRST, ELIMINATE RECORDS WITH DUPLICATE TIMES.  OUR ARBITRARY
C    CONVENTION IS TO KEEP THE LATEST RECORD.  ANY FIX TIME WITHIN 5
C    MINUTES OF ITS PREDECESSOR IN THE SORTED LIST IS CONSIDERED
C    DUPLICATE.

      DO KST=KSRTMN,KSRTMX
      IF(KST .GT. KSRTMN)  THEN
        IF(STMDAY(KST)-SRTDAY(KK) .LT. FIVMIN) THEN
        WRITE(6,53) KST,KK,STMDAY(KST),SRTDAY(KK)
   53   FORMAT(/'...TIME SORTED FIX RECORDS SHOW A DUPLICATE, KST,KK,',
     1         'STMDAY(KST),SRTDAY(KK)=',2I5,2F12.3)
        ELSE
        KK=KK+1
        ENDIF
      ENDIF

C  STORE SORTED LAT/LON, DIRECTION, SPEED FOR FUTURE USE.

      SRTLAT(KK)=TRKLTZ(IDASRT(KST))
      SRTLON(KK)=TRKLNZ(IDASRT(KST))
      SRTDIR(KK)=TRKDRZ(IDASRT(KST))
      SRTSPD(KK)=TRKSPZ(IDASRT(KST))
      SRTDAY(KK)=STMDAY(KST)
      SRTRMX(KK)=TRKRMX(IDASRT(KST))
      SRTPCN(KK)=TRKPCN(IDASRT(KST))
      SRTPEN(KK)=TRKPEN(IDASRT(KST))
      SRTVMX(KK)=TRKVMX(IDASRT(KST))
      SRTDPT(KK)=TRKDPT(IDASRT(KST))
c fixit?? - to avoid subscript zero warning on next two lines, I did
c           the following ....
cdak  ISRTDA(KK)=IDATE(IDASRT(KST))
cdak  ISRTUT(KK)=IUTC (IDASRT(KST))
      if(IDASRT(KST).ne.0)  then
         ISRTDA(KK)=IDATE(IDASRT(KST))
         ISRTUT(KK)=IUTC (IDASRT(KST))
      else
         ISRTDA(KK)=0
         ISRTUT(KK)=0
      end if
      IF(ABS(SRTDAY(KK)-DAY00) .LT. TIMMIN)  THEN
      IF(ABS(SRTDAY(KK)-DAY00) .LT. FIVMIN)  KST0=KK
      KSTZ=KK
      TIMMIN=ABS(SRTDAY(KK)-DAY00)
      ENDIF
      ENDDO

      KSTMX=KK

C  ZERO OUT EXTRAPOLATED DATE AND TIME AS A REMINDER

      IF(EXTRPF)  THEN
      ISRTDA(KSTMX)=0
      ISRTUT(KSTMX)=0
      ENDIF

      IF(EXTRPB)  THEN
      ISRTDA(1)=0
      ISRTUT(1)=0
      ENDIF

      IF(KSTZ .EQ. KSTMX .AND. .NOT. (EXTRPB .OR. EXTRPF))  THEN
      WRITE(6,61) KSTZ,KSTMX,(SRTDAY(KST),KST=1,KSTMX)
   61 FORMAT(/'******THE REFERENCE STORM INDEX IS THE MAXIMUM ALLOWED',
     1       ' A PROBABLE ERROR HAS OCCURRED',/,8X,
     2       'KSTZ,KSTMX,SRTDAY=',2I5,/,(5X,10F12.3))
      CALL ABRT1(' SETTRK',61)
      ENDIF

      IF(KST0 .LE. 0)  THEN
      WRITE(6,72) DAY00,KST0,(SRTDAY(KST),KST=1,KSTMX)
   72 FORMAT(/'******THERE IS NO FIX AT THE ANALYSIS TIME, AN',
     1       ' INTERPOLATED POSITION WILL BE CALCULATED',/,5X,
     2       'DAY00,KST0,SRTDAY=',F12.3,I6,/,(5X,10F12.3))
        IF(DAY00-SRTDAY(KSTZ) .GT. 0.0)  THEN
        RATIO=(DAY00-SRTDAY(KSTZ))/(SRTDAY(KSTZ+1)-SRTDAY(KSTZ))
        STLAT0=SRTLAT(KSTZ)+(SRTLAT(KSTZ+1)-SRTLAT(KSTZ))*RATIO
        STLON0=SRTLON(KSTZ)+(SRTLON(KSTZ+1)-SRTLON(KSTZ))*RATIO
        STMDR0=SRTDIR(KSTZ)+(SRTDIR(KSTZ+1)-SRTDIR(KSTZ))*RATIO
        STMSP0=SRTSPD(KSTZ)+(SRTSPD(KSTZ+1)-SRTSPD(KSTZ))*RATIO
        STDAY0=DAY00
        ELSE
        RATIO=(DAY00-SRTDAY(KSTZ-1))/(SRTDAY(KSTZ)-SRTDAY(KSTZ-1))
        STLAT0=SRTLAT(KSTZ-1)+(SRTLAT(KSTZ)-SRTLAT(KSTZ-1))*RATIO
        STLON0=SRTLON(KSTZ-1)+(SRTLON(KSTZ)-SRTLON(KSTZ-1))*RATIO
        STMDR0=SRTDIR(KSTZ-1)+(SRTDIR(KSTZ)-SRTDIR(KSTZ-1))*RATIO
        STMSP0=SRTSPD(KSTZ-1)+(SRTSPD(KSTZ)-SRTSPD(KSTZ-1))*RATIO
        STDAY0=DAY00
        ENDIF

      ELSE
      STLAT0=SRTLAT(KST0)
      STLON0=SRTLON(KST0)
      STMDR0=SRTDIR(KST0)
      STMSP0=SRTSPD(KST0)
      STDAY0=SRTDAY(KST0)
      ENDIF

      WRITE(6,77) (KSRT,ISRTDA(KSRT),ISRTUT(KSRT),SRTDAY(KSRT),
     1             SRTLAT(KSRT),SRTLON(KSRT),
     2             SRTDIR(KSRT),SRTSPD(KSRT),
     3             SRTPCN(KSRT),SRTPEN(KSRT),SRTRMX(KSRT),
     4             SRTVMX(KSRT),SRTDPT(KSRT),KSRT=1,KSTMX)
   77 FORMAT(/'...FINAL SORTED LIST IS:'/6X,'YYYYMMDD',2X,'HHMM',6X,
     1       'RJDAY',9X,'LAT',9X,'LON',8X,'DIR',9X,'SPEED',7X,'PCEN',8X,
     2       'PENV',8X,'RMAX',5X,'VMAX',4X,'PTOP'
     3       /(1X,I3,2X,I8,2X,I4,8F12.2,2(3X,F5.1)))

      WRITE(6,79) STDAY0,STLAT0,STLON0,STMDR0,STMSP0
   79 FORMAT(/'...THE REFERENCE TIME, LATITUDE, LONGITUDE,',
     1       ' DIRECTION AND SPEED ARE:',5F12.3)

      WRITE(6,89)
   89 FORMAT(/'...END SETTRK')

      RETURN

C-----------------------------------------------------------------------

      ENTRY STMADJ(RLON,RLAT,DAYZ)

C  INPUT ARG. DAYZ    - FRACTIONAL NUMBER OF DAYS SINCE 365 DAYS
C                       PRIOR TO 00Z ON NCEP DATE

c && 2 comments
CC    WRITE(6,101) RLAT,RLON,DAYZ
CC101 FORMAT(/'...ENTERING STMADJ,    RLAT,RLON,DAYZ=',2F12.2,F12.3)

      DO 110 KST=1,KSTMX-1
      KSTZ=KST
      IF(DAYZ .GE. SRTDAY(KST) .AND. DAYZ .LE. SRTDAY(KST+1))  GO TO 120
  110 CONTINUE
      WRITE(6,111) KSTMX,DAYZ,(SRTDAY(KS),KS=1,KSTMX)
  111 FORMAT(/'******CANNOT FIND FIX BRACKET IN STMADJ, KSTMX,DAYZ,',
     1       'SRTDAY=',I5,F12.3,/,(5X,10F12.3))
      CALL ABRT1(' STMADJ',111)

  120 DTFIX=SRTDAY(KSTZ+1)-SRTDAY(KSTZ)
      DTOB =DAYZ-SRTDAY(KSTZ)
      RATIO=DTOB/DTFIX
c && 2 comments
CC    WRITE(6,121) KSTZ,SRTDAY(KSTZ),SRTDAY(KSTZ+1),RATIO
CC121 FORMAT(/'...KSTZ,SRTDAY(KSTZ),SRTDAY(KSTZ+1),RATIO=',I5,3F12.3)

      RLATOB=SRTLAT(KSTZ)+(SRTLAT(KSTZ+1)-SRTLAT(KSTZ))*RATIO
      RLONOB=SRTLON(KSTZ)+(SRTLON(KSTZ+1)-SRTLON(KSTZ))*RATIO
      RLATOF=STLAT0-RLATOB
      RLONOF=STLON0-RLONOB
c && 5 comments
CC    WRITE(6,123) SRTLAT(KSTZ),SRTLAT(KSTZ+1),SRTLON(KSTZ),
CC   1             SRTLON(KSTZ+1),RLATOB,RLONOB,RLATOF,RLONOF
CC123 FORMAT(/'... SRTLAT(KSTZ),SRTLAT(KSTZ+1),SRTLON(KSTZ),',
CC   1       'SRTLON(KSTZ+1),RLATOB,RLONOB,RLATOF,RLONOF=',/,
CC   2       5X,8F12.3)

      RLAT=(NINT((RLAT+RLATOF)*100.))/100.
      RLON=(NINT((RLON+RLONOF)*100.))/100.
      DAYZ=STDAY0
c && 2 comments
CC    WRITE(6,131)  RLAT,RLON,DAYZ
CC131 FORMAT('...LEAVING STMADJ, NEW RLAT,RLON,DAYZ=',2F12.2,F12.3)
      RETURN

C-----------------------------------------------------------------------

      ENTRY STMCOR(RLAT,RLON,IHOWFR,ANGLE)

      DSTNCE=DISTSP_8(RLAT,RLON,STLAT0,STLON0)

C  SINCE RLAT AND RLON HERE ARE ONLY PRECISE TO NEAREST 100'TH DEG,
C   DSTNCE HERE IS ROUNDED TO NEAREST 10 METERS AND CALLED IHOWFR (M)
C   (NOTE: PREVIOUSLY, "IHOWFR" WAS "HOWFAR" WHICH WAS A FLOATING
C          POINT NUMBER CALC. TO FRACTIONAL METERS - THIS WAS
C          DIFFERENT BY TENS OF METERS IBM VS. CRAY)

      IHOWFR = (NINT(DSTNCE/10.)) * 10
      ANGLE= ATAN2DEG(RLON-STLON0,RLAT-STLAT0)
      IF(ANGLE .LT. 0.0) ANGLE=360.+ANGLE
c && 3 comments
CC    WRITE(6,141) RLAT,RLON,STLAT0,STLON0,REAL(IHOWFR),ANGLE
CC141 FORMAT('...IN STMCOR, RLAT,RLON,STLAT0,STLON0,DSTNCE(KM),',
CC   1       'ANGLE=',/,12X,4F12.2,-3P,F12.3,0P,F12.3)
      RETURN

C-----------------------------------------------------------------------

      ENTRY FSTOCR(IOVITL,IOPTZ,IDATTK,IUTCTK,STMNTK,IFSTZ,IERSET,
     1             FSTFGZ,QCFILE)

C  TESTING THE FIRST OCCURRENCE OF A PARTICULAR STORM IS DONE IN ONE OF
C    TWO WAYS:

C    1)  FOR A QUALITY CONTROLLED FILE, A FIRST OCCURRENCE FLAG IS
C         PRESENT AS A COLON IN COLUMN 19 AND THE VARIABLE FSTFLG IS
C         SET TRUE OR FALSE ACCORDINGLY.  IN THIS CASE, THIS ROUTINE
C         JUST TRANSLATES THIS FLAG INTO AN INTEGER.

C    2)  FOR A FILE THAT HAS NOT BEEN QUALITY CONTROLLED, E.G. A
C         RESEARCH FILE OR OLD HISTORICAL FILE, THE FLAG IS NOT PRESENT
C         AND WE MUST SEARCH FOR PREVIOUS OCCURRENCES OF THAT PARTICULAR
C         STORM.

C  OPTION 1: A QUALITY-CONTROLLED FILE

      IF(QCFILE)  THEN

      IF(FIRST)  WRITE(6,201) QCFILE
  201 FORMAT(/'...ENTERING FSTOCR WITH QCFILE=',L2,' LOGICAL ',
     1       'OCCURRENCE FLAGS WILL BE TRANSFORMED INTO INTEGERS.')

      IFSTZ=2
      IF(FSTFGZ) IFSTZ=1

C  OPTION 2: NOT A QUALITY-CONTROLLED FILE

      ELSE
      IOPT=IOPTZ
      IDTREQ=IDATTK
      IF(IOPT .EQ. 5)  THEN
      STMID (1)=STMNTK(1:3)
      ELSE IF(IOPT .EQ. 6)  THEN
      STMNAM(1)=STMNTK(1:9)
      ELSE
      WRITE(6,203) IOPT
  203 FORMAT(/'******ILLEGAL OPTION IN FSTOCR=',I4)
      IERSET=1
      RETURN
      ENDIF

      IF(FIRST)  WRITE(6,207) QCFILE,IOPT,STMNTK,IDATTK,IUTCTK
  207 FORMAT(/'...ENTERING FSTOCR WITH QCFILE=',L2,' AND IOPT=',I2,
     1       '. LOOKING FOR ALL FIXES FOR ',A,' TO COMPARE WITH DATE=',
     2       I9,' & UTC=',I5)

      CALL NEWVIT(IOVITL,IPRNT,IOPT,IERVIT,MAXSTM,KSTORM,IDTREQ,IHRREQ,
     1            IHRWIN,IDATE,IUTC,STMLAT,STMLON,STMDIR,STMSPD,PCEN,
     2            PENV,RMAX,VMAX,RMW,R15NE,R15SE,R15SW,R15NW,PTOP,
     3            FSTFLG,STMNAM,STMID,RSMC)

C  LOOK FOR THE MINIMUM FIX TIME
C A value of IDAFST > 2149mmddhh exceeds the 32-bit limit!!

      IDAFST_8=9999999999_8
      DO KST=1,KSTORM
         ICHECK   = IDATE(KST)*100+IUTC(KST)/100
         ICHECK_8 = ICHECK
         IDAFST_8 = MIN(ICHECK_8,IDAFST_8)
         IDAFST   = IDAFST_8
      ENDDO
      WRITE(6,221) IDAFST,IDATTK,IUTCTK
  221 FORMAT(/'...FIRST FIX IS AT YYYYMMDDHH=',I12,'. COMPARING WITH ',
     1       'IDATE,IUTC=',I9,I5)

      IF(IDAFST .EQ. IDATTK*100+IUTCTK/100) THEN
      IFSTZ=1

      ELSE
      IFSTZ=2
      ENDIF

      ENDIF

      FIRST=.FALSE.
      IF(IFSTZ .EQ. 1)  WRITE(6,231) STMNTK
  231 FORMAT('...THIS TIME IS THE FIRST OCCURRENCE OF STORM=',A)
      IF(IFSTZ .GE. 2)  WRITE(6,233) STMNTK
  233 FORMAT('...THIS STORM=',A,' HAS HAD PREVIOUS OCCURRENCES.')

      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    NEWVIT      READS TROP. CYCLONE VITAL STAT. FILE
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: 1991-06-06
C
C ABSTRACT: GENERAL FILE READER FOR TROPICAL CYCLONE VITAL STATISTICS
C   FILE.  CAN FIND ALL STORMS OF A PARTICULAR NAME OR ID, ALL
C   STORMS ON A PARTICULAR DATE/TIME AND VARIOUS COMBINATIONS OF
C   THE ABOVE.
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD
C
C USAGE:    CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C   INPUT ARGUMENT LIST:
C     INARG1   - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C     INARG2   - TYPE.  EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     WRKARG   - GENERIC DESCRIPTION, ETC., AS ABOVE.
C     OUTARG1  - EXPLAIN COMPLETELY IF ERROR RETURN
C     ERRFLAG  - EVEN IF MANY LINES ARE NEEDED
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     DDNAME1  - GENERIC NAME & CONTENT
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     DDNAME2  - GENERIC NAME & CONTENT AS ABOVE
C     FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE NEWVIT(IOVITL,IPRNT,IOPT,IERVIT,MAXSTM,KSTORM,IDTREQ,
     1                  IHRREQ,IHRWIN,IDATE,IUTC,STMLAT,STMLON,STMDIR,
     2                  STMSPD,PCEN,PENV,RMAX,VMAX,RMW,R15NE,R15SE,
     3                  R15SW,R15NW,PTOP,FSTFLG,STMNAM,STMID,RSMC)

      SAVE

      DIMENSION  JDAT(8),RINC(5)

      CHARACTER STMNAM*9,STMID*3,RSMC*4

      LOGICAL FSTFLG

      DIMENSION STMNAM(MAXSTM),STMLAT(MAXSTM),STMLON(MAXSTM),
     1          STMDIR(MAXSTM),STMSPD(MAXSTM),IDATE(MAXSTM),
     2          IUTC(MAXSTM),RMAX(MAXSTM),PENV(MAXSTM),PCEN(MAXSTM),
     3          PTOP(MAXSTM),RSMC(MAXSTM),RMW(MAXSTM),VMAX(MAXSTM),
     4          R15NW(MAXSTM),R15NE(MAXSTM),R15SE(MAXSTM),R15SW(MAXSTM),
     5          STMID(MAXSTM),FSTFLG(MAXSTM)

      PARAMETER (MAXCHR=95)
      PARAMETER (MAXVIT=15)
      PARAMETER (MAXTPC= 3)

      DIMENSION IVTVAR(MAXVIT),VITVAR(MAXVIT),VITFAC(MAXVIT),
     1          ISTVAR(MAXVIT),IENVAR(MAXVIT),STMTOP(0:MAXTPC)

      DIMENSION BUFIN(MAXCHR),STMTPC(0:MAXTPC),FMTVIT(MAXVIT)
      DIMENSION BUFY2K(MAXCHR)

      CHARACTER BUFIN*1,RSMCZ*4,STMIDZ*3,STMNMZ*9,FSTFLZ*1,STMDPZ*1,
     1          SHALO*1,MEDIUM*1,DEEP*1,LATNS*1,LONEW*1,FMTVIT*6,
     2          BUFINZ*100,STMREQ*9,RELOCZ*1,STMTPC*1,EXE*1
      CHARACTER BUFY2K*1

      COMMON/BDATE/LDAT(8)

      EQUIVALENCE (BUFIN(1),RSMCZ),(BUFIN(5),RELOCZ),(BUFIN(6),STMIDZ),
     1            (BUFIN(10),STMNMZ),(BUFIN(19),FSTFLZ),
     2            (BUFIN(37),LATNS),(BUFIN(43),LONEW),
     3            (BUFIN(MAXCHR),STMDPZ),(BUFIN(1),BUFINZ)

      EQUIVALENCE (IVTVAR(1),IDATEZ),(IVTVAR(2),IUTCZ)

      EQUIVALENCE (VITVAR( 3),STMLTZ),(VITVAR( 4),STMLNZ),
     1            (VITVAR( 5),STMDRZ),(VITVAR( 6),STMSPZ),
     2            (VITVAR( 7),PCENZ), (VITVAR( 8),PENVZ),
     3            (VITVAR( 9),RMAXZ), (VITVAR(10),VMAXZ),
     4            (VITVAR(11),RMWZ),  (VITVAR(12),R15NEZ),
     5            (VITVAR(13),R15SEZ),(VITVAR(14),R15SWZ),
     6            (VITVAR(15),R15NWZ)

      DATA SHALO/'S'/,MEDIUM/'M'/,DEEP/'D'/,EXE/'X'/,VITFAC/2*1.0,2*0.1,
     1     1.0,0.1,9*1.0/,FMTVIT/'(I8.8)','(I4.4)','(I3.3)','(I4.4)',
     2     2*'(I3.3)',3*'(I4.4)','(I2.2)','(I3.3)',4*'(I4.4)'/,
     3     ISTVAR/20,29,34,39,45,49,53,58,63,68,71,75,80,85,90/,
     4     IENVAR/27,32,36,42,47,51,56,61,66,69,73,78,83,88,93/,
     5     STMTOP/-99.0,700.,400.,200./

      EQUIVALENCE (STMTPC(0), EXE),(STMTPC(1),SHALO),(STMTPC(2),MEDIUM),
     1            (STMTPC(3),DEEP)

C  BASIN BOUNDARIES: MIN AND MAX LATITUDES; MIN AND MAX LONGITUDES
C    NOTE: SOME BOUNDARIES MAY OVERLAP, BUT SCANNING IS IN ORDER OF
C          DECREASING PRIORITY SO BASINS SHOULD BE CAPTURED PROPERLY

C  FIVMIN IS FIVE MINUTES IN UNITS OF FRACTIONAL DAYS

      DATA FIVMIN/3.4722E-3/,IRDERM/20/,NUM/1/

C  THIS SUBROUTINE READS A GLOBAL VITAL STATISTICS FILE FOR TROPICAL
C    CYCLONES.  THERE ARE A NUMBER OF OPTIONS (IOPT) UNDER WHICH THIS
C    ROUTINE WILL OPERATE:
C          1) FIND ALL STORMS ON A SPECIFIED DATE/TIME (+WINDOW)
C          2) FIND A PARTICULAR STORM NAME ON A SPECIFIED DATE/TIME
C             (+WINDOW)
C          3) FIND ALL OCCURRENCES OF A PARTICULAR STORM NAME
C          4) SAME AS OPTION 2, EXCEPT FOR A PARTICULAR STORM ID
C          5) SAME AS OPTION 3, EXCEPT FOR A PARTICULAR STORM ID
C          6) ALL OCCURRENCES OF A PARTICULAR STORM NAME, EVEN BEFORE IT
C             HAD A NAME (FIND FIRST OCCURRENCE OF STORM NAME,
C             SUBSTITUE STORM ID, REWIND, THEN EXECUTE OPTION 5

C  STORM ID POSITON CONTAINS THE BASIN IDENTIFIER IN THE LAST CHARACTER.
C    THESE ABBREVIATIONS ARE:
C          NORTH ATLANTIC:   L
C          EAST PACIFIC:     E
C          CENTRAL PACIFIC:  C
C          WEST PACIFIC:     W
C          AUSTRALIAN:       U
C          SOUTH INDIAN:     S
C          SOUTH PACIFIC     P
C          N ARABIAN SEA     A
C          BAY OF BENGAL     B
C          SOUTH CHINA SEA   O
C          EAST CHINA SEA    T

C  CHECK INPUT ARGUMENTS ACCORDING TO OPTION.  ALSO DO OVERHEAD CHORES
C    IF NECESSARY

      IERVIT=0
      STMREQ=' '
      IYRREQ=-9999

      IF(IOPT .LE. 2 .OR. IOPT .EQ. 4)  THEN
        IF(IDTREQ .LE. 0)  THEN
        WRITE(6,11) IOPT,IDTREQ,IHRREQ,IHRWIN,MAXSTM,STMNAM(1),STMID(1)
   11   FORMAT(/'****** ILLEGAL DATE IN NEWVIT, IOPT,IDTREQ,IHRREQ,',
     1         'IHRWIN,MAXSTM,STMNAM,STMID=',/,9X,5I10,2X,A9,2X,A3)
        IERVIT=10
        ENDIF

        IF(IHRREQ .LT. 0)  THEN
        WRITE(6,21) IOPT,IDTREQ,IHRREQ,IHRWIN,MAXSTM,STMNAM(1),STMID(1)
   21   FORMAT(/'****** ILLEGAL HOUR IN NEWVIT, IOPT,IDTREQ,IHRREQ,',
     1         'IHRWIN,MAXSTM,STMNAM,STMID=',/,9X,5I10,2X,A9,2X,A3)
        IERVIT=20
        ENDIF

        IF(IHRWIN .LT. 0)  THEN
        WRITE(6,31) IOPT,IDTREQ,IHRREQ,IHRWIN,MAXSTM,STMNAM(1),STMID(1)
   31   FORMAT(/'****** ILLEGAL WINDOW IN NEWVIT, IOPT,IDTREQ,IHRREQ,',
     1         'IHRWIN,MAXSTM,STMNAM,STMID=',/,9X,5I10,2X,A9,2X,A3)
        IERVIT=30

C  SET UP PARAMETERS FOR TIME WINDOW

        ELSE IF(IHRWIN .GT. 0)  THEN
        CALL ZTIME(IDTREQ,IHRREQ,IYRWIN,IMO,IDA,IHR,IMIN)
        JDAT = 0
        JDAT(1) = IYRWIN
        JDAT(2) = IMO
        JDAT(3) = IDA
        CALL W3DIFDAT(JDAT,LDAT,1,RINC)
        JDY = NINT(RINC(1))
        CALL FLDAY(JDY,IHR,IMIN,DAY00)

C  NORMAL CASE

        WINDOW=REAL(IHRWIN)/24.
        DAYPLS=DAY00+WINDOW+FIVMIN
        DAYMNS=DAY00-WINDOW-FIVMIN
        ENDIF
      ENDIF

      IF(IOPT .EQ. 2 .OR. IOPT .EQ. 3 .OR. IOPT .EQ. 6)  THEN
        IF(STMNAM(1) .EQ. ' ')  THEN
        WRITE(6,41) IOPT,IDTREQ,IHRREQ,IHRWIN,MAXSTM,STMNAM(1),STMID(1)
   41   FORMAT(/'****** ILLEGAL STMNAM IN NEWVIT, IOPT,IDTREQ,IHRREQ,',
     1         'IHRWIN,MAXSTM,STMNAM,STMID=',/,9X,5I10,2X,A9,2X,A3)
        IERVIT=40

        ELSE
        STMREQ=STMNAM(1)
        ENDIF

      ELSE IF(IOPT .EQ. 4 .OR. IOPT .EQ. 5)  THEN
        IF(STMID(1) .EQ. ' ')  THEN
        WRITE(6,51) IOPT,IDTREQ,IHRREQ,IHRWIN,MAXSTM,STMNAM(1),STMID(1)
   51   FORMAT(/'****** ILLEGAL STMID IN NEWVIT, IOPT,IDTREQ,IHRREQ,',
     1         'IHRWIN,MAXSTM,STMNAM,STMID=',/,9X,5I10,2X,A9,2X,A3)
        IERVIT=50

        ELSE
        STMREQ=STMID(1)
        ENDIF

      ELSE IF(IOPT .NE. 1)  THEN
      WRITE(6,61) IOPT,IDTREQ,IHRREQ,IHRWIN,MAXSTM,STMNAM(1),STMID(1)
   61 FORMAT(/'****** ILLEGAL OPTION IN NEWVIT, IOPT,IDTREQ,IHRREQ,',
     1       'IHRWIN,MAXSTM,STMNAM,STMID=',/,9X,5I10,2X,A9,2X,A3)
      IERVIT=60
      ENDIF

C  FOR OPTIONS 3, 5, 6 (ALL OCCURRENCES OPTIONS), SEARCH IS RESTRICTED
C    TO A SPECIFIC YEAR WHEN IDTREQ IS POSITIVE

      IF(IOPT .EQ. 3 .OR. IOPT .EQ. 5 .OR. IOPT .EQ. 6)
     1                                   IYRREQ=IDTREQ/10000

C  ******  ERROR EXIT  ******

      IF(IERVIT .GT. 0)  RETURN

C  INITIALIZE FILE AND COUNTERS

   90 REWIND IOVITL
      KREC=0
      KSTORM=0
      NERROR=0

C  READ A RECORD INTO BUFFER

  100 CONTINUE
cdak  READ(IOVITL,101,ERR=990,END=200) (BUFIN(NCH),NCH=1,MAXCHR)
      READ(IOVITL,101,ERR=200,END=200) (BUFIN(NCH),NCH=1,MAXCHR) ! Jack
  101 FORMAT(95A1)

C At this point we do not know if a 2-digit year begins in column 20
C  of the record (old non-y2k compliant form) or if a 4-digit year
C  begins in column 20 (new y2k compliant form) - test on location of
C  latitude N/S indicator to find out ...

      if(BUFIN(35).eq.'N' .or. BUFIN(35).eq.'S')  then

C ... this record still contains the old 2-digit form of the year -
C      for example:

C NHC  13L MITCH     981028 1800 164N 0858W 270 010 0957 1008 0371 51 019 0278 0278 0185 0185 D
C 123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123
C          1         2         3         4         5         6         7         8         9

C ... this program will convert the record to a 4-digit year using the
C      "windowing" technique since subsequent logic expects this  - for
C       example, the above record is converted to:

C NHC  13L MITCH     19981028 1800 164N 0858W 270 010 0957 1008 0371 51 019 0278 0278 0185 0185 D
C 12345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345
C          1         2         3         4         5         6         7         8         9

cppppp
         print *, ' '
         print *, '==> Read in RECORD from tcvitals file -- contains a',
     $    ' 2-digit year "',BUFIN(20:21),'"'
         print *, ' '
         print'(" From unit ",I0,"; BUFIN-1: ",95A)', iovitl,bufin
         print *, ' '
cppppp
         BUFY2K(1:19) = BUFIN(1:19)
         IF(BUFIN(20)//BUFIN(21).GT.'20')  THEN
            BUFY2K(20) = '1'
            BUFY2K(21) = '9'
         ELSE
            BUFY2K(20) = '2'
            BUFY2K(21) = '0'
         ENDIF
         BUFY2K(22:95) = BUFIN(20:93)
         BUFIN = BUFY2K
cppppp
         print *, ' '
         print *, '==> 2-digit year converted to 4-digit year "',
     $    BUFIN(20:23),'" via windowing technique'
         print *, ' '
         print'(" From unit ",I0,"; BUFIN-1: ",95A)', iovitl,bufin
         print *, ' '
cppppp

      else  if(BUFIN(37).eq.'N' .or. BUFIN(37).eq.'S')  then

C ... this record contains the new 4-digit form of the year -
C      for example:

C NHC  13L MITCH     19981028 1800 164N 0858W 270 010 0957 1008 0371 51 019 0278 0278 0185 0185 D
C 12345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345
C          1         2         3         4         5         6         7         8         9

C ... no conversion necessary since this subsequent logic expects this

cppppp
         print *, ' '
         print *, '==> Read in RECORD from tcvitals file -- contains a',
     $    ' 4-digit year "',BUFIN(20:23),'"'
         print *, ' '
         print'(" From unit ",I0,"; BUFIN-1: ",95A)', iovitl,bufin
         print *, ' '
         print *, '==> No conversion necessary'
         print *, ' '
cppppp

      else

         print *, ' '
         print *, '***** Cannot determine if this record contains ',
     $    'a 2-digit year or a 4-digit year - skip it and try reading ',
     $    'the next record'
         print *, ' '
         go to 100

      end if

      KREC=KREC+1

C  DECODE DATE AND TIME

      DO 110 IV=1,2
      CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV),
     1            BUFINZ)
CIBM  CALL FFA2I(BUFINZ,ISTVAR(IV),IENVAR(IV)-ISTVAR(IV)+1,
CIBM 1           NUM,IVTVAR(IV),IERDEC)
CCRAY CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV),
CCRAY1            BUFINZ)
c && 4 comments
CC    WRITE(6,109) IV,ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,
CC   1             FMTVIT(IV)
CC109 FORMAT(/'...DECODING VARIABLE #',I2,' ISTART,IEND,IVALUE,IER,',
CC   1       'FMT=',2I4,I10,I3,2X,A10)
  110 CONTINUE

C  FILTER OUT RECORDS THAT ARE NOT GATHERED BY CURRENT OPTION

C  FIRST: DATE/TIME/WINDOW FILTER

      IF(IOPT .LE. 2 .OR. IOPT .EQ. 4)  THEN

C  EXACT DATE/UTC ARE SPECIFIED

        IF(IHRWIN .EQ. 0)  THEN
c && 2 comments
CC      WRITE(6,117) IDATEZ,IUTCZ
CC117   FORMAT(/'...NO WINDOW OPTION: IDATEZ,IUTCZ=',2I10)
          IF(IDTREQ .NE. IDATEZ)  GO TO 100
          IF(IHRREQ .NE. IUTCZ )  GO TO 100

        ELSE
        CALL ZTIME(IDATEZ,IUTCZ,IYR,IMO,IDA,IHR,IMIN)
        JDAT = 0
        JDAT(1) = IYR
        JDAT(2) = IMO
        JDAT(3) = IDA
        CALL W3DIFDAT(JDAT,LDAT,1,RINC)
        JDY = NINT(RINC(1))
        CALL FLDAY(JDY,IHR,IMIN,DAYZ)

c && 3 comments
CC      WRITE(6,119) IYR,IMO,IDA,IHR,IMIN,JDY,DAYZ,DAYMNS,DAYPLS,IYRMNS
CC119   FORMAT('...DEBUGGING WINDOW TIME SELECTION: IYR,IMO,IDA,',
CC   1    'IHR,IMIN,JDY,DAYZ,DAYMNS,DAYPLS,IYRMNS=',/,15X,6I5,3F12.4,I5)

C  YEAR WINDOW, THEN FRACTIONAL JULIAN DAY WINDOW

        IF(IYR .NE. IYRWIN)  GO TO 100
        IF(DAYZ .LT. DAYMNS .OR. DAYZ .GT. DAYPLS)  GO TO 100
        ENDIF
      ENDIF

C  SECOND: STORM NAME FILTER

      IF(IOPT .EQ. 2 .OR. IOPT .EQ. 3 .OR. IOPT .EQ. 6)  THEN
      IF(IPRNT .GT. 0)  WRITE(6,123) STMNMZ,STMREQ
  123 FORMAT('...STORM NAME FILTER, STMNMZ,STMREQ=',A9,2X,A9)
      IF(STMNMZ .NE. STMREQ)  GO TO 100
      IF(IOPT .EQ. 3 .OR. IOPT .EQ. 6)  THEN
      IF(IYRREQ .GT. 0 .AND. IDATEZ/10000 .NE. IYRREQ)  GO TO 100
      ENDIF

C  FOR OPTION 6, BRANCH BACK TO LOOK FOR STORM ID INSTEAD OF STORM NAME

        IF(IOPT .EQ. 6)  THEN
        IOPT=5
        STMREQ=STMIDZ
        GO TO 90
        ENDIF

      ENDIF

C  THIRD: STORM ID FILTER

      IF(IOPT .EQ. 4 .AND.  STMIDZ .NE. STMREQ)  GO TO 100
      IF(IOPT .EQ. 5 .AND. (STMIDZ .NE. STMREQ .OR. (IYRREQ .GT. 0
     1   .AND. IDATEZ/10000 .NE. IYRREQ)))  GO TO 100

C  EUREKA

      IF(IPRNT .GT. 0)  WRITE(6,137) STMREQ,KREC
  137 FORMAT('...REQUESTED STORM FOUND, NAME/ID=',A9,' AT RECORD #',I6)

      DO 140 IV=3,MAXVIT
      CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV),
     1            BUFINZ)
CIBM  CALL FFA2I(BUFINZ,ISTVAR(IV),IENVAR(IV)-ISTVAR(IV)+1,
CIBM 1           NUM,IVTVAR(IV),IERDEC)
CCRAY CALL DECVAR(ISTVAR(IV),IENVAR(IV),IVTVAR(IV),IERDEC,FMTVIT(IV),
CCRAY1            BUFINZ)
      VITVAR(IV)=REAL(IVTVAR(IV))*VITFAC(IV)
  140 CONTINUE

C  DEPTH OF CYCLONIC CIRCULATION

      IF(STMDPZ .EQ. SHALO)  THEN
      PTOPZ=STMTOP(1)
      ELSE IF(STMDPZ .EQ. MEDIUM)  THEN
      PTOPZ=STMTOP(2)
      ELSE IF(STMDPZ .EQ. DEEP)  THEN
      PTOPZ=STMTOP(3)
      ELSE IF(STMDPZ .EQ. 'X')  THEN
      PTOPZ=-99.0
c && 3 comments
CC    WRITE(6,141) STMDPZ
CC141 FORMAT('******DEPTH OF CYCLONIC CIRCULATION HAS MISSING CODE=',
CC   1       A,'.')
      ELSE
      WRITE(6,143) STMDPZ
  143 FORMAT('******ERROR DECODING DEPTH OF CYCLONIC CIRCULATION,',
     1       ' STMDPZ=',A1,'. ERROR RECOVERY NEEDED.')
      ENDIF

C          *****************************************************
C          *****************************************************
C          ****            IMPORTANT NOTES:                 ****
C          ****                                             ****
C          ****    ALL STORM LONGITUDES CONVERTED TO        ****
C          ****    0-360 DEGREES, POSITIVE EASTWARD  !!!    ****
C          ****                                             ****
C          ****    ALL STORM SPEEDS ARE IN M/SEC            ****
C          ****                                             ****
C          ****    ALL DISTANCE DATA ARE IN KM              ****
C          ****                                             ****
C          ****    ALL PRESSURE DATA ARE IN HPA (MB)        ****
C          *****************************************************
C          *****************************************************

C  SIGN OF LATITUDE AND CONVERT LONGITUDE

      IF(LATNS .EQ. 'S')  THEN
      STMLTZ=-STMLTZ
      ELSE IF(LATNS .NE. 'N')  THEN
      WRITE(6,153) STMLTZ,STMLNZ,LATNS
  153 FORMAT('******ERROR DECODING LATNS, ERROR RECOVERY NEEDED.',
     1       '  STMLTZ,STMLNZ,LATNS=',2F12.2,2X,A1)
      GO TO 100
      ENDIF

      IF(LONEW .EQ. 'W')  THEN
      STMLNZ=360.-STMLNZ
      ELSE IF(LONEW .NE. 'E')  THEN
      WRITE(6,157) STMLTZ,STMLNZ,LATNS
  157 FORMAT('******ERROR DECODING LONEW, ERROR RECOVERY NEEDED.',
     1       '  STMLTZ,STMLNZ,LATNS=',2F12.2,2X,A1)
      ENDIF

      IF(IPRNT .EQ. 1)
     1  WRITE(6,161) IDATEZ,IUTCZ,STMLTZ,STMLNZ,STMDRZ,STMSPZ,PENVZ,
     2               PCENZ,RMAXZ,VMAXZ,RMWZ,R15NEZ,R15SEZ,R15SWZ,R15NWZ
  161 FORMAT('...ALL STORM DATA CALCULATED: IDATEZ,IUTCZ,',
     1       'STMLTZ,STMLNZ,STMDRZ,STMSPZ,PENVZ,PCENZ,',
     2       'RMAXZ,VMAXZ,RMWZ,R15NEZ,R15SEZ,R15SWZ,R15NWZ=',/,
     3       5X,2I10,13F8.2)

      IF(KSTORM .LT. MAXSTM)  THEN
      KSTORM=KSTORM+1
      IDATE(KSTORM)=IDATEZ
      IUTC(KSTORM)=IUTCZ
      PTOP(KSTORM)=PTOPZ
      STMLAT(KSTORM)=STMLTZ
      STMLON(KSTORM)=STMLNZ
      STMDIR(KSTORM)=STMDRZ
      STMSPD(KSTORM)=STMSPZ
      STMNAM(KSTORM)=STMNMZ
      STMID (KSTORM)=STMIDZ
      RSMC  (KSTORM)=RSMCZ
      RMAX(KSTORM)=RMAXZ
      PENV(KSTORM)=PENVZ
      PCEN(KSTORM)=PCENZ
      VMAX(KSTORM)=VMAXZ
      RMW(KSTORM)=RMWZ
      R15NE(KSTORM)=R15NEZ
      R15SE(KSTORM)=R15SEZ
      R15SW(KSTORM)=R15SWZ
      R15NW(KSTORM)=R15NWZ

C  SET THE FIRST OCCURRENCE FLAG IF PRESENT

      IF(FSTFLZ .EQ. ':')  THEN
      FSTFLG(KSTORM)=.TRUE.
      ELSE
      FSTFLG(KSTORM)=.FALSE.
      ENDIF

      GO TO 100

      ELSE
      GO TO 300
      ENDIF

  200 CONTINUE

      IF(KSTORM .GT. 0)  THEN

C  NORMAL RETURN HAVING FOUND REQUESTED STORM (S) AT DATE/TIME/WINDOW

      IF(IPRNT .EQ. 1)  WRITE(6,201) STMREQ,IDTREQ,IHRREQ,KSTORM,
     1                               KREC
  201 FORMAT(/'...FOUND STORM NAME/ID ',A12,' AT DATE, TIME=',
     1       I9,'/',I5,' UTC IN VITALS FILE.',/,4X,I5,' RECORDS FOUND.',
     2       ' TOTAL NUMBER OF RECORDS READ=',I7)
      RETURN

C  UNABLE TO FIND REQUESTED STORM AT DATE/TIME/WINDOW

      ELSE
      IF(IOPT .EQ. 1) STMREQ='ALLSTORMS'
      WRITE(6,207) IOPT,STMREQ,STMNMZ
  207 FORMAT(/'****  OPTION=',I3,' CANNOT FIND STORM NAME/ID=',A9,
     1       '... LAST STORM FOUND=',A9)

      WRITE(6,209) IDATEZ,IDTREQ,IUTCZ,IHRREQ
  209 FORMAT('****  CANNOT FIND REQUESTED DATE/TIME,',
     1       ' (FOUND, REQUESTED) (DATE/TIME)=',4I10,/)
      IERVIT=210
      RETURN
      ENDIF

  300 WRITE(6,301) KSTORM
  301 FORMAT(/'******KSTORM EXCEEDS AVAILABLE SPACE, KSTORM=',I5)
      RETURN

C-----------------------------------------------------------------------

      ENTRY VITLST(IOVITL)

      REWIND IOVITL
      WRITE(6,401)
  401 FORMAT(//20X,'**** LISTING OF VITAL STATISTICS FILE FOLLOWS ****'
     $ //)
      KREC=0
  410 CONTINUE
      READ(IOVITL,411,ERR=990,END=420) (BUFIN(NCH),NCH=1,MAXCHR)
  411 FORMAT(95A1)

C At this point we do not know if a 2-digit year begins in column 20
C  of the record (old non-y2k compliant form) or if a 4-digit year
C  begins in column 20 (new y2k compliant form) - test on location of
C  latitude N/S indicator to find out ...

      if(BUFIN(35).eq.'N' .or. BUFIN(35).eq.'S')  then

C ... this record still contains the old 2-digit form of the year -
C      for example:

C NHC  13L MITCH     981028 1800 164N 0858W 270 010 0957 1008 0371 51 019 0278 0278 0185 0185 D
C 123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123
C          1         2         3         4         5         6         7         8         9

C ... this program will convert the record to a 4-digit year using the
C      "windowing" technique since subsequent logic expects this  - for
C       example, the above record is converted to:

C NHC  13L MITCH     19981028 1800 164N 0858W 270 010 0957 1008 0371 51 019 0278 0278 0185 0185 D
C 12345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345
C          1         2         3         4         5         6         7         8         9

cppppp
         print *, ' '
         print *, '==> Read in RECORD from tcvitals file -- contains a',
     $    ' 2-digit year "',BUFIN(20:21),'"'
         print *, ' '
         print'(" From unit ",I0,"; BUFIN-1: ",95A)', iovitl,bufin
         print *, ' '
cppppp
         BUFY2K(1:19) = BUFIN(1:19)
         IF(BUFIN(20)//BUFIN(21).GT.'20')  THEN
            BUFY2K(20) = '1'
            BUFY2K(21) = '9'
         ELSE
            BUFY2K(20) = '2'
            BUFY2K(21) = '0'
         ENDIF
         BUFY2K(22:95) = BUFIN(20:93)
         BUFIN = BUFY2K
cppppp
         print *, ' '
         print *, '==> 2-digit year converted to 4-digit year "',
     $    BUFIN(20:23),'" via windowing technique'
         print *, ' '
         print'(" From unit ",I0,"; BUFIN-1: ",95A)', iovitl,bufin
         print *, ' '
cppppp

      else  if(BUFIN(37).eq.'N' .or. BUFIN(37).eq.'S')  then

C ... this record contains the new 4-digit form of the year -
C      for example:

C NHC  13L MITCH     19981028 1800 164N 0858W 270 010 0957 1008 0371 51 019 0278 0278 0185 0185 D
C 12345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345
C          1         2         3         4         5         6         7         8         9

C ... no conversion necessary since this subsequent logic expects this

cppppp
         print *, ' '
         print *, '==> Read in RECORD from tcvitals file -- contains a',
     $    ' 4-digit year "',BUFIN(20:23),'"'
         print *, ' '
         print'(" From unit ",I0,"; BUFIN-1: ",95A)', iovitl,bufin
         print *, ' '
         print *, '==> No conversion necessary'
         print *, ' '
cppppp

      else

         print *, ' '
         print *, '***** Cannot determine if this record contains ',
     $    'a 2-digit year or a 4-digit year - consider this a READ ',
     $    'ERROR'
         print *, ' '
         go to 990

      end if

      KREC=KREC+1

      WRITE(6,413) (BUFIN(NCH),NCH=1,MAXCHR)
  413 FORMAT(5X,95A1)
      GO TO 410

  420 WRITE(6,421) KREC,MAXCHR
  421 FORMAT(/'...',I5,' RECORDS READ OF',I4,' CHARACTER LENGTH.',///)
      RETURN

  990 WRITE(6,991) BUFIN
  991 FORMAT('******ERROR READING STORM RECORD.  BUFIN IS:',/,
     1       ' ******',A95,'******')
      NERROR=NERROR+1
      IF(NERROR .LE. IRDERM)  GO TO 100
      IERVIT=990
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    DECVAR      DECODES VARIALES
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: 1991-06-06
C
C ABSTRACT: DECODES VARIABLES FROM THE TROPICAL CYCLONE VITAL
C   STATISTICS FILE.  FILE SHOULD BE CHARACTER BASED.
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD
C
C USAGE:    CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C   INPUT ARGUMENT LIST:
C     INARG1   - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C     INARG2   - TYPE.  EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     WRKARG   - GENERIC DESCRIPTION, ETC., AS ABOVE.
C     OUTARG1  - EXPLAIN COMPLETELY IF ERROR RETURN
C     ERRFLAG  - EVEN IF MANY LINES ARE NEEDED
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     DDNAME1  - GENERIC NAME & CONTENT
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     DDNAME2  - GENERIC NAME & CONTENT AS ABOVE
C     FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE DECVAR(ISTART,IEND,IVALUE,IERDEC,FMT,BUFF)

      PARAMETER (NCHLIN=130)

      CHARACTER FMT*(*),BUFF*(*),OUTLIN*1

      SAVE

      DIMENSION OUTLIN(NCHLIN)

c && 2 comments
CC    WRITE(6,1) FMT,BUFF
CC  1 FORMAT(/'...FMT=',A10,/,' ...BUFF=',A100)

      READ(BUFF(ISTART:IEND),FMT,ERR=10)  IVALUE
      IERDEC=0
      RETURN

   10 CONTINUE

      OUTLIN=' '

      IERDEC=10
      OUTLIN(ISTART:IEND)='*'

      WRITE(6,31) (OUTLIN(ICH1),ICH1=1,NCHLIN)
      WRITE(6,32) BUFF
   31 FORMAT(/'******ERROR DECODING, BUFF=',/,130A1)
   32 FORMAT(A130)

      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    GRABVO      HANDLES VORTEX TYPES FOR BOGUSING
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: 1991-06-06
C
C ABSTRACT: UTILITY ROUTINE TO CONTROL EXTRACTION OF VARIABLES
C   FROM A ROUTINE THAT PRODUCES A BOGUS VORTEX.
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD
C
C USAGE:    CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C   INPUT ARGUMENT LIST:
C     INARG1   - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C     INARG2   - TYPE.  EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     WRKARG   - GENERIC DESCRIPTION, ETC., AS ABOVE.
C     OUTARG1  - EXPLAIN COMPLETELY IF ERROR RETURN
C     ERRFLAG  - EVEN IF MANY LINES ARE NEEDED
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     DDNAME1  - GENERIC NAME & CONTENT
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     DDNAME2  - GENERIC NAME & CONTENT AS ABOVE
C     FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$

C  *****************************
C  ****  SUBROUTINE GRABVO  ****
C  ****     ENTRY GRABIV    ****
C  ****     ENTRY GRABIP    ****
C  ****     ENTRY PROVOR    ****
C  *****************************

      SUBROUTINE GRABVO(IUNTFV,IUNTTK,IUNTDO,IPREQ,IVREQ,KLVLS,JVARS,
     2                  ILVLVO,INDPVO,IVARVO,INDVVO,FSTBOG,IVOTYP,
     3                  IVFLTP,PT,KLBOGZ,JVBOGZ,ONLYWI,ONLYMA,ONLYPS)

      PARAMETER(MAXBGK=10)
      PARAMETER(MAXBGV= 7)

      COMMON /DSK/MSKEF,MSKEZ,MSKDA1,MSKDA2,MSKDA3,MSKDA4,MSKDA5,MSKDA6,
     1            MSKDA7,MSKDA8,MSKDA9,MSKD11,MSKD12,MSKD13,MSKD14,
     2            MSKD15,MSKD16,MSKD17,MSKD18

      LOGICAL ONLYWI,ONLYMA,ONLYPS,FSTBOG

      SAVE

      DIMENSION IPREQ(KLVLS),ILVL(MAXBGK),INDXP(MAXBGK),IVREQ(JVARS),
     1          IVAR(MAXBGV),INDXV(MAXBGV),IPREQZ(MAXBGK),IVREQZ(MAXBGV)

      DIMENSION ILVLS(MAXBGK),INDXPS(MAXBGK),IVARS(MAXBGV),
     1          INDXVS(MAXBGV)

      DIMENSION ILVLVO(MAXBGK),INDPVO(MAXBGK),IVARVO(MAXBGV),
     1          INDVVO(MAXBGV)

C  CURRENT VORTEX AND FILE TYPES ARE:

C  VORTEX TYPE:

C       IVOTYP= 1: NON-DIVERGENT, AXISYMMETRIC

C       IVOTYP= 2: DIVERGENT, AXISYMMETRIC

C    FILE TYPES:

C       IVFLTP= 1: MATHUR POSTPROCESSED 3-D U, V, Z FILE
C                  == SEE SLVVO1 FOR SETUP INFORMATION ON VERTICAL
C                     LEVELS
C                  == SEE SVRVO1 FOR SETUP INFORMATION ON VARIABLES

C       IVFLTP= 2: MATHUR 2-D VORTEX
C                  == SEE SLVVO2 FOR SETUP INFORMATION ON VERTICAL
C                     LEVELS
C                  == SEE SVRVO2 FOR SETUP INFORMATION ON VARIABLES

C       IVFLTP= 3: SHAPIRO 2-D ANGULAR MOMENTUM VORTEX
C                  (ITERATIVE, CREATES RADIAL AND TANGENTIAL WIND)
C                  == SEE SLVVO3 FOR SETUP INFORMATION ON VERTICAL
C                     LEVELS
C                  == SEE SVRVO3 FOR SETUP INFORMATION ON VARIABLES

C-----------------------------------------------------------------------

C  ++++++++++++++++++++++++
C  ++++  ENTRY GRABIV  ++++
C  ++++++++++++++++++++++++

      ENTRY GRABIV(IVOTYP,IVFLTP,IPREQ,KLVLS,IVREQ,JVARS,PT)

C  AS IN THE ENVIRONMENTAL MODEL (GRABIM), FOR PHYSICAL REASONS AS WELL
C    AS COMPUTATIONAL EFFICIENCY, WE CONSIDER ONLY A SINGLE LEVEL ABOVE
C    THE LEVEL OF THE DEEPEST CYCLONIC CIRCULATION (PT)

      WRITE(6,1) IVOTYP,IVFLTP,KLVLS,JVARS,PT
    1 FORMAT(/'...ENTERING GRABIV WITH IVOTYP,IVFLTP,KLVLS,JVARS,PT=',
     1       4I5,F10.2)
      WRITE(6,3) (IPREQ(NP),NP=1,KLVLS)
    3 FORMAT(/'...IPREQ=',/,(5X,10I5))
      WRITE(6,5) (IVREQ(NP),NP=1,JVARS)
    5 FORMAT(/'...IVREQ=',/,(5X,10I5))
      DO 10 KL=1,KLVLS
      NPREQ=KL
      IF(NINT(PT*10.) .GE. IPREQ(KL)*10)  GO TO 11
   10 CONTINUE
   11 CONTINUE

      IF(NPREQ .NE. KLVLS)  THEN
      WRITE(6,13) NPREQ,IPREQ(NPREQ),KLVLS,IPREQ(KLVLS)
   13 FORMAT(/'...IN GRABIV, REQUESTED LEVELS HAVE BEEN TRUNCATED TO ',
     1       'CONFORM TO HEIGHT OF THE DEEPEST CYCLONIC CIRCULATION.',/,
     2       4X,'TRUNCATED, REQUESTED INDEX, PRESSURE LEVEL ARE',4I5)
      ENDIF

C  STORE REQUESTED PRESSURE LEVELS AND VARIABLES LOCALLY.  THEN PERFORM
C    SOME BASIC CHECKS FOR SUFFICIENT SPACE, LEVELS THEN VARIABLES

C  STORE LEVELS TO BE BOGUSSED HERE

      NP=0
      DO 15 NZ=1,NPREQ
      NP=NP+1
      IPREQZ(NP)=IPREQ(NZ)
   15 CONTINUE

      KLMAX=NP
      IF(KLVLS .LT. KLMAX)   THEN
      WRITE(6,17) KLVLS,KLMAX
   17 FORMAT(/'******INSUFFICIENT STORAGE ALLOCATED FOR STORING ',
     1       'VERTICAL LEVELS IN GRABEN.',/,10X,'KLVLS=',I5,' WHILE ',
     2       'AVAILABLE SPACE=KLMAX=',I5,/,10X,' THE NUMBER OF ',
     3       'LEVELS WILL BE REDUCED ACCORDINGLY')
      KLMAX=KLVLS
      ENDIF

C  STORE VARIABLES TO BE BOGUSSED HERE

      NV=0
      DO 20 NZ=1,JVARS
      NV=NV+1
      IVREQZ(NV)=IVREQ(NZ)
   20 CONTINUE

      JVMAX=NV
      IF(JVARS .LT. JVMAX)  THEN
      WRITE(6,31) JVMAX,MAXBGV
   31 FORMAT(/'******INSUFFICIENT STORAGE ALLOCATED FOR STORING ',
     1       'VARIABLES IN GRABEN.',/,10X,'JVMAX=',I5,' WHILE ',
     2       'AVAILABLE SPACE=MAXBGV=',I5,/,10X,' THEREFORE, ',
     3       'WE MUST TERMINATE THE PROGRAM')
      CALL ABRT1(' GRABIV',31)
      ENDIF

      IF(IVOTYP .EQ. 1)  THEN
        IF(IVFLTP .EQ. 1)  THEN
          CALL SLVVO1(KLMAX,IPREQZ,ILVL,INDXP,KLBOGA)
          CALL SVRVO1(JVMAX,IVREQZ,IVAR,INDXV,JVBOGA)
        ELSE IF(IVFLTP .EQ. 2)  THEN
          CALL SLVVO2(KLMAX,IPREQZ,ILVL,INDXP,KLBOGA)
          CALL SVRVO2(JVMAX,IVREQZ,IVAR,INDXV,JVBOGA)
        ELSE IF(IVFLTP .EQ. 3)  THEN
          CALL SLVVO3(KLMAX,IPREQZ,ILVL,INDXP,KLBOGA)
          CALL SVRVO3(JVMAX,IVREQZ,IVAR,INDXV,JVBOGA)
        ENDIF

      ELSE IF(IVOTYP .EQ. 2)  THEN
        IF(IVFLTP .EQ. 3)  THEN
          CALL SLVVO3(KLMAX,IPREQZ,ILVL,INDXP,KLBOGA)
          CALL SVRVO3(JVMAX,IVREQZ,IVAR,INDXV,JVBOGA)
        ELSE
        WRITE(6,37)  IVFLTP,IVOTYP
   37 FORMAT(/'******ILLEGAL VORTEX FILE TYPE=',I3,' FOR VORTEX ',
     1         'TYPE=',I3)
        CALL ABRT1(' GRABIV',37)
        ENDIF
      ENDIF
      KLBOG=KLBOGA
      JVBOG=JVBOGA

      ILVLS (1:KLBOG)=ILVL(1:KLBOG)
      INDXPS(1:KLBOG)=INDXP(1:KLBOG)

      WRITE(6,43) (KP,IPREQZ(KP),KP=1,KLMAX)
   43 FORMAT(/'...REQUESTED PRESSURE LEVELS FOR THE VORTEX ARE:',/,
     1       (10X,2I5))
      WRITE(6,44) IVOTYP,IVFLTP,(KP,ILVL(KP),INDXP(KP),KP=1,KLBOG)
   44 FORMAT(/'...FOR VORTEX TYPE=',I3,' AND VORTEX FILE TYPE=',I4,',',
     1       /,4X,'ACTUAL PRESSURE LEVELS AND INDICES FOR THE VORTEX',
     2       ' ARE:',/,(10X,3I5))

      IVARS (1:JVBOG)=IVAR(1:JVBOG)
      INDXVS(1:JVBOG)=INDXV(1:JVBOG)

      WRITE(6,57) (JV,IVREQZ(JV),JV=1,JVMAX)
   57 FORMAT(/'...REQUESTED VARIABLES FOR THE VORTEX ARE:',/,
     1       (10X,2I5))
      WRITE(6,59) IVOTYP,IVFLTP,(JV,IVAR(JV),INDXV(JV),JV=1,JVBOG)
   59 FORMAT(/'...FOR VORTEX TYPE=',I3,' AND VORTEX FILE TYPE=',I4,',',
     1       /,4X,'ACTUAL VARIABLES AND INDICES FOR THE VORTEX ARE:',/,
     2       (10X,3I5))

      RETURN

C-----------------------------------------------------------------------


C  ++++++++++++++++++++++++
C  ++++  ENTRY GRABIP  ++++
C  ++++++++++++++++++++++++

      ENTRY GRABIP(ILVLVO,INDPVO,KLBOGZ,IVARVO,INDVVO,JVBOGZ,ONLYWI,
     1             ONLYMA,ONLYPS)

C  THIS ENTRY DIRECTS THE SELECTION OF COMPOSITED VARIABLES BY SURPRP
C    (PREPBUFR SCANNER FOR DATA AROUND THE STORM).
C    ****NOTE: THE CURRENT SETUP IS TO COMPOSITE SURFACE PRESSURE ALL
C              THE TIME, NEVER TO COMPOSITE HEIGHT, AND TO COMPOSITE
C              WINDS IF NEED BE ****

      ONLYPS=.TRUE.
      ONLYMA=.FALSE.
      KLBOGZ=KLBOG
      JVBOGZ=JVBOG
      DO 110 JV=1,JVBOG
      IF(IVREQZ(JV) .GE. 4 .AND. IVREQZ(JV) .LE. 7)  ONLYWI=.TRUE.
      IVARVO(JV)=IVARS(JV)
      INDVVO(JV)=INDXVS(JV)
  110 CONTINUE

      ILVLVO(1:KLBOG)=ILVLS(1:KLBOG)
      INDPVO(1:KLBOG)=INDXPS(1:KLBOG)

      RETURN

C-----------------------------------------------------------------------

C  ++++++++++++++++++++++++
C  ++++  ENTRY PROVOR  ++++
C  ++++++++++++++++++++++++

      ENTRY PROVOR(IUNTFV,IUNTTK,IUNTDO,FSTBOG)

C  SET UNIT NUMBERS FOR 2-D SPLINE ANALYSIS

      MSKDA9=IUNTFV
      MSKD18=IUNTDO
      MSKDA2=IUNTTK
CCCC  REWIND MSKD18

      IF(FSTBOG)  THEN
      CALL SPLDAT
      ELSE
      CALL SPLD1
      ENDIF

      WRITE(6,211) MSKD15,IUNTFV
  211 FORMAT(/'...REWINDING MSKD15=',I3,', IUNTFV=',I3,' IN PROVOR.')
      REWIND MSKD15
      REWIND IUNTFV

      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    SETUP       CONTROLS MODEL AND VORTEX SELECTION
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: 1991-06-06
C
C ABSTRACT: CONTROLS SELECTION OF MODEL AND VORTEX TYPE FOR
C   BOGUSING.  GUARANTEES THAT VARIABLES CHOSEN FOR MODEL AND
C   VORTEX ARE THE SAME.
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD
C
C USAGE:    CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C   INPUT ARGUMENT LIST:
C     INARG1   - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C     INARG2   - TYPE.  EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     WRKARG   - GENERIC DESCRIPTION, ETC., AS ABOVE.
C     OUTARG1  - EXPLAIN COMPLETELY IF ERROR RETURN
C     ERRFLAG  - EVEN IF MANY LINES ARE NEEDED
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     DDNAME1  - GENERIC NAME & CONTENT
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     DDNAME2  - GENERIC NAME & CONTENT AS ABOVE
C     FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$

C  *****************************
C  ****  SUBROUTINE SETUP   ****
C  *****************************

      SUBROUTINE SETUP(MODTYP,IMFLTP,IVOTYP,IVFLTP,IPREQ,IPREQZ,IPDUM,
     2                 NPREQ,IVREQ,IVREQZ,IVDUM,NVREQ)

      SAVE

      DIMENSION IPREQ(NPREQ),IPREQZ(NPREQ),IVREQ(NVREQ),IVREQZ(NVREQ),
     1          IPDUM(NPREQ),IVDUM(NVREQ)

      WRITE(6,3) MODTYP,IMFLTP,IVOTYP,IVFLTP,NPREQ,NVREQ,
     1           (IPREQ(KP),KP=1,NPREQ)
      WRITE(6,4) (IVREQ(JV),JV=1,NVREQ)
    3 FORMAT(/'...ENTERING SETUP WITH MODTYP,IMFLTP,IVOTYP,IVFLTP,',
     1       'NPREQ,NVREQ=',6I5,/,1X,'...REQUESTED LEVELS, IPREQ',
     2       ', ARE:',/,(5X,10I5))
    4 FORMAT(/'...REQUESTED VARIABLES, IVREQ ARE:',/,(5X,10I5))

      IPDUM=0
      IPREQZ=IPREQ

      IVDUM=0
      IVREQZ=IVREQ

      KLMAX=NPREQ
      JVMAX=NVREQ

C  CALL INDIVIDUAL SET UP ROUTINES FOR MODEL AND VORTEX ENVIRONMENT TO
C    MAKE SURE REQUESTED VARIABLES AND LEVELS EXIST.  LEVELS AND
C    VARIABLES SET TO NEGATIVE MEAN THEY ARE NOT PRESENT IN THE
C    RESPECTIVE FILES.

C  FIRST, THE MODEL:

      IF(MODTYP .EQ. 0 .OR. MODTYP .EQ. 1)  THEN

C  ARGUMENTS 3-5 IN SLVSP1,2 SVRSP1,2 SHOULD NOT BE USED HERE

        IF(IMFLTP .EQ. 1)  THEN
          CALL SLVSP1(KLMAX,IPREQZ,IPDUM,IPDUM,KLDUM)
          CALL SVRSP1(JVMAX,IVREQZ,IVDUM,IVDUM,JVDUM)
        ELSE IF(IMFLTP .EQ. 2)  THEN
          CALL SLVSP2(KLMAX,IPREQZ,IPDUM,IPDUM,KLDUM)
          CALL SVRSP2(JVMAX,IVREQZ,IVDUM,IVDUM,JVDUM)
        ENDIF

      ELSE IF(MODTYP .EQ. -1) THEN
        IF(IMFLTP .NE. -1)  THEN
        WRITE(6,31)  IMFLTP
   31   FORMAT(/'******IMFLTP=',I5,' FOR GRID POINT MODEL IS NOT ',
     1         'INSTALLED')
        CALL ABRT1(' SETUP ',31)
        ENDIF

      ELSE
      WRITE(6,33) MODTYP
   33 FORMAT(/'******MODTYP=',I5,' (UNKNOWN MODEL) IS NOT INSTALLED')
      CALL ABRT1(' SETUP ',33)
      ENDIF

C  WEED OUT ALL REQUESTED LEVELS AND VARIABLES THAT WERE NOT FOUND

      KK=0
      DO 40 KL=1,KLMAX
      IF(IPREQZ(KL) .GT. 0)  THEN
      KK=KK+1
      IPREQZ(KK)=IPREQZ(KL)
      ENDIF
   40 CONTINUE

      JJ=0
      DO 50 JV=1,JVMAX
      IF(IVREQZ(JV) .GT. 0)  THEN
      JJ=JJ+1
      IVREQZ(JJ)=IVREQZ(JV)
      ENDIF
   50 CONTINUE
      KLMAX=KK
      JVMAX=JJ
      WRITE(6,51) KLMAX,JVMAX
   51 FORMAT(/'...AFTER FIRST (ENV) WEEDING, KLMAX,JVMAX=',2I5)

C  SECOND, THE VORTEX:

      IF(IVOTYP .EQ. 1 .OR. IVOTYP .EQ. 2)  THEN

C  ARGUMENTS 3-5 IN SLVVO1(2), SVRVO1(2) SHOULD NOT BE USED HERE

        IF(IVFLTP .EQ. 1)  THEN
          CALL SLVVO1(KLMAX,IPREQZ,IPDUM,IPDUM,KLDUM)
          CALL SVRVO1(JVMAX,IVREQZ,IVDUM,IVDUM,JVDUM)
        ELSE IF(IVFLTP .EQ. 2)  THEN
          CALL SLVVO2(KLMAX,IPREQZ,IPDUM,IPDUM,KLDUM)
          CALL SVRVO2(JVMAX,IVREQZ,IVDUM,IVDUM,JVDUM)
        ELSE IF(IVFLTP .EQ. 3)  THEN
          CALL SLVVO3(KLMAX,IPREQZ,IPDUM,IPDUM,KLDUM)
          CALL SVRVO3(JVMAX,IVREQZ,IVDUM,IVDUM,JVDUM)
        ELSE
        WRITE(6,111) IVFLTP
  111   FORMAT(/'******IVFLTP=',I5,' IS NOT INSTALLED')
        CALL ABRT1(' SETUP',111)
        ENDIF

      ELSE IF(IVOTYP .EQ. -99) THEN
      WRITE(6,113) IVOTYP
  113 FORMAT(/'######IVOTYP=',I5,' VORTEX WILL NOT BE INCLUDED IN ',
     1       'SETUP.')
      ELSE
      WRITE(6,114) IVOTYP
  114 FORMAT(/'******IVOTYP=',I5,' (UNKNOWN VORTEX) IS NOT INSTALLED')
      CALL ABRT1(' SETUP',114)
      ENDIF

C  THE SECOND WEEDING (FOR THE VORTEX AND MODEL ENVIRONMENT COMBINED)

      KK=0
      DO 130 KL=1,KLMAX
      IF(IPREQZ(KL) .GT. 0)  THEN
      KK=KK+1
      IPREQZ(KK)=IPREQZ(KL)
      ENDIF
  130 CONTINUE

      JJ=0
      DO 140 JV=1,JVMAX
      IF(IVREQZ(JV) .GT. 0)  THEN
      JJ=JJ+1
      IVREQZ(JJ)=IVREQZ(JV)
      ENDIF
  140 CONTINUE
      NPREQ=KK
      NVREQ=JJ

      IPREQ=IPREQZ

      IVREQ=IVREQZ

      IF(NPREQ .NE. KLDUM)  THEN
      WRITE(6,171) NPREQ,KLDUM
  171 FORMAT(/'******A SERIOUS ERROR HAS OCCURRED, NPREQ AND KLDUM ',
     1       'ARE NOT EQUAL IN SETUP.',/,12X,'NPREQ, KLDUM=',2I5)
      ENDIF

      IF(NVREQ .NE. JVDUM)  THEN
      WRITE(6,173) NVREQ,JVDUM
  173 FORMAT(/'******A SERIOUS ERROR HAS OCCURRED, NVREQ AND JVDUM ',
     1       'ARE NOT EQUAL IN SETUP.',/,12X,'NVREQ, JVDUM=',2I5)
      CALL ABRT1(' SETUP ',173)
      ENDIF

      WRITE(6,181) (KP,IPREQ(KP),KP=1,NPREQ)
  181 FORMAT(/'...REQUESTED AND CHECKED PRESSURE LEVELS IN SETUP ARE:',
     1       /,(10X,2I5))

      WRITE(6,183) (JV,IVREQ(JV),JV=1,NVREQ)
  183 FORMAT(/'...REQUESTED AND CHECKED VARIABLES IN SETUP ARE:',/,
     1       (10X,2I5))

      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    SETVOR      PROCESSES VORTEX FILE STRUCTURE
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: 1991-06-06
C
C ABSTRACT: PROCESSES INFORMATION ABOUT VORTEX VARIABLES AND LEVELS
C   THAT WILL BE MADE BY VARIOUS TYPES OF VORTEX SUBROUTINES.
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD
C
C USAGE:    CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C   INPUT ARGUMENT LIST:
C     INARG1   - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C     INARG2   - TYPE.  EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     WRKARG   - GENERIC DESCRIPTION, ETC., AS ABOVE.
C     OUTARG1  - EXPLAIN COMPLETELY IF ERROR RETURN
C     ERRFLAG  - EVEN IF MANY LINES ARE NEEDED
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     DDNAME1  - GENERIC NAME & CONTENT
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     DDNAME2  - GENERIC NAME & CONTENT AS ABOVE
C     FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
C
C     *****************************
C     ****  SUBROUTINE SETVOR  ****
C     ****     ENTRY SLVVO1    ****
C     ****     ENTRY SVRVO1    ****
C     ****     ENTRY SLVVO2    ****
C     ****     ENTRY SVRVO2    ****
C     ****     ENTRY SLVVO3    ****
C     ****     ENTRY SVRVO3    ****
C     *****************************
C
      SUBROUTINE SETVOR(KLMAX,IPREQ,ILVL,INDXP,KLBOG,JVMAX,IVREQ,IVAR,
     1                  INDXV,JVBOG)
C
C**DEB  PARAMETER(KDIM=#PLEVS)  PL1 PARAMETERS ARE A POSSIBILITY HERE
      PARAMETER(KDIMV1=10)
      PARAMETER(JDIMV1= 4)
      PARAMETER(KDIMV2=12)
      PARAMETER(JDIMV2= 4)
      PARAMETER(KDIMV3=12)
      PARAMETER(JDIMV3= 5)
C
      SAVE
C
      DIMENSION IPREQ(KLMAX),ILVL(KLMAX),INDXP(KLMAX),IPFL1(KDIMV1),
     1          IVREQ(JVMAX),IVAR(JVMAX),INDXV(JVMAX),IVFL1(JDIMV1),
     2          IPFL2(KDIMV2),IVFL2(JDIMV2),IPFL3(KDIMV3),IVFL3(JDIMV3)
C
      LOGICAL FOUND
C
      DATA IPFL1/1000,850,700,500,400,300,250,200,150,100/
      DATA IVFL1/3,4,5,6/
      DATA IPFL2/1000,850,700,500,400,300,250,200,150,100.,70.,50./
      DATA IVFL2/3,4,5,6/
      DATA IPFL3/1000,850,700,500,400,300,250,200,150,100.,70.,50./
      DATA IVFL3/3,4,5,6,7/
C
C     THIS SET OF ENTRIES IN SUBROUTINE SETVOR CONTAINS VORTEX SPECIFIC
C       INFORMATION ABOUT THE FILE STRUCTURES.  CURRENT VORTEX
C       TYPES ARE:
C          IVFLTP=1: MATHUR 3-D POSTPROCESSED U,V,Z FILE
C          IVFLTP=2: MATHUR 2-D VORTEX
C          IVFLTP=3: SHAPIRO 2-D ANGULAR MOMENTUM VORTEX
C                    CREATES BOTH RADIAL AND TANGENTIAL WIND
C

C-----------------------------------------------------------------------

C
C     ++++++++++++++++++++++++
C     ++++  ENTRY SLVVO1  ++++
C     ++++++++++++++++++++++++
C
      ENTRY SLVVO1(KLMAX,IPREQ,ILVL,INDXP,KLBOG)
C
      KL=0
      DO 40 KP=1,KLMAX
      FOUND=.FALSE.
      DO 20 KLF=1,KDIMV1
      IF(IPREQ(KP) .EQ. IPFL1(KLF))   THEN
      FOUND=.TRUE.
      KL=KL+1
      ILVL(KL)=IPFL1(KLF)
      INDXP(KL)=KLF
      ENDIF
   20 CONTINUE
C
      IF(.NOT. FOUND)  THEN
      WRITE(6,21) IPREQ(KP)
   21 FORMAT('###### PRESSSURE LEVEL',I3,' NOT AVAILABLE IN ',
     1       'VORTEX FILE.')
      IPREQ(KP)=-IPREQ(KP)
      ENDIF
C
   40 CONTINUE
      KLBOG=KL
      RETURN

C-----------------------------------------------------------------------

C
C
C     ++++++++++++++++++++++++
C     ++++  ENTRY SVRVO1  ++++
C     ++++++++++++++++++++++++
C
      ENTRY SVRVO1(JVMAX,IVREQ,IVAR,INDXV,JVBOG)
C
      JV=0
      DO 140 JJ=1,JVMAX
      FOUND=.FALSE.
      DO 120 JLF=1,JDIMV1
      IF(IVREQ(JJ) .EQ. IVFL1(JLF))   THEN
      FOUND=.TRUE.
      JV=JV+1
      IVAR(JV)=IVFL1(JLF)
      INDXV(JV)=JLF
      ENDIF
  120 CONTINUE
C
      IF(.NOT. FOUND)  THEN
      WRITE(6,121) IVREQ(JJ)
  121 FORMAT('###### VARIABLE',I3,' NOT AVAILABLE IN VORTEX FILE.')
      IVREQ(JJ)=-IVREQ(JJ)
      ENDIF
C
  140 CONTINUE
      JVBOG=JV
      RETURN

C-----------------------------------------------------------------------

C
C     ++++++++++++++++++++++++
C     ++++  ENTRY SLVVO2  ++++
C     ++++++++++++++++++++++++
C
      ENTRY SLVVO2(KLMAX,IPREQ,ILVL,INDXP,KLBOG)
C
      KL=0
      DO 240 KP=1,KLMAX
      FOUND=.FALSE.
      DO 220 KLF=1,KDIMV2
      IF(IPREQ(KP) .EQ. IPFL2(KLF))   THEN
      FOUND=.TRUE.
      KL=KL+1
      ILVL(KL)=IPFL2(KLF)
      INDXP(KL)=KLF
      ENDIF
  220 CONTINUE
C
      IF(.NOT. FOUND)  THEN
      WRITE(6,221) IPREQ(KP)
  221 FORMAT('###### PRESSSURE LEVEL',I3,' NOT AVAILABLE IN ',
     1       'VORTEX FILE.')
      IPREQ(KP)=-IPREQ(KP)
      ENDIF
C
  240 CONTINUE
      KLBOG=KL
      RETURN

C-----------------------------------------------------------------------

C
C     ++++++++++++++++++++++++
C     ++++  ENTRY SVRVO2  ++++
C     ++++++++++++++++++++++++
C
      ENTRY SVRVO2(JVMAX,IVREQ,IVAR,INDXV,JVBOG)
C
      JV=0
      DO 340 JJ=1,JVMAX
      FOUND=.FALSE.
      DO 320 JLF=1,JDIMV2
      IF(IVREQ(JJ) .EQ. IVFL2(JLF))   THEN
      FOUND=.TRUE.
      JV=JV+1
      IVAR(JV)=IVFL2(JLF)
      INDXV(JV)=JLF
      ENDIF
  320 CONTINUE
C
      IF(.NOT. FOUND)  THEN
      WRITE(6,321) IVREQ(JJ)
  321 FORMAT('###### VARIABLE',I3,' NOT AVAILABLE IN VORTEX FILE.')
      IVREQ(JJ)=-IVREQ(JJ)
      ENDIF
C
  340 CONTINUE
      JVBOG=JV
      RETURN

C-----------------------------------------------------------------------

C
C     ++++++++++++++++++++++++
C     ++++  ENTRY SLVVO3  ++++
C     ++++++++++++++++++++++++
C
      ENTRY SLVVO3(KLMAX,IPREQ,ILVL,INDXP,KLBOG)
C
      KL=0
      DO 440 KP=1,KLMAX
      FOUND=.FALSE.
      DO 420 KLF=1,KDIMV3
      IF(IPREQ(KP) .EQ. IPFL3(KLF))   THEN
      FOUND=.TRUE.
      KL=KL+1
      ILVL(KL)=IPFL3(KLF)
      INDXP(KL)=KLF
      ENDIF
  420 CONTINUE
C
      IF(.NOT. FOUND)  THEN
      WRITE(6,421) IPREQ(KP)
  421 FORMAT('###### PRESSSURE LEVEL',I3,' NOT AVAILABLE IN ',
     1       'VORTEX FILE.')
      IPREQ(KP)=-IPREQ(KP)
      ENDIF
C
  440 CONTINUE
      KLBOG=KL
      RETURN

C-----------------------------------------------------------------------

C
C     ++++++++++++++++++++++++
C     ++++  ENTRY SVRVO3  ++++
C     ++++++++++++++++++++++++
C
      ENTRY SVRVO3(JVMAX,IVREQ,IVAR,INDXV,JVBOG)
C
      JV=0
      DO 540 JJ=1,JVMAX
      FOUND=.FALSE.
      DO 520 JLF=1,JDIMV3
      IF(IVREQ(JJ) .EQ. IVFL3(JLF))   THEN
      FOUND=.TRUE.
      JV=JV+1
      IVAR(JV)=IVFL3(JLF)
      INDXV(JV)=JLF
      ENDIF
  520 CONTINUE
C
      IF(.NOT. FOUND)  THEN
      WRITE(6,521) IVREQ(JJ)
  521 FORMAT('###### VARIABLE',I3,' NOT AVAILABLE IN VORTEX FILE.')
      IVREQ(JJ)=-IVREQ(JJ)
      ENDIF
C
  540 CONTINUE
      JVBOG=JV
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    MM3DVO      MUKUT MATHUR POSTPROCESSED VORTEX READER
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: 1991-06-06
C
C ABSTRACT: READS THE FILE FORMAT FOR MUKUT MATHUR'S 3-D VORTEX
C   WHICH IS USED FOR BOGUSING IN THE QLM.
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD
C
C USAGE:    CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C   INPUT ARGUMENT LIST:
C     INARG1   - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C     INARG2   - TYPE.  EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     WRKARG   - GENERIC DESCRIPTION, ETC., AS ABOVE.
C     OUTARG1  - EXPLAIN COMPLETELY IF ERROR RETURN
C     ERRFLAG  - EVEN IF MANY LINES ARE NEEDED
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     DDNAME1  - GENERIC NAME & CONTENT
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     DDNAME2  - GENERIC NAME & CONTENT AS ABOVE
C     FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
C
C     *****************************
C     ****  SUBROUTINE MM3DVO  ****
C     *****************************
C
      SUBROUTINE MM3DVO(IPRNTV,IUNTRV,IUNTPV,IUNTTK,IUNTDO,IUNTBH,IPRES,
     1                  INDXP,KLVLS,IVAR,JVBOG,RMXBOG,DELTA,STMLTZ,
     2                  STMLNZ,RLATMN,RLATMX,RLONMN,RLONMX,IDAYZ,IUTCZ,
     3                  STMNMZ)
C
      PARAMETER(IDIM=11,JDIM=11,KMDIM=1,JVMDIM=3)
      PARAMETER(ITRKMX=3)
C
      COMMON/VARS/ RMVARS(IDIM,JDIM,KMDIM,JVMDIM)
C
      LOGICAL BOGVAR
C
      SAVE
C
      CHARACTER FLAG*4,STMNMZ*9
C
      DIMENSION UP(IDIM,JDIM,KMDIM),VP(IDIM,JDIM,KMDIM),
     1          ZP(IDIM,JDIM,KMDIM),RLAT(IDIM,JDIM),RLON(IDIM,JDIM),
     2          IPRES(KLVLS),INDXP(KLVLS),IVAR(JVBOG),BOGVAR(JVMDIM),
     3          IDAYZZ(ITRKMX),IUTCZZ(ITRKMX),STLTZZ(ITRKMX),
     4          STLNZZ(ITRKMX)
C
      EQUIVALENCE (RMVARS(1,1,1,1),ZP(1,1,1)),(RMVARS(1,1,1,2),
     1             UP(1,1,1)),(RMVARS(1,1,1,3),VP(1,1,1))
C
      DATA  EPSVP/0.1/,DEGFAC/57.29578/,RMISS/-99.0/,FLAG/'0000'/
C
C     SET UP VARIABLES TO BE BOGUSSED.  THE EXPECTED RANGE OF
C       IVAR IS:
C                   3  : HEIGHT
C                   4,5: TOTAL WIND=TANGENTIAL WIND FOR THIS
C                          AXISYMMETRIC VORTEX
C                   6  : ROTATIONAL WIND=TOTAL WIND FOR THIS VORTEX
C
      DO 1 JV=1,JVBOG
      IF(IVAR(JV) .LE. JVMDIM+2)  THEN
      BOGVAR(IVAR(JV)-2)=.TRUE.
      ELSE IF(IVAR(JV) .EQ. 6)  THEN
      BOGVAR(2)=.TRUE.
      BOGVAR(3)=.TRUE.
      ENDIF
    1 CONTINUE
C
C     MAKE SURE DIMENSIONS ARE SET CORRECTLY
C
      IF(IDIM .NE. 111 .OR. JDIM .NE. 111)  THEN
      WRITE(6,3) IDIM,JDIM
    3 FORMAT(/'******DIMENSIONS IN MM3DVO NOT SET CORRECTLY. ',
     1       'IDIM,JDIM=',2I4)
      CALL ABRT1(' MM3DVO',3)
      ENDIF
C
      NREC=0
      NLEV=0
      ITYP=12
C
C     ASSUME MUKUT MATHUR'S MODEL HAS GRID SPACING OF 40 KM.
C        WE SAMPLE THE MODEL'S DATA OUT TO SOME MULTIPLE OF RMAX
C        (RMXBOG), AND RMAX IS THE RADIUS OF THE OUTERMOST CLOSED
C        ISOBAR AND COMES FROM THE VITAL STATISTICS FILE.
C        OUTSIDE RMAX, THE WINDS ARE ZERO AND THE HEIGHT DEVIATIONS
C        ARE ZERO.
C
      DELXMM=40.
      DELYMM=40.
C
      print *, ' '
      print *, ' '
      WRITE(6,6)
      WRITE(6,6)
      WRITE(6,7)
      WRITE(6,8) STMNMZ,IDAYZ,IUTCZ,STMLTZ,STMLNZ,RMXBOG,RLATMN,
     1           RLATMX,RLONMN,RLONMX
      WRITE(6,7)
      WRITE(6,6)
      WRITE(6,6)
      WRITE(IUNTBH,6)
      WRITE(IUNTBH,6)
      WRITE(IUNTBH,7)
      WRITE(IUNTBH,8) STMNMZ,IDAYZ,IUTCZ,STMLTZ,STMLNZ,RMXBOG,RLATMN,
     1                RLATMX,RLONMN,RLONMX
      WRITE(IUNTBH,7)
      WRITE(IUNTBH,6)
      WRITE(IUNTBH,6)
    6 FORMAT(20X,'**********************************************')
    7 FORMAT(20X,'****                                      ****')
    8 FORMAT(20X,'****  MATHUR 3-D VORTEX FROM PPUVZF FILE  ****',/
     1       20X,'****',8X,'STORM:',A13,11X,'****',/
     2       20X,'****',4X,'DATE:',I9,' TIME:',I5,9X,'****',/
     3       20X,'****',5X,'LAT:',F8.2,'  LON:',F8.2,7X,'****',/
     4       20X,'****',5X,'RMXBOG:',F8.1,18X,'****',/
     5       20X,'****',5X,'YNB:',F8.2,'  YNT:',F8.2,7X,'****',/
     6       20X,'****',5X,'XML:',F8.2,'  XMR:',F8.2,7X,'****')
C
      IRAD=IFIX(RMXBOG/DELXMM)
      JRAD=IFIX(RMXBOG/DELYMM)
      WRITE(6,16) IRAD,JRAD
   16 FORMAT(/'...APPROXIMATE INDICES OF RADIAL EXTENT ARE: IRAD,JRAD=',
     1       2I5)
C
C     OPEN FILES
C
      OPEN(UNIT=IUNTRV,ACCESS='SEQUENTIAL',
     1     STATUS='OLD',FORM='UNFORMATTED')
CIBM 1     STATUS='OLD',ACTION='READ',FORM='UNFORMATTED')
      OPEN(UNIT=IUNTPV,ACCESS='SEQUENTIAL',
     1     STATUS='OLD',FORM='UNFORMATTED')
C
      READ(IUNTRV) RLAT
      READ(IUNTRV) RLON
      READ(IUNTRV) UP
      READ(IUNTRV) VP
      READ(IUNTRV) ZP
C
      DO 30 J=1,JDIM
      DO 20 I=1,IDIM
      RLAT(I,J)=RLAT(I,J)*DEGFAC
      RLON(I,J)=RLON(I,J)*DEGFAC
   20 CONTINUE
   30 CONTINUE
C
      ICEN=56
      JCEN=56
C
      WRITE(6,31) ICEN,JCEN
   31 FORMAT(/'...ICEN,JCEN=',2I5//)
      WRITE(6,32) (J,J=1,IDIM)
      WRITE(6,33) (RLAT(ICEN,J),J=1,JDIM)
      print *, ' '
      print *, ' '
      WRITE(6,34) (I,I=1,JDIM)
      WRITE(6,33) (RLON(I,JCEN),I=1,IDIM)
   32 FORMAT(/'...CENTER LATITUDES  (ICEN,J) ARE:',/,(13X,10I11))
   34 FORMAT(/'...CENTER LONGITUDES (I,JCEN) ARE:',/,(13X,10I11))
   33 FORMAT(12X,10F11.2)
C
C     CHECK THAT THE INPUT LAT/LON POSITION OF THE STORM COINCIDES
C       WITH THE LAT/LON OF THE VORTEX CENTER AT ICEN,JCEN=56,56
C
      RLATCZ=RLAT(ICEN,JCEN)
      RLONCZ=360.-RLON(ICEN,JCEN)
C
      IF(NINT(ABS(STMLTZ-RLAT(ICEN,JCEN))*100.).GT.NINT(EPSVP*100.) .OR.
     1   NINT(ABS(STMLNZ-RLONCZ)*100.)         .GT.NINT(EPSVP*100.))THEN
      WRITE(6,43) STMLTZ,STMLNZ,RLATCZ,RLONCZ
   43 FORMAT(/'******A SEVERE ERROR HAS OCCURRED IN MM3DVO, VORTEX ',
     1       'POSITION AND CENTER OF 3-D VORTEX DO NOT AGREE.',/,7X,
     2       'STMLAT,STMLON,RLAT(ICEN,JCEN),RLON(ICEN,JCEN)=',4F12.4)
      CALL ABRT1(' MM3DVO',43)
      ENDIF
C
      IMIN=ICEN-IRAD-1
      IMAX=ICEN+IRAD
      JMIN=JCEN-JRAD-1
      JMAX=JCEN+JRAD
      IMAX2=(IMIN+IMAX)/2
      JMAX2=(JMIN+JMAX)/2
C
   51 XML=RLON(IMIN,JMAX2)
      IF(NINT(XML*100.) .LT. NINT((360.-RLONMN)*100.))  THEN
      IMIN=MAX(1,IMIN-1)
      WRITE(6,511) XML,RLONMN,IMIN
  511 FORMAT('...REVISING ESTIMATE FOR IMIN: XML, RLONMN, NEW IMIN=',
     1       2F12.4,I5)
      GO TO 51
      ENDIF
C
   52 XMR=RLON(IMAX,JMAX2)
      IF(NINT(XMR*100.) .GT. NINT((360.-RLONMX)*100.))  THEN
      IMAX=MIN(IDIM,IMAX+1)
      WRITE(6,512) XMR,RLONMX,IMAX
  512 FORMAT('...REVISING ESTIMATE FOR IMAX: XMR, RLONMX, NEW IMAX=',
     1       2F12.4,I5)
      GO TO 52
      ENDIF
C
   53 YNB=RLAT(IMAX2,JMIN)
      IF(NINT(YNB*100.) .GT. NINT(RLATMN*100.))  THEN
      JMIN=MAX(1,JMIN-1)
      WRITE(6,513) YNB,RLATMN,JMIN
  513 FORMAT('...REVISING ESTIMATE FOR JMIN: YNB, RLATMN, NEW JMIN=',
     1       2F12.4,I5)
      GO TO 53
      ENDIF
C
   54 YNT=RLAT(IMAX2,JMAX)
      IF(NINT(YNT*100.) .LT. NINT(RLATMX*100.))  THEN
      JMAX=MIN(JDIM,JMAX+1)
      WRITE(6,514) YNT,RLATMX,JMAX
  514 FORMAT('...REVISING ESTIMATE FOR JMAX: YNT, RLATMX, NEW JMAX=',
     1       2F12.4,I5)
      GO TO 54
      ENDIF
C
C     CONVERT LONGITUDES TO DEGREES WEST FOR MATHUR'S PROGRAMS AND
C       THE 2-D SPLINE ANALYSIS FILTER
C
      XMLZ=360.-RLONMN
      XMRZ=360.-RLONMX
      YNBZ=RLATMN
      YNTZ=RLATMX
C
      WRITE(6,57) IDIM,JDIM,IMIN,IMAX,JMIN,JMAX,IMAX2,JMAX2
   57 FORMAT(/'...TOTAL ARRAY SIZE (IDIM,JDIM)=(',I4,',',I4,')',/,
     1       ' ...SAMPLED ARRAY IS (IMIN,IMAX,JMIN,JMAX)=(',I4,',',
     2       I4,',',I4,',',I4,')',/,' ...MIDDLE LON,LAT INDICES ARE',
     3       '(',I4,',',I4,')')
      WRITE(6,59) XMLZ,XMRZ,YNBZ,YNTZ
   59 FORMAT('...CORNER LONGITUDES, LATITUDES ARE:',4F8.2)
C
C     SET VARIABLES THAT WILL NOT BE BOGUSSED TO MISSING
C
      DO 70 JV=1,JVMDIM
C
      IF(.NOT. BOGVAR(JV))  THEN
      WRITE(6,61)  JV
   61 FORMAT('######VARIABLE INDEX',I3,' IS SET TO MISSING.')

      RMVARS(:,:,:,JV)=RMISS
      ENDIF
C
   70 CONTINUE
C
      RITYP=REAL(ITYP)
      UTC0=REAL(IUTCZ)
      KK=1
      DO 100 KL=1,KMDIM
      IF(KL .EQ. INDXP(KK))  THEN
        NLEV=NLEV+1
        IF(NLEV .EQ. 1)  THEN
        WRITE(6,81) KL,IPRES(KK),(J,J=1,IDIM)
        WRITE(6,82) (UP(ICEN,J,KL),J=1,JDIM)
        WRITE(6,83) KL,IPRES(KK),(I,I=1,JDIM)
        WRITE(6,82) (VP(I,JCEN,KL),I=1,IDIM)
        WRITE(6,84) KL,IPRES(KK),(I,I=1,JDIM)
        WRITE(6,82) (ZP(I,JCEN,KL),I=1,IDIM)
   81   FORMAT(//'...CENTER ZONAL WINDS (ICEN,J) FOR INDEX,PRES=',
     1         2I5,' ARE:',/,(13X,10I11))
   83   FORMAT(//'...CENTER MERIDIONAL WINDS (ICEN,J) FOR INDEX,PRES=',
     1         2I5,' ARE:',/,(13X,10I11))
   84   FORMAT(//'...CENTER HEIGHT DEVIATIONS (ICEN,J) FOR INDEX,PRES=',
     1         2I5,' ARE:',/,(13X,10I11))
   82   FORMAT(12X,10F11.2)
        print *, ' '
        print *, ' '
        ENDIF
C
        PP=REAL(IPRES(KK))
        DO J=JMIN,JMAX
        DO I=IMIN,IMAX
        RLATZ=RLAT(I,J)
        RLONZ=RLON(I,J)
        IF(IPRNTV .GT. 0)  THEN
        IF(IPRNTV .EQ. 2 .OR. NREC .LE. 1000)  THEN
        WRITE(6,87) ITYP,IDAYZ,IUTCZ,RLATZ,RLONZ,PP,RMISS,RMISS,
     1              ZP(I,J,KL),UP(I,J,KL),VP(I,J,KL),FLAG
   87   FORMAT(1X,I2,1X,I9,1X,I4,1X,2(F7.3,1X),3(F6.1,1X),F7.1,
     1       2(F6.1,1X),A4)
        ENDIF
        ENDIF
        NREC=NREC+1
        WRITE(IUNTPV) RITYP,IDAYZ,IUTCZ,RLATZ,RLONZ,PP,RMISS,RMISS,
     1                ZP(I,J,KL),UP(I,J,KL),VP(I,J,KL),FLAG
        ENDDO
        ENDDO
C
        KK=KK+1
        IF(KK .GT. KLVLS)  GO TO 101
C
      ENDIF
  100 CONTINUE
  101 CONTINUE
      NPTS=NREC/NLEV
      IVOTYP=1
      IVFLTP=1
      WRITE(6,103) NREC,NPTS,NLEV,IVOTYP,IVFLTP
  103 FORMAT('...MM3DVO HAS WRITTEN',I7,' RECORDS AT',I6,
     1       ' POINTS AND',I3,' LEVELS FOR IVOTYP, IVFLTP=',2I3)
C
C     WRITE NAMELIST UPDATE FILES FOR XSPLDAT ANALYSIS AND STORM
C       TRACK FILES.
C       ****NOTE: WE USE A DUMMY TRACK FOR SIMPLICITY HERE ****
C
      ITRK=3

      IDAYZZ(1:ITRK)=IDAYZ
      IUTCZZ(1:ITRK)=IUTCZ
      STLTZZ(1:ITRK)=STMLTZ
      STLNZZ(1:ITRK)=STMLNZ
C
      CALL RITTRK(ITRK,IUNTTK,IDAYZZ,IUTCZZ,STLTZZ,STLNZZ,STMNMZ)
C
      ITRK=1
      CALL RITDOM(ITRK,IUNTDO,IDAYZZ,IUTCZZ,XMLZ,XMRZ,YNBZ,YNTZ,DELTA,
     1            STMNMZ)
C
C     CLOSE OR REWIND FILES
C
      REWIND IUNTDO
      REWIND IUNTTK
      CLOSE(UNIT=IUNTRV ,STATUS='KEEP')
      CLOSE(UNIT=IUNTPV,STATUS='KEEP')
C
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    MAKVOR      CONTROLS BOGUS VORTEX CONSTRUCTION
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: 2016-05-18
C
C ABSTRACT: CONTROLS BOGUS VORTEX CONSTRUCTION.  COMPOSITES
C   OBSERVATIONS FOR COMPARISON WITH BOGUS VORTEX.
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD
C 1991-10-21  S. J. LORD  MADE DELMMV INPUT ARGUMENT
C 2016-05-18  S. J. LORD  Defined dayoff=0.0 (was previously
C        unititialized).  This is passed into subr. SETTRK.
C
C USAGE:    CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C   INPUT ARGUMENT LIST:
C     INARG1   - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C     INARG2   - TYPE.  EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     WRKARG   - GENERIC DESCRIPTION, ETC., AS ABOVE.
C     OUTARG1  - EXPLAIN COMPLETELY IF ERROR RETURN
C     ERRFLAG  - EVEN IF MANY LINES ARE NEEDED
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     DDNAME1  - GENERIC NAME & CONTENT
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     DDNAME2  - GENERIC NAME & CONTENT AS ABOVE
C     FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
C
C     *****************************
C     ****  SUBROUTINE MAKVOR  ****
C     *****************************
C
      SUBROUTINE MAKVOR(IDATEZ,IUTCZ,IUNTPN,IUNTPV,IUNTTK,IUNTDO,IUNTRV,
     1                  IUNTBH,IUNTDH,IUNTVD,IOVITL,IVOTYP,IVFLTP,
     2                  IBMETH,DELTA,DELMMV,SP1DWL,RLATMN,RLATMX,
     3                  RLONMN,RLONMX,STMLTZ,STMLNZ,STMDRZ,STMSPZ,RMAXZ,
     4                  PENVZ,PCENZ,PTOPZ,DIVFAC,PCENF,R15WND,
     5                  VTBOGZ,NOBWMN,VORDIV,STMIDZ,STMNMZ,ihrreq)
C
      PARAMETER (MAXDAT=5)
      PARAMETER (KDTDIM=5)
      PARAMETER (MAXVPT=100,MAXPTS=MAXVPT*MAXVPT)
      PARAMETER (MAXVOP=12)
      PARAMETER (MAXVOV= 3)
      PARAMETER (MAXVOW= 7)
      PARAMETER (MAXVOR=1000)
      PARAMETER (ITRKMX=3)
      PARAMETER (IQUADX=4)
C
      CHARACTER FLAG*4,STMIDZ*3,STMNMZ*9,STMNZZ*9
      LOGICAL FIRST,VORDIV,ONLYWI,ONLYMA,ONLYPS
C
      SAVE
C
      REAL(8) SINDEG_8,COSDEG_8,DISTSP_8,term_8

      DIMENSION  JDAT(8),RINC(5)

      DIMENSION COMDTA(MAXDAT),NDATA(MAXDAT),INDCOM(MAXDAT)
      DIMENSION RLATP(MAXPTS),RLONP(MAXPTS),DATA(KDTDIM),RADIUS(MAXPTS),
     1          SINTH(MAXPTS),COSTH(MAXPTS)
      DIMENSION A2DVOR(MAXVOR,MAXVOP,MAXVOV),IBOGVR(MAXVOV)
      DIMENSION ILVL(MAXVOP),INDXP(MAXVOP),IVAR(MAXVOW),INDXV(MAXVOW),
     1          IDAYZZ(ITRKMX),IUTCZZ(ITRKMX),STLTZZ(ITRKMX),
     2          STLNZZ(ITRKMX)
      DIMENSION ILVLZ(MAXVOP),INDXPZ(MAXVOP),R15WND(IQUADX)
C
      COMMON/BDATE/LDAT(8)

      EQUIVALENCE (NDATA(1),NUDAT),(NDATA(2),NVDAT),
     1            (NDATA(3),NPSDAT)
C
C     COMFAC: FACTOR FOR DETERMINING THE COMPOSITING RADIUS AS A
C             MULTIPLE OF RMAX
C     DELMMV: SPACING OF MATHUR 2-D VORTEX (KM)
C     DEGLAT: ONE DEGREE LATITUDE IN METERS
C     RMISS : SPLINE ANALYSIS CODE FOR MISSING DATA
C     ITYP  : SPLINE ANALYSIS DATA TYPE
C     IFIRST: =0, CODE FOR CALLING RFAC TO RETAIN PREVIOUS
C             INTERPOLATION FACTORS
C     SP1DWL : FILTER WAVELENGTH FOR THE 1-D SPLINE FILTERS
C              FOR THE SURFACE PRESSURE, VORTICITY AND DIVERGENCE
C              (SEE AS2DVO)
C
      DATA IPRT/1/,IPRTV/0/,IHRD/0/,NDATA/MAXDAT*0/,FIRST/.TRUE./,
     1     COMFAC/2.0/,DEGLAT/111.1775E3/,RMISS/-99.0/,EPSMIS/1.E-2/,
     2     ITYP/12/,FLAG/'0000'/,IBOGVR/MAXVOV*-1/,IFIRST/0/,DELSP/20./,
     3     DELVD/2./
C
      DATA R15MPS/15.0/,R15INF/20./,SPDMIN/5.0/
C
      IOPT=5
      STMNZZ=STMIDZ
      WRITE(6,1) STMNMZ//STMIDZ,VORDIV,IUNTVD,IVOTYP,IVFLTP,IBMETH,
     1           STMLTZ,STMLNZ,RMAXZ,PENVZ,PCENZ,PTOPZ,VTBOGZ
    1 FORMAT(///'...ENTERING MAKVOR FOR STORM ',A,', WITH VORDIV,',
     1       'IUNTVD,IVOTYP,IVFLTP,IBMETH,STMLAT,STMLON,RMAX,PENV,',
     2       'PCEN,PTOP,VTBOGZ=',/,5X,L1,4I5,7F12.3)
      WRITE(IUNTDH,3) IDATEZ,IUTCZ,STMNMZ//STMIDZ,STMLTZ,STMLNZ,RMAXZ,
     1                PENVZ,PCENZ,STMDRZ,STMSPZ,VTBOGZ,IBMETH
    3 FORMAT(' COMPOSITED OBS:',I10,I5,1X,A,8F10.2,I3)
C
C     SET UP COMPOSITING VARIABLES AND DO SOME BASIC SPACE CHECKS
C
      IF(FIRST)  THEN
         FIRST=.FALSE.
         CALL GRABIP(ILVL,INDXP,KLBOG,IVAR,INDXV,JVBOG,
     1               ONLYWI,ONLYMA,ONLYPS)
         WRITE(6,4) ONLYWI,ONLYMA,ONLYPS,KLBOG,JVBOG
    4    FORMAT(/'...SETTING UP COMPOSITING: ONLYWI,ONLYMA,ONLYPS=',3L2,
     1          ' KLBOG,JVBOG=',2I5)
C
C     SET UP VARIABLES TO BE BOGUSED.  THE EXPECTED RANGE OF
C       IVAR IS:
C                   3  : HEIGHT
C                   4,5: TOTAL WIND
C                   6  : ROTATIONAL WIND
C                   7  : DIVERGENT  WIND
C
         DO 6 JV=1,JVBOG
            IF(IVAR(JV) .LE. MAXVOV+2)  THEN
cdak??      IF(IVAR(JV) .LE. MAXVOW+2)  THEN
               IBOGVR(IVAR(JV)-2)=1
            ELSE IF(IVAR(JV) .EQ. 6)  THEN
               IBOGVR(2)=1
               IBOGVR(3)=0
            ELSE IF(IVAR(JV) .EQ. 7)  THEN
               IBOGVR(2)=0
               IBOGVR(3)=1
            ENDIF
    6    CONTINUE
C
         IF(KLBOG .GT. MAXVOP)  THEN
            WRITE(6,11) IVOTYP,IVFLTP,KLBOG,MAXVOP
   11 FORMAT(/'******INSUFFICIENT SPACE FOR VERTICAL LEVELS OF ',
     1       'AXISYMMETRIC VORTEX, IVOTYP,IVFLTP,KLBOG,MAXVOP=',4I5)
            CALL ABRT1(' MAKVOR',11)
         ENDIF
C
         IF(JVBOG .GT. MAXVOV)  THEN
cdak??   IF(JVBOG .GT. MAXVOW)  THEN
            WRITE(6,21) IVOTYP,IVFLTP,JVBOG,MAXVOV
   21 FORMAT(/'******INSUFFICIENT SPACE FOR VORTEX VARIABLES OF ',
     1       'AXISYMMETRIC VORTEX, IVOTYP,IVFLTP,JVBOG,MAXVOV=',4I5)
            CALL ABRT1(' MAKVOR',21)
         ENDIF
C
         NTODAT=0
         IF(ONLYWI)  THEN
            NUDAT=1
            NVDAT=1
            INDCOM(1)=1
            INDCOM(2)=2
         ENDIF
C
         IF(ONLYPS)  THEN
            NPSDAT=1
            INDCOM(3)=3
         ENDIF
C
         DO 40 MDAT=1,MAXDAT
            NTODAT=NTODAT+NDATA(MDAT)
   40    CONTINUE
C
         DATA=RMISS
C
         RITYP=REAL(ITYP)
C
      ENDIF
C
      CALL ZTIME(IDATEZ,IUTCZ,IYR,IMO,IDA,IHR,IMIN)
      JDAT = 0
      JDAT(1) = IYR
      JDAT(2) = IMO
      JDAT(3) = IDA
      CALL W3DIFDAT(JDAT,LDAT,1,RINC)
      JDY = NINT(RINC(1))
      CALL FLDAY(JDY,IHR,IMIN,DAY00)
C
C     ASSUME A SIX HOUR WINDOW FOR FINDING THE TRACK
C
      WINDOW=0.25
      DAYMX0=DAY00+WINDOW
      DAYMN0=DAY00-WINDOW
C SJL 4/13/16
      dayoff=0.0
C
C     DETERMINE THE VORTEX SIZE: SEE COMMENTS BELOW
C
      IF(IBMETH .LE. 2)  THEN
C
      CALL R15FND(R15WND,STMDRZ,RMAXZ,R15AVG)
C
      IF(R15AVG .LE. RMAXZ)  THEN
      RPOT=R15AVG
      WRITE(6,61) IBMETH,RPOT
   61 FORMAT(/'...FOR IBMETH=',I3,' RPOT=',F7.2,' IS EQUAL TO R15AVG.')
C
      ELSE
      RPOT=RMAXZ
      WRITE(6,63) IBMETH,RPOT,R15AVG
   63 FORMAT(/'...FOR IBMETH=',I3,' RPOT=',F7.2,' IS EQUAL TO RMAXZ,'/,
     1       4X,' WHILE R15AVG=',F7.2)
C
      ENDIF
C
      ELSE
      RPOT=RMAXZ
      ENDIF
C
C     SET THE DOMAIN FOR SCANNING DATA AND COMPOSITING
C
      ISHAPE=1
      ZLAT=ZNEAR(STMLTZ,DELTA)
      ZLON=ZNEAR(STMLNZ,DELTA)
      RMXCOM=MIN(COMFAC*RMAXZ,RFAC(IFIRST,RMAXZ))
      CALL TEMPLT(ISHAPE,DELTA,ZLAT,ZLON,RMXCOM,MAXPTS,MMX,NNY,YNB,YNT,
     1            XML,XMR,RLATP,RLONP,NPTS)
C
C
C     SET UP TRACK AND COMPOSITING ROUTINES. PTOP IS THE UPPERMOST
C       PRESSURE LEVEL TO BE COMPOSITED. RMXCOM IS THE LARGEST
C       RADIAL EXTENT OF THE COMPOSITE (HALF THE DIAGONAL DISTANCE
C       ACROSS THE BOX FOR THE BOGUSING AREA)
C
      RMXCOM=0.5*DISTSP_8(YNT,XML,YNB,XMR)
      CALL SETTRK(IOVITL,IOPT,IDATEZ,DAY00,DAYMN0,DAYMX0,DAYOFF,STMDRZ,
     1            STMSPZ,STMNZZ,IERSET,ihrreq)
      CALL SETCOM(NTODAT,IUNTDH,STMDRZ,STMSPZ,PTOPZ,RMXCOM,RMAXZ,RPOT,
     1            ONLYWI,ONLYPS,STMNMZ//STMIDZ)
C
      WRITE(6,971)
  971 FORMAT(/110('V')/110('V'))
      WRITE(6,71)  NTODAT,(INDCOM(NTO),NTO=1,NTODAT)
   71 FORMAT(/'...CALLING SURPRP WITH NTODAT,INDCOM=',10I4)
      CALL SURPRP(IUNTPN,IUNTBH,IUNTDH,PTOPZ,XML,XMR,YNB,YNT,RPOT,
     1            SPDPOT,NOBWMN,IYR,DAY00,NTODAT,COMDTA,IPRT,IHRD,
     2            INDCOM,ONLYWI,ONLYMA,ONLYPS)
      WRITE(6,73) RPOT,NOBWMN,SPDPOT
      WRITE(IUNTBH,73) RPOT,NOBWMN,SPDPOT
   73 FORMAT(/'...FOR RPOT,NOBWMN=',F7.2,I3,' SURPRP HAS FOUND ',
     1       'SPDPOT=',F7.2)
      WRITE(6,972)
  972 FORMAT(/110('A')/110('A')/)
C
      REWIND IUNTPN
C
      RMXMMV=RMAXZ
C
C     SET UP THE BOGUS VORTEX PARAMETERS DEPENDING ON BOGUS METHOD
C       IBMETH=1,2: PERTURBATION VORTEX CALIBRATED TO 15 M/S WIND RADIUS
C                   OR RMAX (WHICHEVER IS SMALLER)
C                   AND EQUAL TO THE STORM SPEED (STEERING FLOW) AT
C                   RMAX
C       IBMETH=3,4: VORTEX CALIBRATED TO AVERAGE TANGENTIAL WIND IN
C                   THE GUESS FIELD
C
      IF(IBMETH .LE. 2)  THEN
C
C     WE TRY TO MATCH THE PERTURBATION VORTEX TO THE STEERING FLOW
C       AT RMAX.
C
      IF(SPDPOT .LE. 0.0)  THEN
      SPDPOT=MAX(STMSPZ+SPDMIN,R15MPS-STMSPZ)
      IF(VORDIV)  SPDPOT=R15MPS
      ENDIF
C
      UPOT=-SPDPOT*SINDEG_8(R15INF)
      VPOT= SPDPOT*COSDEG_8(R15INF)
      VTBOG=MIN(STMSPZ,R15MPS*0.5)
C
C     METHOD=3,4:
C       VORTEX TO MATCH AZIMUTHALLY-AVERAGED TANGENTIAL WIND AT RMAX
C         RMAX (VTBOGZ)
C
      ELSE
      SPDPOT=-99.0
      VPOT=VTBOGZ
      UPOT=-VPOT*SINDEG_8(R15INF)
      ENDIF
C
      WRITE(6,91)  IBMETH,RPOT,UPOT,VPOT,R15INF,VTBOGZ,STMSPZ,SPDPOT
      WRITE(IUNTBH,91)  IBMETH,RPOT,UPOT,VPOT,R15INF,VTBOGZ,
     1                  STMSPZ,SPDPOT
   91 FORMAT(/'...INPUT PARM FOR MAKVOR: IBMETH,RPOT,UPOT,VPOT,',
     1       'R15INF,VTBOGZ,STMSPZ,SPDPOT=',/,4X,I3,7F9.1)
C
C     RADIAL GRID FOR CALCULATING VORTEX PROPERTIES
C
      IF(VORDIV)  THEN
      DELXVO=DELVD
      ELSE
      DELXVO=DELMMV
      DLMMVM=DELMMV*1000.
      ENDIF
C
C     ***************************
C     ****  MAKE THE VORTEX  ****
C     ***************************
C
C     FIRST, FIND PRESSURE INDEX FOR THE TOP OF THE CYCLONIC
C       CIRCULATION
C
      DO 200 KL=1,KLBOG
      IF(ILVL(KL)*10 .LT. NINT(PTOPZ*10.))  GO TO 201
      KLBOGV=KL
      INDXPZ(KL)=INDXP(KL)
      ILVLZ (KL)=ILVL (KL)
  200 CONTINUE
  201 CONTINUE
C
      IF(IVOTYP .LE. 2) THEN
         IF(IVFLTP .EQ. 1)  THEN
C
C     AN INTERACTIVE VORTEX IS NOT ALLOWED FOR MM3DVO (VORTEX ON DISK).
C       BUT WE MUST CALL RDTITL TO PRESERVE THE CORRECT SEQUENCE OF
C       DATA READ FROM UNIT 5.
C
            CALL RDTITL(1)
            RMXBOG=RFAC(IFIRST,RMAXZ)
            WRITE(6,203) STMNMZ//STMIDZ,STMLTZ,STMLNZ,PTOPZ,RMXBOG,
     1                  IDATEZ,IUTCZ,RLATMN,RLATMX,RLONMN,RLONMX
  203 FORMAT(/'...CALLING MM3DVO WITH STMNAM,STMLAT,STMLON,PTOP,',
     1        'RMXBOG,IDATEZ,IUTCZ,RLATMN,RLATMX,RLONMN,RLONMX=',/,
     2        10X,A,4F12.3,I9,I5,4F12.4)
C
            IUNTRV=IUNTRV+1
            CALL MM3DVO(IPRTV,IUNTRV,IUNTPV,IUNTTK,IUNTDO,IUNTBH,ILVLZ,
     1                  INDXPZ,KLBOGV,IVAR,JVBOG,RMXBOG,DELTA,STMLTZ,
     2                  STMLNZ,RLATMN,RLATMX,RLONMN,RLONMX,IDATEZ,IUTCZ,
     3                  STMNMZ//STMIDZ)
            RETURN
C
         ELSE IF(IVFLTP .EQ. 2)  THEN
            CALL MM2DVO(IUNTBH,DELXVO,SP1DWL,STMLTZ,STMLNZ,RMXMMV,PCENZ,
     1                  PENVZ,PTOPZ,PCENF,A2DVOR,MAXVOR,MAXVOP,MAXVOV,
     2                  KLEVMX,IRADMX,IDATEZ,IUTCZ,STMNMZ//STMIDZ)
C
         ELSE IF(IVFLTP .EQ. 3)  THEN
C
C     TANGENTIAL AND RADIAL WIND ARE SPECIFIED AT THE RADIUS OF
C       OBSERVED 15 M/S WINDS.
C
            CALL AS2DVO(IUNTBH,IUNTVD,IVOTYP,DELXVO,DELSP,SP1DWL,STMLTZ,
     1                  STMLNZ,RMXMMV,PCENZ,PENVZ,PTOPZ,VPOT,UPOT,RPOT,
     2                  VTBOG,DIVFAC,PCENF,A2DVOR,MAXVOR,MAXVOP,MAXVOV,
     3                  KLEVMX,IRADMX,IDATEZ,IUTCZ,IERASV,VORDIV,
     4                  STMNMZ//STMIDZ)
            IF(IERASV .NE. 0)  THEN
               IF(VORDIV)  THEN
                  WRITE(6,211) VORDIV,IERASV
  211 FORMAT(/'******WITH VORDIV=',L1,' ERROR IN SHAPIRO VORTEX=',I3,
     1       ' HAS OCCURRED.  THEREFORE WE MUST CURRENTLY TERMINATE ',
     2  /,7X,'THIS PROGRAM UNTIL VORTICITY/DIVERGENCE OPTION ',
     3       'IS INCLUDED FOR MM2DVO')
                  CALL ABRT1(' MAKVOR',211)
C
               ELSE
                  CALL MM2DVO(IUNTBH,DELMMV,SP1DWL,STMLTZ,STMLNZ,
     1                        RMXMMV,PCENZ,PENVZ,PTOPZ,PCENF,A2DVOR,
     2                        MAXVOR,MAXVOP,MAXVOV,KLEVMX,IRADMX,
     3                        IDATEZ,IUTCZ,STMNMZ//STMIDZ)
               ENDIF
            ENDIF
         ENDIF
      ELSE
         WRITE(6,213) IVOTYP
  213    FORMAT(/'******VORTEX TYPE=',I3,' NOT YET INSTALLED')
         CALL ABRT1(' MAKVOR',69)
      ENDIF
C
C     DO 230 NVAR=1,MAXVOV
C     WRITE(6,217) NVAR
C 217 FORMAT(///'...NVAR=',I5)
C     DO 220 NRAD=1,IRADMX
C     WRITE(6,218) NRAD
C 218 FORMAT(///'...NRAD=',I5)
C     WRITE(6,219) (A2DVOR(NRAD,NPR,NVAR),NPR=1,KLEVMX)
C 219 FORMAT(1X,12F10.2)
C 220 CONTINUE
C 230 CONTINUE
C
      CALL ANLVOR(ONLYWI,ONLYPS)
C
      CALL FITOBS(IUNTBH,RMAXZ,PCENZ,PENVZ,ONLYWI,ONLYPS,STMLTZ,STMLNZ,
     1            IDATEZ,IUTCZ,STMNMZ//STMIDZ)
C
C     FOR VORTICITY/DIVERGENCE OPTION, WE ARE FINISHED
C
      IF(VORDIV)  RETURN
C
C     CONTINUE FOR WIND BOGUSING OPTION
C
C     NOW THAT THE VORTEX IS FINAL, INTERPOLATE THE VORTEX TO
C       A TEMPLATE OF EQUALLY SPACED (LAT/LON) POINTS THAT COVER
C       THE BOGUSING AREA.  THE SPACING IS APPROXIMATELY AT
C       THE LAT/LON INTERVAL CORRESPONDING TO THE DISTANCE DELMMV
C       CALCULATED AT THE STORM LATITUDE.
C       **** IMPORTANT NOTE: LONGITUDES ARE CONVERTED TO
C                            DEGREES WEST IN THIS INSTANCE ****
C
      ISHAPE=2
      DELXVO=DLMMVM/(DEGLAT*COSDEG_8(STMLTZ))
      ZLAT=ZNEAR(STMLTZ,DELTA)
      ZLON=ZNEAR(STMLNZ,DELTA)
      R1=DISTSP_8(RLATMX,RLONMN,ZLAT,RLONMN)
      R2=DISTSP_8(RLATMN,RLONMN,ZLAT,RLONMN)
      R3=DISTSP_8(ZLAT  ,  ZLON,ZLAT,RLONMX)
      R4=DISTSP_8(ZLAT  ,  ZLON,ZLAT,RLONMN)
      RMXVOR=1.E-3*MAX(R1,R2,R3,R4)
      CALL TEMPLT(ISHAPE,DELXVO,ZLAT,ZLON,RMXVOR,MAXPTS,MXZ,NYZ,YNBZ,
     1            YNTZ,XMLZ,XMRZ,RLATP,RLONP,NPTS)
      YNB=RLATMN
      YNT=RLATMX
      XML=360.-RLONMN
      XMR=360.-RLONMX
C
      NREC=0
      UTC0=REAL(IUTCZ)
C
C     OPEN FILE FOR 2-D SPLINE FORMAT DATA
C
C
C     OPENING IUNTPV NOT PERFORMED ON THE CRAY
C
C     OPEN(UNIT=IUNTPV,ACCESS='SEQUENTIAL',
C    1     STATUS='OLD',FORM='UNFORMATTED')
C
      WRITE(6,301)  (IVAR(JV),JV=1,JVBOG)
  301 FORMAT(////,1X,'...PREPARING TO CREATE DATA FROM ',
     1       '2-D VORTEX IVAR=',10I4)
      WRITE(6,303) YNB,YNT,XML,XMR,YNBZ,YNTZ,360.-XMLZ,360.-XMRZ
  303 FORMAT('...CORNERS OF BOGUSING AREA (DEG. W) ARE:',4F10.2,/,4X,
     1       'WHILE CORNERS POINTS OF VORTEX DATA ARE:',F8.2,3F10.2)
C
      DO 350 JV=1,MAXVOV
C
      IF(IBOGVR(JV) .GT. 0)  GO TO 350
C
      IF(IBOGVR(JV) .LT. 0)  THEN
      RVALUE=RMISS
      WRITE(6,311) JV
  311 FORMAT(/'...BOGUS VARIABLE',I3,' FROM 2-D VORTEX WILL BE ',
     1       'MADE MISSING')
C
      ELSE IF(IBOGVR(JV) .EQ. 0)  THEN
      RVALUE=0.0
      WRITE(6,321) JV
  321 FORMAT(/'...BOGUS VARIABLE',I3,' FROM 2-D VORTEX WILL BE ',
     1       'MADE IDENTICALLY ZERO')
      ENDIF
C
      A2DVOR(1:IRADMX,1:KLEVMX,JV)=RVALUE

  350 CONTINUE
C
      DO 420 NP=1,NPTS
      THETA=ATAN2DEG(RLONP(NP)-STMLNZ,RLATP(NP)-STMLTZ)
C     RADIUS(NP)=DISTSP_8(RLATP(NP),RLONP(NP),STMLTZ,STMLNZ)

cdak  fix 7/03/05 VVVVVVVVVV
ccc   RADIUS(NP)=ACOS(COSDEG_8(RLONP(NP)-STMLNZ)*COSDEG_8(RLATP(NP))*
ccc  1           COSDEG_8(STMLTZ)+SINDEG_8(RLATP(NP))*SINDEG_8(STMLTZ))*
ccc  2           6.37E6
      term_8=cosdeg_8(rlonp(np)-stmlnz)*cosdeg_8(rlatp(np))*
     1       cosdeg_8(stmltz)+sindeg_8(rlatp(np))*sindeg_8(stmltz)
      term_8=min(term_8,1.0_8)  ! since double precision, term inside
                                ! ACOS below can exceed 1.0 (just a bit)
                                ! causing an undefined value for radius
                                ! -- this makes sure term is never
                                !    greater than 1.0
      RADIUS(NP)=ACOS(term_8)*6.37E6
cdak  fix 7/03/05 ^^^^^^^^^^

      SINTH(NP)=SINDEG_8(THETA)
      COSTH(NP)=COSDEG_8(THETA)
  420 CONTINUE
C
      DO 440 NP=1,NPTS
C
      IRAD=1+RADIUS(NP)/DLMMVM
      DRAD=RADIUS(NP)-REAL(IRAD-1)*DLMMVM
C
c && 5 comments
CC    WRITE(6,423) NP,RLONP(NP),RLATP(NP),STMLTZ,STMLNZ,THETA,RADIUS(NP)
CC423 FORMAT('...NP,RLONP,RLATP,STMLTZ,STMLNZ,THETA,RADIUS=',/,5X,I5,
CC   1       5F10.2,F12.2)
CC    WRITE(6,424) SINTH(NP),COSTH(NP),RADIUS(NP),DRAD
CC424 FORMAT('...SINTH,COSTH,RADIUS,DRAD=',2F8.4,2F12.2)
C
C     **** IMPORTANT NOTE:  LONGITUDE FOR 2-D SPLINE FILE
C                           IS IN DEGREES WEST ****
C
      RLATZ=RLATP(NP)
      RLONZ=360.-RLONP(NP)
C
      DO 430 KL=1,KLBOG
      PP=REAL(ILVL(KL))
c && 6 comments
CC    WRITE(6,427) KL,NP,INDXP(KL),IRAD,A2DVOR(IRAD,INDXP(KL),1),
CC   1             A2DVOR(IRAD+1,INDXP(KL),1),A2DVOR(IRAD,INDXP(KL),2),
CC   2             A2DVOR(IRAD+1,INDXP(KL),2),A2DVOR(IRAD,INDXP(KL),3),
CC   3             A2DVOR(IRAD+1,INDXP(KL),3)
CC427 FORMAT('...INTERPOLATING, KL,NP,INDXP,IRAD,HEIGHT(IRAD,IRAD+1),',
CC   1       'VTAN(IRAD,IRAD+1),VRAD(IRAD,IRAD+1)=',/,5X,4I5,6F10.2)
C
      HEIGHT=A2DVOR(IRAD,INDXP(KL),1)+DRAD*(A2DVOR(IRAD+1,INDXP(KL),1)-
     1       A2DVOR(IRAD,INDXP(KL),1))/DLMMVM
      VTAN  =A2DVOR(IRAD,INDXP(KL),2)+DRAD*(A2DVOR(IRAD+1,INDXP(KL),2)-
     1       A2DVOR(IRAD,INDXP(KL),2))/DLMMVM
      VRAD  =A2DVOR(IRAD,INDXP(KL),3)+DRAD*(A2DVOR(IRAD+1,INDXP(KL),3)-
     1       A2DVOR(IRAD,INDXP(KL),3))/DLMMVM
C
C     MAKE MISSING HEIGHTS AND WINDS IF NECESSARY
C
      IF(ABS(HEIGHT-RMISS) .LT. EPSMIS)  HEIGHT=RMISS
      IF(ABS(VTAN-RMISS) .LT. EPSMIS .AND. ABS(VRAD-RMISS) .LT. EPSMIS)
     1  THEN
      UWIND=RMISS
      VWIND=RMISS
      ELSE
      UWIND=VRAD*SINTH(NP)-VTAN*COSTH(NP)
      VWIND=VRAD*COSTH(NP)+VTAN*SINTH(NP)
      ENDIF
C
      NREC=NREC+1
c && 3 comments
CC    IF(NREC .LE. 1000*KLBOG .AND. KL .EQ. 1)
CC   1   WRITE(6,428) HEIGHT,VTAN,VRAD,UWIND,VWIND
CC428 FORMAT('...HEIGHT,VTAN,VRAD,UWIND,VWIND=',5F11.4)
      DATA(3)=HEIGHT
      DATA(4)=UWIND
      DATA(5)=VWIND
C
C     PRINT OUT THE BOTTOM LEVEL FOR THE FIRST 1000 POINTS
C
c && 5 comments
CC    IF(NREC .LE. 1000*KLBOG .AND. KL .EQ. 1)
CC   1  WRITE(6,429) ITYP,IDATEZ,IUTCZ,RLATZ,RLONZ,PP,
CC   2               (DATA(KD),KD=1,KDTDIM),FLAG
CC429 FORMAT(1X,I2,1X,I9,1X,I4,1X,2(F7.3,1X),3(F6.1,1X),F7.1,
CC   1       2(F6.1,1X),A4)
      WRITE(IUNTPV) RITYP,IDATEZ,IUTCZ,RLATZ,RLONZ,PP,
     1              (DATA(KD),KD=1,KDTDIM),FLAG
  430 CONTINUE
C
  440 CONTINUE
      NPTS=NREC/KLBOG
      WRITE(6,441) NREC,NPTS,KLBOG,IVOTYP,IVFLTP
  441 FORMAT('...MAKVOR HAS WRITTEN',I7,' RECORDS AT',I6,
     1       ' POINTS AND',I3,' LEVELS FOR IVOTYP, IVFLTP=',2I3)
C
C     WRITE NAMELIST UPDATE FILES FOR XSPLDAT ANALYSIS AND STORM
C       TRACK FILES.
C       ****NOTE: WE USE A DUMMY TRACK FOR SIMPLICITY HERE ****
C
      ITRK=3

      IDAYZZ(1:ITRK)=IDATEZ
      IUTCZZ(1:ITRK)=IUTCZ
      STLTZZ(1:ITRK)=STMLTZ
      STLNZZ(1:ITRK)=STMLNZ
C
      CALL RITTRK(ITRK,IUNTTK,IDAYZZ,IUTCZZ,STLTZZ,STLNZZ,
     1            STMNMZ//STMIDZ)
C
      ITRK=1
      CALL RITDOM(ITRK,IUNTDO,IDAYZZ,IUTCZZ,XML,XMR,YNB,YNT,DELTA,
     1            STMNMZ//STMIDZ)
C
C     CLOSE OR REWIND FILES
C
C     REWIND IUNTTK
C     REWIND IUNTDO
C     REWIND IUNTPV
      CLOSE(UNIT=IUNTTK,STATUS='KEEP')
      CLOSE(UNIT=IUNTDO,STATUS='KEEP')
      CLOSE(UNIT=IUNTPV,STATUS='KEEP')
C
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    R15FND      CALCULATES AVERAGE RADIUS OF 15 M/S WINDS
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: 1991-06-06
C
C ABSTRACT: CALCULATES AVERAGE RADIUS OF 15 M/S WINDS
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD
C
C USAGE:    CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C   INPUT ARGUMENT LIST:
C     INARG1   - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C     INARG2   - TYPE.  EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     WRKARG   - GENERIC DESCRIPTION, ETC., AS ABOVE.
C     OUTARG1  - EXPLAIN COMPLETELY IF ERROR RETURN
C     ERRFLAG  - EVEN IF MANY LINES ARE NEEDED
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     DDNAME1  - GENERIC NAME & CONTENT
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     DDNAME2  - GENERIC NAME & CONTENT AS ABOVE
C     FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
C
      SUBROUTINE R15FND(R15WND,STMDRZ,RMAXZ,R15AVG)
C
      PARAMETER (IQUADX=4)
C
      SAVE
      LOGICAL FIRST
C
      DIMENSION R15WND(IQUADX),ANGR15(IQUADX)
C
      DATA FIRST/.TRUE./,ANGR15/45.,135.,225.,315./,R15FAC/0.667/
C
      IF(FIRST)  THEN
      FIRST=.FALSE.
      ASECTR=360./REAL(IQUADX)
      ENDIF
C
C     DETERMINE THE RADIUS OF 15 M/S WINDS IN THE FRONT AND REAR
C       RIGHT QUADRANTS RELATIVE TO THE STORM MOTION
C
      NQAVG=0
      R15AVG=0.0
      DO 10 IQ=1,IQUADX
      IF(R15WND(IQ) .GT. 0.0)  THEN
      IQUADZ=IFIX(MOD(360.-STMDRZ+ANGR15(IQ),360.)/ASECTR)+1
c && 3 comments
CC    WRITE(6,9) IQ,R15WND(IQ),STMDRZ,ANGR15(IQ),ASECTR,IQUADZ
CC  9 FORMAT('...IQ,R15WND(IQ),STMDRZ,ANGR15(IQ),ASECTR,IQUADZ=',I3,
CC   1       4F8.1,I4)
      IF(IQUADZ .EQ. 1 .OR. IQUADZ .EQ. 2)  THEN
      NQAVG=NQAVG+1
      R15AVG=R15AVG+R15WND(IQ)
      ENDIF
      ENDIF
   10 CONTINUE
C
      IF(NQAVG .GT. 0)  THEN
      R15AVG=R15AVG/REAL(NQAVG)
C
      ELSE
C
      R15AVG= R15FAC*RMAXZ
      WRITE(6,11)  R15FAC,RMAXZ,(R15WND(IQ),IQ=1,IQUADX)
   11 FORMAT(/'...RADII OF 15 M/S WINDS ARE MISSING. AN EMPIRICAL ',
     1       'FACTOR OF',F7.3,' WILL BE APPLIED TO RMAX=',F7.1,'.',/,4X,
     2       'R15WND=',4F7.1)
      ENDIF
C
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    OVRLAP      OVERLAP BETWEEN TROPICAL CYCLONE CIRCS.
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: 1992-10-01
C
C ABSTRACT: DETERMINES WHETHER OR NOT AN OVERLAP EXISTS BETWEEN
C   MULTIPLE TROPICAL CYCONE CIRCULATIONS.
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD
C 1992-10-01  S. J. LORD FIXED BUG CAUSING FAILURE IN OVERLAP CHECK
C
C USAGE:    CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C   INPUT ARGUMENT LIST:
C     INARG1   - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C     INARG2   - TYPE.  EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     WRKARG   - GENERIC DESCRIPTION, ETC., AS ABOVE.
C     OUTARG1  - EXPLAIN COMPLETELY IF ERROR RETURN
C     ERRFLAG  - EVEN IF MANY LINES ARE NEEDED
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     DDNAME1  - GENERIC NAME & CONTENT
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     DDNAME2  - GENERIC NAME & CONTENT AS ABOVE
C     FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE OVRLAP(IUNTSL,IUNTBH,KSTORM,MAXPTS,ISHAPE,DELTA,STMLTO,
     2                  STMLNO,RMXBOG,RMAX,RLATP,RLONP,IFST,OVRFLG)
C
      PARAMETER (MAXSTM=70)
      PARAMETER (LATG2=190,LONF=384)
C
      LOGICAL OVRFLG
C
      SAVE

      REAL(8)  DISTSP_8
C
      DIMENSION RLAT(LATG2),RLON(LONF),SLMASK(LONF,LATG2)
C
      DIMENSION STMLTO(KSTORM),STMLNO(KSTORM),RMXBOG(KSTORM),
     1          RMAX(KSTORM),RLATP(MAXPTS),RLONP(MAXPTS),IFST(KSTORM),
     2          OVRFLG(KSTORM)
C
      DIMENSION RLATMN(MAXSTM),RLATMX(MAXSTM),RLONMN(MAXSTM),
     1          RLONMX(MAXSTM)
C
C     BUFZON:  WIDTH BETWEEN TWO RECTANGULAR BOGUSING REGIONS
C              (DEG. LAT.)
C     EPSLL:   TOLERANCE FOR TESTING QUADRANT (DEG. LAT.)
C
      DATA BUFZON/1.0/,EPSLL/1.E-2/,DEGLAT/111.1775/
C
      OVRFLG=.FALSE.
C
      IF(KSTORM .GT. MAXSTM)  THEN
      WRITE(6,11)  KSTORM,MAXSTM
   11 FORMAT(/'******INSUFFICIENT SPACE ALLOCATED FOR OVERLAP CHECK.',
     1       ' KSTORM, MAXSTM=',2I5,/,7X,'THIS CHECK WILL NOT BE ',
     2       'PERFORMED!!!')
      RETURN
      ENDIF
C
      DLON=360./REAL(LONF)
      DO 20 ILON=1,LONF
      RLON(ILON)=REAL(ILON-1)*DLON
   20 CONTINUE
C
      JDIM=LATG2
      CALL GAULAT(RLAT,JDIM)
      DO 30 JLAT=1,JDIM
      RLAT(JLAT)=90.-RLAT(JLAT)
   30 CONTINUE
C
c && 4 comments
CC    WRITE(6,31) (RLON(ILON),ILON=1,LONF)
CC 31 FORMAT(//'...IN OVRLAP, LONGITUDES ARE:',/,(3X,10F10.3))
CC    WRITE(6,33) (RLAT(ILAT),ILAT=1,LATG2)
CC 33 FORMAT(/'...IN OVRLAP, LATITUDES ARE:',/,(3X,10F10.3))
C
      READ(IUNTSL) SLMASK
C
C     MAKE SOME ISLAND POINTS OCEAN SO THAT BOGUSING IS CONTINUOUS
C       AS CYCLONE PASSES OVER IT
C
      CALL FIXSLM(LONF,LATG2,RLON,RLAT,SLMASK)
C
c && 13 comments
CC    WRITE(6,38)
CC    WRITE(6,37)  (J,(IFIX(SLMASK(I,J)),I=1,100),J=1,190)
CC 37 FORMAT(/'...SLMASK(1-100,1-190)=:',/,(1X,I3,1X,100I1))
CC    WRITE(6,38)
CC 38 FORMAT(//)
CC    WRITE(6,38)
CC    WRITE(6,39)  (J,(IFIX(SLMASK(I,J)),I=101,200),J=1,190)
CC 39 FORMAT(/'...SLMASK(101-200,1-190)=:',/,(1X,I3,1X,100I1))
CC    WRITE(6,41)  (J,(IFIX(SLMASK(I,J)),I=201,300),J=1,190)
CC 41 FORMAT(/'...SLMASK(201-300,1-190)=:',/,(1X,I3,1X,100I1))
CC    WRITE(6,38)
CC    WRITE(6,43)  (J,(IFIX(SLMASK(I,J)),I=301,384),J=1,190)
CC 43 FORMAT(/'...SLMASK(301-384,1-190)=:',/,(1X,I3,1X,84I1))
C
      DO 50 KST=1,KSTORM
      ZLAT=ZNEAR(STMLTO(KST),DELTA)
      ZLON=ZNEAR(STMLNO(KST),DELTA)
      CALL TEMPLT(ISHAPE,DELTA,ZLAT,ZLON,RMXBOG(KST),MAXPTS,MXZ,NYZ,
     1            RLATMN(KST),RLATMX(KST),RLONMN(KST),RLONMX(KST),
     2            RLATP,RLONP,NPTS)
      WRITE(6,49) KST,RLATMN(KST),RLATMX(KST),RLONMN(KST),RLONMX(KST)
   49 FORMAT('...KST,RLATMN,RLATMX,RLONMN,RLONMX=',I3,4F10.3)
   50 CONTINUE
C
C     FIRST, WE CHECK FOR OVERLAP OF THE BOGUSING REGION WITH ANY
C       LAND POINTS.  IF THERE IS AN OVERLAP, WE BOGUS ONLY WITHIN
C       RMAX, EVEN IF IT IS THE FIRST TIME OCCURRENCE OF A STORM
C       ***IMPORTANT NOTE:  THIS METHODOLOGY RELIES ON PREPROCESSING
C                           BY THE VITCHK QUALITY CONTROL PROGRAM
C                           THAT ELIMINATES ALL STORMS FROM
C                           CONSIDERATION IF LAND IS WITHIN RMAX.
C
      DO 90 KST=1,KSTORM
C
      DO 70 JLAT=1,LATG2
      IF(NINT(RLAT(JLAT)*100.) .LE. NINT(RLATMX(KST)*100.) .AND.
     1   NINT(RLAT(JLAT)*100.) .GE. NINT(RLATMN(KST)*100.))  THEN
      DO 60 ILON=1,LONF
      IF(NINT(RLON(ILON)*100.) .LE. NINT(RLONMX(KST)*100.) .AND.
     1   NINT(RLON(ILON)*100.) .GE. NINT(RLONMN(KST)*100.)) THEN
C
      DISTZ=DISTSP_8(STMLTO(KST),STMLNO(KST),RLAT(JLAT),RLON(ILON))*
     1 1.E-3
      IF(DISTZ .LE. RMAX(KST) .AND. SLMASK(ILON,JLAT) .GT. EPSLL) THEN
      WRITE(6,59) KST,STMLTO(KST),STMLNO(KST),RMAX(KST),IFST(KST)
   59 FORMAT(/'###BOGUSING AREA REDUCED TO RMAX DUE TO PROXIMITY TO ',
     1       'LAND.  KST,STMLAT,STMLON,RMAX,IFST=',/,4X,I4,3F10.2,I5)
      IF(IFST(KST) .EQ. 1)  IFST(KST)=2
      GO TO 90
      ENDIF
      ENDIF
   60 CONTINUE
      ENDIF
   70 CONTINUE
C
   90 CONTINUE
C
C     NOW CONSIDER OVERLAPS OF THE BOGUSING AREA BETWEEN DIFFERENT
C       STORMS.
C
      IF(KSTORM .EQ. 1)  THEN
      WRITE(6,101)
  101 FORMAT(/'...THERE IS ONLY ONE STORM. NO OVERLAP FLAGS WILL BE ',
     1       'SET.')
      RETURN
C
      ELSE
      WRITE(6,103) KSTORM,BUFZON
  103 FORMAT(/'...SINCE THERE ARE',I3,' STORMS, WE LOOK FOR POSSIBLE ',
     1       'OVERLAPS BETWEEN THE BOGUSING AREAS. BUFFER ZONE=',F6.1,
     2       ' DEG.')
C
      DO 150 KST1=1,KSTORM-1
      IF(OVRFLG(KST1))  GO TO 150
C
      IQUAD1=IFIX((RLONMX(KST1)-EPSLL)/90.0)+1
C
      DO 130 KST2=KST1+1,KSTORM
C
C     CHECK OVERLAPS ONLY IF BOTH STORMS HAVE NOT ALREADY BEEN
C       MARKED OFF BY ASSIGNING AN OVERLAP FLAG
C
      IF(.NOT. OVRFLG(KST1) .AND. .NOT. OVRFLG(KST2))  THEN
C
      IQUAD2=IFIX((RLONMX(KST2)-EPSLL)/90.0)+1
C
C     STORMS MUST BE IN ADJACENT QUADRANTS FOR THE FOLLOWING TEST
C       TO APPLY (THE EXCEPTION, STORMS ACROSS GREENWICH, WILL BE
C       TESTED SEPARATELY
C
      IF(IABS(IQUAD1-IQUAD2) .LE. 1)  THEN
C
      IF(NINT((RLATMX(KST1)+BUFZON)*100.).GE.NINT(RLATMN(KST2)*100.)
     1  .AND.
     2  NINT((RLATMN(KST1)-BUFZON)*100.).LE.NINT(RLATMX(KST2)*100.))THEN
C
      IF(NINT((RLONMX(KST1)+BUFZON)*100.).GE.NINT(RLONMN(KST2)*100.)
     1  .AND.
     2  NINT((RLONMN(KST1)-BUFZON)*100.).LE.NINT(RLONMX(KST2)*100.))THEN
      DISTZ=DISTSP_8(STMLTO(KST1),STMLNO(KST1),
     1             STMLTO(KST2),STMLNO(KST2))*1.E-3
C
C     FOR CASES WHERE BOTH STORM HAVE BEEN BOGUSED BEFORE, A MORE
C       ACCURATE CHECK IS IF THE DISTANCE BETWEEN THE STORM CENTERS
C       IS LESS THAN THE SUM OF THE RADII OF THE CIRCULATIONS PLUS
C       THE BUFFER DISTANCE
C
      IF(IFST(KST1) .GE. 2 .AND. IFST(KST2) .GE. 2 .AND.
     1   DISTZ .GT. RMAX(KST1)+RMAX(KST2)+BUFZON*DEGLAT)  GO TO 130
      WRITE(6,123) IQUAD1,KST1,RLATMN(KST1),RLATMX(KST1),RLONMN(KST1),
     1         RLONMX(KST1),DISTZ,STMLTO(KST1),STMLNO(KST1),IFST(KST1),
     2         IQUAD2,KST2,RLATMN(KST2),RLATMX(KST2),RLONMN(KST2),
     3         RLONMX(KST2),DISTZ,STMLTO(KST2),STMLNO(KST2),IFST(KST2)
      WRITE(IUNTBH,123) IQUAD1,KST1,RLATMN(KST1),RLATMX(KST1),
     1                 RLONMN(KST1),RLONMX(KST1),DISTZ,STMLTO(KST1),
     2                 STMLNO(KST1),IFST(KST1),IQUAD2,KST2,RLATMN(KST2),
     3                 RLATMX(KST2),RLONMN(KST2),RLONMX(KST2),DISTZ,
     4                 STMLTO(KST2),STMLNO(KST2),IFST(KST2)
  123 FORMAT(/'...AN OVERLAP HAS BEEN DETECTED.  IQUAD,KST,RLATMN,',
     1       'RLATMX,RLONMN,RLONMX,DIST,STMLAT,STMLON,IFST(1,2)=',/,
     2       (5X,2I3,7F10.3,I3))
C
      IF(IFST(KST1) .GE. 2 .AND. IFST(KST2) .GE. 2 .AND.
     1   DISTZ .LT. RMAX(KST1)+RMAX(KST2))  THEN
      WRITE(6,127)  KST1,RMAX(KST1),KST2,RMAX(KST2),DISTZ
  127 FORMAT(/'******OVERLAP BETWEEN VORTEX CIRCULATIONS HAS OCCURRED.',
     1       ' THIS IS AN UNREALISTIC SITUATION.',/,4X,
     2       'THE SMALLER STORM MUST BE DROPPED. KST1,RMAX(KST1)',
     3       'KST2,RMAX(KST2),DISTZ',/,4X,I3,F10.2,I3,2F10.2)
        IF(RMAX(KST1) .GE. RMAX(KST2))  THEN
        OVRFLG(KST2)=.TRUE.
        ELSE
        OVRFLG(KST1)=.TRUE.
        ENDIF
C
      ENDIF
C
      TOOBIG=MAX(0.5*(RMXBOG(KST1)+RMXBOG(KST2)+BUFZON*DEGLAT-DISTZ),
     1             0.0)
      RMXBOG(KST1)=MAX(RMXBOG(KST1)-TOOBIG,RMAX(KST1))
      RMXBOG(KST2)=MAX(RMXBOG(KST2)-TOOBIG,RMAX(KST2))
      WRITE(6,129)  RMAX(KST1),RMAX(KST2),TOOBIG,BUFZON*DEGLAT,DISTZ,
     1              RMXBOG(KST1),RMXBOG(KST2)
  129 FORMAT(/'...OVERLAP REDUCED BY DECREASING RMXBOG. RMAX(1,2),',
     1       'TOOBIG,BUFZON,DISTZ,NEW RMXBOG(1,2)=',/,20X,7F10.2)
C
C     IF AN OVERLAP OCCURS, ONLY ONE OF THE STORMS WILL BE BOGUSED.
C       TOP PRIORITY IS A STORM THAT HAS NOT BEEN BOGUSED BEFORE
C       (IFST=1).  PRIORITY THEN PROCEEDS DOWNWARD FROM SMALL TO
C       LARGE STORMS ON THE SUPPOSITION THAT THE SMALL ONES ARE
C       HARDER TO KEEP IN THE MODEL.
C
C     BOTH STORMS HAVE NOT BEEN BOGUSED BEFORE OR BOTH STORMS HAVE
C       BEEN BOGUSED BEFORE: DECISION BASED ON SIZE ONLY
C****NOT USED AS OF 12/18/90
C     IF((IFST(KST1) .EQ. 1 .AND. IFST(KST2) .EQ. 1) .OR.
C    1    IFST(KST1) .GE. 2 .AND. IFST(KST2) .GE. 2)  THEN
C       IF(RMXBOG(KST1) .LT. RMXBOG(KST2))  THEN
C       OVRFLG(KST2)=.TRUE.
C       ELSE
C       OVRFLG(KST1)=.TRUE.
C       ENDIF
C     GO TO 130
C     ENDIF
C
C     ONE STORM IS BEING BOGUSED FOR THE FIRST TIME
C
C     IF(IFST(KST1) .EQ. 1) THEN
C     OVRFLG(KST2)=.TRUE.
C     ELSE
C     OVRFLG(KST1)=.TRUE.
C     ENDIF
C****NOT USED AS OF 12/18/90
C
      ENDIF
      ENDIF
      ELSE IF(IQUAD1 .EQ. 1 .AND. IQUAD2 .EQ. 4 .OR.
     1        IQUAD1 .EQ. 4 .AND. IQUAD2 .EQ. 1)  THEN
      WRITE(6,137) IQUAD1,IQUAD2
  137 FORMAT(/'...OPTION FOR OVERLAP CHECK ACROSS GREENWICH IS NOT ',
     1       'IMPLEMENTED. IQUAD1,IQUAD2=',2I4)
      ENDIF
      ENDIF
  130 CONTINUE
  150 CONTINUE
      ENDIF
C
      WRITE(6,151) (KST,STMLTO(KST),STMLNO(KST),RMXBOG(KST),
     1            IFST(KST),OVRFLG(KST),KST=1,KSTORM)
      WRITE(IUNTBH,151) (KST,STMLTO(KST),STMLNO(KST),RMXBOG(KST),
     1                  IFST(KST),OVRFLG(KST),KST=1,KSTORM)
  151 FORMAT(/'...SUMMARY OF OVERLAP CALCULATIONS:',/,5X,'KST',4X,
     1       'STMLAT',4X,'STMLON',4X,'RMXBOG',2X,'IFST',2X,'OVRFLG',/,
     2       (5X,I3,3F10.3,2X,I3,4X,L3))
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    RITSPS      WRITE INPUT FILES FOR SPLINE ANALYSIS
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: 1991-06-06
C
C ABSTRACT: WRITES INPUT FILES FOR SPLINE ANALYSIS ROUTINES.  INFO
C   WRITTEN INCLUDE STORM NAME AND TRACK AND DOMAIN FOR THE ANALYSIS
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD
C
C USAGE:    CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C   INPUT ARGUMENT LIST:
C     INARG1   - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C     INARG2   - TYPE.  EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     WRKARG   - GENERIC DESCRIPTION, ETC., AS ABOVE.
C     OUTARG1  - EXPLAIN COMPLETELY IF ERROR RETURN
C     ERRFLAG  - EVEN IF MANY LINES ARE NEEDED
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     DDNAME1  - GENERIC NAME & CONTENT
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     DDNAME2  - GENERIC NAME & CONTENT AS ABOVE
C     FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE RITSPS(INUM,IUNTTK,IUNTDO,IDAYZ,IUTCZ,STMLTZ,STMLNZ,
     1                  XMLZ,XMRZ,YNBZ,YNTZ,DELTA,STMNMZ)
C
      PARAMETER (MDIM=35,NDIM=35)
C
      CHARACTER STMNMZ*(*),STNMZZ*12
C
      SAVE
C
      DIMENSION IDAYZ(INUM),IUTCZ(INUM),STMLTZ(INUM),STMLNZ(INUM)
C
      DATA NODPDL/2/
C
C     THIS SUBROUTINE WRITES FILES AND NAMELISTS CONTAINING
C       STORM TRACK AND DOMAIN THAT ARE NEEDED BY XSPLDAT AND THE
C       ANALYSIS

C-----------------------------------------------------------------------

C
      ENTRY RITTRK(INUM,IUNTTK,IDAYZ,IUTCZ,STMLTZ,STMLNZ,STMNMZ)
C
      STNMZZ=STMNMZ
      WRITE(6,11) INUM,IUNTTK,STMNMZ,(IDAYZ(IZ),IUTCZ(IZ),STMLTZ(IZ),
     1            STMLNZ(IZ),IZ=1,INUM)
   11 FORMAT(/'...ENTERING RITTRK, INUM,IUNTTK,STMNMZ,IDAYZ,IUTCZ,',
     1       'STMLTZ,STMLNZ=',
     2       2I5,1X,A,/,(4X,I8,1X,I5,2F10.2))
C
      WRITE(IUNTTK,21) STNMZZ
   21 FORMAT(A12)
      WRITE(IUNTTK,23)  INUM,INUM
   23 FORMAT('99. 1',2I2)
C
C     CONVERT LONGITUDE TO 0-360 POSITIVE WESTWARD
C
      DO 30 ITR=1,INUM
      STMLNW=360.-STMLNZ(ITR)
      WRITE(IUNTTK,*) STMLNW,STMLTZ(ITR),IDAYZ(ITR),IUTCZ(ITR)
   30 CONTINUE
C
      WRITE(6,1121) STNMZZ
 1121 FORMAT('...A COPY OF THE STORM TRACK FILE FOLLOWS:',/,1X,A12)
      WRITE(6,1123)  INUM,INUM
 1123 FORMAT(' 99. 1',2I2)
      DO 1130 ITR=1,INUM
      STMLNW=360.-STMLNZ(ITR)
      WRITE(6,*) STMLNW,STMLTZ(ITR),IDAYZ(ITR),IUTCZ(ITR)
 1130 CONTINUE
C
      REWIND IUNTTK
      RETURN

C-----------------------------------------------------------------------

C
      ENTRY RITDOM(INUM,IUNTDO,IDAYZ,IUTCZ,XMLZ,XMRZ,YNBZ,YNTZ,DELTA,
     1             STMNMZ)
C
      WRITE(6,101) INUM,IUNTDO,IDAYZ(INUM),IUTCZ(INUM),XMLZ,XMRZ,
     1             YNBZ,YNTZ,DELTA
  101 FORMAT(/'...ENTERING RITDOM, INUM,IUNTDO,IDAYZ,IUTCZ,XMLZ,',
     1       'XMRZ,YNBZ,YNTZ,DELTA=',/,5X,2I5,1X,I8,1X,I5,5F10.2)
C
      STNMZZ=STMNMZ
      WRITE(IUNTDO,121)  STNMZZ
  121 FORMAT(' &BOGPRM STMNAM=''',A12,''',')
      WRITE(IUNTDO,122)  IDAYZ(INUM),IUTCZ(INUM)
  122 FORMAT('   IDAYZ=',I9,',IUTCZ=',I7,',')
      WRITE(IUNTDO,123) XMLZ,XMRZ,YNBZ,YNTZ
  123 FORMAT('   XMLZ=',F8.3,',XMRZ=',F8.3,',YNBZ=',F8.3,
     1       ',YNTZ=',F8.3,',')
C
C     CALCULATE NUMBER OF NODAL POINTS.  NODAL SPACING WILL BE
C       APPROXIMATELY TWICE THE NUMBER OF SAMPLED ANALYSIS POINTS
C
      MXZ=MIN(INT((ABS(XMLZ-XMRZ)/DELTA)*REAL(NODPDL)+0.0001),MDIM-1)
      NXZ=MIN(INT((ABS(YNTZ-YNBZ)/DELTA)*REAL(NODPDL)+0.0001),NDIM-1)
      WRITE(IUNTDO,124) MXZ,NXZ,DELTA
  124 FORMAT('   MXZ=',I5,',NXZ=',I5,',DELSPD=',F6.3)
C
      WRITE(IUNTDO,131)
  131 FORMAT(' /')
C
      WRITE(6,151) STNMZZ
  151 FORMAT('...A COPY OF THE BOGUS DOMAIN AND PARM FILE',
     1       ' FOLLOWS:',/,1X,A12)
      WRITE(6,161)  STNMZZ
  161 FORMAT(/' &BOGPRM STMNAM=''',A12,''',')
      WRITE(6,171)  IDAYZ(INUM),IUTCZ(INUM)
  171 FORMAT('    IDAYZ=',I9,',IUTCZ=',I7)
      WRITE(6,181) XMLZ,XMRZ,YNBZ,YNTZ
  181 FORMAT('    XMLZ=',F8.3,',XMRZ=',F8.3,',YNBZ=',F8.3,
     1       ',YNTZ=',F8.3)
      WRITE(6,191) MXZ,NXZ,DELTA
  191 FORMAT('    MXZ=',I5,',NXZ=',I5,',DELSPD=',F6.3)
C
      WRITE(6,199)
  199 FORMAT('  /')
      REWIND IUNTDO
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    RITCR1      WRITES RUN INFO TO LOG FILE
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: 1991-06-06
C
C ABSTRACT: WRITES RUN INFORMATION TO LOG FILE.
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD
C
C USAGE:    CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C   INPUT ARGUMENT LIST:
C     INARG1   - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C     INARG2   - TYPE.  EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     WRKARG   - GENERIC DESCRIPTION, ETC., AS ABOVE.
C     OUTARG1  - EXPLAIN COMPLETELY IF ERROR RETURN
C     ERRFLAG  - EVEN IF MANY LINES ARE NEEDED
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     DDNAME1  - GENERIC NAME & CONTENT
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     DDNAME2  - GENERIC NAME & CONTENT AS ABOVE
C     FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE RITCR1(IUNTBD,IUNTBH,IDAYZ,IUTCZ,RUNID)
C
      CHARACTER RUNID*(*)
C
      SAVE
C
      CALL ZTIME(IDAYZ,IUTCZ,IYR,IMO,IDA,IHR,IMIN)
      WRITE(IUNTBD,1) IDA,IHR
    1 FORMAT(2I12)
      WRITE(6,11) RUNID,IDA,IHR
      WRITE(IUNTBH,11) RUNID,IDA,IHR
   11 FORMAT('######BEGINNING SYNDATA FOR RUNID=',A,', DAY=',I3,
     1       ', HOUR=',I2.2,'######')
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    RITCR2      WRITES STORM INFO TO MAPPING FILE
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: 1991-06-06
C
C ABSTRACT: WRITES STORM INFO TO FILE FOR LIMITED AREA MAPPING.
C   INFO ARE STORM LAT/LON, RADIUS OF CIRCULATION, LATITUDINAL
C   EXTENT OF THE MAP TO BE PLOTTED, AND STORM NAME/ID.
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD
C
C USAGE:    CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C   INPUT ARGUMENT LIST:
C     INARG1   - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C     INARG2   - TYPE.  EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     WRKARG   - GENERIC DESCRIPTION, ETC., AS ABOVE.
C     OUTARG1  - EXPLAIN COMPLETELY IF ERROR RETURN
C     ERRFLAG  - EVEN IF MANY LINES ARE NEEDED
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     DDNAME1  - GENERIC NAME & CONTENT
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     DDNAME2  - GENERIC NAME & CONTENT AS ABOVE
C     FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE RITCR2(IUNTBD,STMLTZ,STMLNZ,RMAXZ,RLATMN,RLATMX,STMNMZ,
     1                  STMIDZ)
C
      CHARACTER STMNMZ*(*),STMIDZ*3
C
      SAVE
C
      RLATEX=RLATMX-RLATMN+2.0
      WRITE(6,202)
  202 FORMAT(/'...ENTERING RITCR2 TO WRITE STORM INFORMATION:')
      WRITE(IUNTBD,203) STMLTZ,STMLNZ,RMAXZ,RLATEX,
     1                  STMNMZ(1:9),STMIDZ(1:3)
      WRITE(6,203) STMLTZ,STMLNZ,RMAXZ,RLATEX,STMNMZ,
     1             STMIDZ
  203 FORMAT(4F10.2,1X,A,1X,A)
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    TIMSUB      PERFORMS TIME CHORES
C   PRGMMR: D. A. KEYSER     ORG: W/NMC22    DATE: 1998-06-05
C
C ABSTRACT: VARIOUS ENTRIES CONVERT 8 DIGIT YYYYMMDD INTO YEAR, MONTH
C   AND DAY, AND FRACTIONAL JULIAN DAY FROM INTEGER JULIAN DAY, HOUR
C   AND MINUTE.
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD
C 1998-06-05  D. A. KEYSER - Y2K/F90 COMPLIANCE
C
C USAGE:    CALL TIMSUB(IDATE,IUTC,IYR,IMO,IDA,IHR,IMIN,JDY,DAY)
C           CALL FLDAY(JDY,IHR,IMIN,DAY)
C   INPUT ARGUMENT LIST:
C     IDATE    - DATE IN FORM YYYYMMDD
C     JDY      - FRACTIONAL NUMBER OF DAYS SINCE 365 DAYS PRIOR TO
C              - 00Z ON NCEP DATE
C
C   OUTPUT ARGUMENT LIST:
C     IYR      - YEAR IN FORM YYYY
C     IMO      - MONTH OF YEAR
C     IDA      - DAY OF MONTH
C     IHR      - HOUR OF DAY
C     IMIN     - MINUTE OF HOUR
C     DAY      - FRACTIONAL NUMBER OF DAYS SINCE 365 DAYS PRIOR TO
C              - 00Z ON NCEP DATE
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE TIMSUB(IDATE,IUTC,IYR,IMO,IDA,IHR,IMIN,JDY,DAY)

C-----------------------------------------------------------------------


      ENTRY ZTIME(IDATE,IUTC,IYR,IMO,IDA,IHR,IMIN)

C PARSE 8 DIGIT YYYYMMDD INTO YEAR MONTH AND DAY

      IYR = IDATE/10000
      IMO =(IDATE-IYR*10000)/100
      IDA = IDATE-IYR*10000-IMO*100
      IHR =IUTC/100
      IMIN=IUTC-IHR*100
      RETURN


C-----------------------------------------------------------------------

C THIS ENTRY CALCULATES THE FRACTIONAL JULIAN DAY FROM INTEGERS
C  JULIAN DAY, HOUR AND MINUTE (ACUALLY, JDY HERE IS NO. OF DAYS
C  SINCE 365 DAYS PRIOR TO 00Z ON NCEP DATE)

      ENTRY FLDAY(JDY,IHR,IMIN,DAY)
      DAY=REAL(JDY)+(REAL(IHR)*60.+REAL(IMIN))/1440.
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    YTIME       GETS INTEGER YYYY, YYYYMMDD, HHMM
C   PRGMMR: D. A. KEYSER     ORG: NP22       DATE: 1998-10-29
C
C ABSTRACT: CALCULATES 8-DIGIT INTEGER YYYYMMDD, 4-DIGIT INTEGER YYYY,
C   AND 4-DIGIT INTEGER HHMM FROM FRACTIONAL NUMBER OF DAYS SINCE
C   365 DAYS PRIOR TO 00Z ON NCEP DATE
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD
C 1998-10-29  D. A. KEYSER - Y2K/F90 COMPLIANCE
C
C USAGE:    CALL YTIME(IYR,DAYZ,IDATE,IUTC)
C   INPUT ARGUMENT LIST:
C     DAYZ     - FRACTIONAL NUMBER OF DAYS SINCE 365 DAYS PRIOR TO
C              - 00Z ON NCEP DATE
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     IYR      - YEAR (YYYY)
C     IDATEZ   - SLORD DATE FORMAT FOR DATE (YYYYMMDD)
C     IUTC     - SLORD DATE FORMAT FOR DATE (HHMM)
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE YTIME(IYR,DAYZ,IDATE,IUTC)
      DIMENSION JDAT(8),RINC(5)
      COMMON/BDATE/LDAT(8)

      RINC = 0.
      RINC(1) = DAYZ
      CALL W3MOVDAT(RINC,LDAT,JDAT)

      IYR = JDAT(1)
      IMO = JDAT(2)
      IDA = JDAT(3)
      IHR = JDAT(5)
      IMN = JDAT(6)

      IDATE=IDA+(100*IMO)+(10000*IYR)
      IUTC =IMN+100*IHR
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    SORTRL      SORTS REAL NUMBERS
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: 1991-06-04
C
C ABSTRACT: SORTS REAL NUMBERS.  OUTPUT ARRAY IS THE INDEX OF
C   THE INPUT VALUES THAT ARE SORTED.
C
C PROGRAM HISTORY LOG:
C 1991-06-04  S. J. LORD (MODIFIED FROM NCAR CODE)
C
C USAGE:    CALL SORTRL(A,LA,NL)
C   INPUT ARGUMENT LIST:
C     A        - ARRAY OF ELEMENTS TO BE SORTED.
C     NL       - NUMBER OF ELEMENTS TO BE SORTED.
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     LA       - INTEGER ARRAY CONTAINING THE INDEX OF THE SORTED
C              - ELEMENTS.  SORTING IS FROM SMALL TO LARGE.  E.G.
C              - LA(1) CONTAINS THE INDEX OF THE SMALLEST ELEMENT IN
C              - ARRAY.  LA(NL) CONTAINS THE INDEX OF THE LARGEST.
C
C
C REMARKS: NONE
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE SORTRL(A,LA,NL)
C
C          ENTRY SORTRL(A,LA,NL)    SORT UP REAL NUMBERS
C  ** REVISED (6/13/84) FOR THE USE IN VAX-11
C     ARGUMENTS ...
C       A    INPUT ARRAY OF NL ELEMENTS TO BE SORTED OR RE-ORDERED
C       LA   OUTPUT ARRAY OF NL ELEMENTS IN WHICH THE ORIGINAL LOCATION
C            OF THE SORTED ELEMENTS OF A ARE SAVED, OR
C            INPUT ARRAY TO SPECIFY THE REORDERING OF ARRAY A BY SORTED
C       NL   THE NUMBER OF ELEMENTS TO BE TREATED
C
      SAVE
C
      DIMENSION A(NL),LA(NL),LS1(64),LS2(64)
      DATA NSX/64/
C
C     SET THE ORIGINAL ORDER IN LA
C
      DO L=1,NL
      LA(L)=L
      END DO
C
C     SEPARATE NEGATIVES FROM POSITIVES
C
      L = 0
      M = NL + 1
   12 CONTINUE
      L = L + 1
      IF(L.GE.M) GO TO 19
      IF(A(L).LT.0) GO TO 12
   15 CONTINUE
      M = M - 1
      IF(L.GE.M) GO TO 19
      IF(A(M).GE.0) GO TO 15
      AZ = A(M)
      A(M) = A(L)
      A(L) = AZ
      LZ = LA(M)
      LA(M) = LA(L)
      LA(L) = LZ
      GO TO 12
   19 CONTINUE
      L = L - 1
C
C     NOTE THAT MIN AND MAX FOR INTERVAL (1,NL) HAVE NOT BEEN DETERMINED
C
      LS1(1) = 0
      L2 = NL + 1
      NS = 1
C
C     STEP UP
C
   20 LS1(NS) = LS1(NS) + 1
      LS2(NS) = L
      NS = NS + 1
      IF(NS.GT.NSX) GO TO 80
      L1 = L + 1
      LS1(NS) = L1
      L2 = L2 - 1
      GO TO 40
C
C     STEP DOWN
C
   30 NS=NS-1
      IF (NS.LE.0) GO TO 90
      L1 = LS1(NS)
      L2 = LS2(NS)
   40 IF(L2.LE.L1) GO TO 30
C
C     FIND MAX AND MIN OF THE INTERVAL (L1,L2)
C
      IF (A(L1)-A(L2) .LE. 0) GO TO 52
      AN = A(L2)
      LN = L2
      AX = A(L1)
      LX = L1
      GO TO 54
   52 AN = A(L1)
      LN = L1
      AX = A(L2)
      LX = L2
   54 L1A = L1 + 1
      L2A = L2 - 1
      IF(L1A.GT.L2A) GO TO 60
C
      DO 58 L=L1A,L2A
      IF (A(L)-AX .GT. 0) GO TO 56
      IF (A(L)-AN .GE. 0) GO TO 58
      AN = A(L)
      LN = L
      GO TO 58
   56 AX = A(L)
      LX = L
   58 CONTINUE
C
C     IF ALL ELEMENTS ARE EQUAL (AN=AX), STEP DOWN
C
   60 IF (AN .EQ. AX)  GO TO 30
C
C     PLACE MIN AT L1, AND MAX AT L2
C     IF EITHER LN=L2 OR LX=L1, FIRST EXCHANGE L1 AND L2
C
      IF(LN.EQ.L2.OR.LX.EQ.L1) GO TO 62
      GO TO 64
   62 AZ=A(L1)
      A(L1)=A(L2)
      A(L2)=AZ
      LZ=LA(L1)
      LA(L1)=LA(L2)
      LA(L2)=LZ
C
C     MIN TO L1, IF LN IS NOT AT EITHER END
C
   64 IF(LN.EQ.L1.OR.LN.EQ.L2) GO TO 66
      A(LN)=A(L1)
      A(L1)=AN
      LZ=LA(LN)
      LA(LN)=LA(L1)
      LA(L1)=LZ
C
C     MAX TO L2, IF LX IS NOT AT EITHER END
C
   66 IF(LX.EQ.L2.OR.LX.EQ.L1) GO TO 68
      A(LX)=A(L2)
      A(L2)=AX
      LZ=LA(LX)
      LA(LX)=LA(L2)
      LA(L2)=LZ
C
C     IF ONLY THREE ELEMENTS IN (L1,L2), STEP DOWN.
C
   68 IF(L1A.GE.L2A) GO TO 30
C
C     SET A CRITERION TO SPLIT THE INTERVAL (L1A,L2A)
C     AC IS AN APPROXIMATE ARITHMETIC AVERAGE OF AX AND AN,
C     PROVIDED THAT AX IS GREATER THAN AN.  (IT IS THE CASE, HERE)
C     ** IF A IS DISTRIBUTED EXPONENTIALLY, GEOMETRIC MEAN MAY
C        BE MORE EFFICIENT
C
      AC = (AX+AN)/2
C
C     MIN AT L1 AND MAX AT L2 ARE OUTSIDE THE INTERVAL
C
      L = L1
      M = L2
   72 L = L + 1
      IF(L.GE.M) GO TO 78
C  73 CONTINUE
      IF (A(L)-AC .LE. 0) GO TO 72
   75 M = M - 1
      IF(L.GE.M) GO TO 78
C  76 CONTINUE
      IF (A(M)-AC .GT. 0) GO TO 75
      AZ = A(M)
      A(M) = A(L)
      A(L) = AZ
      LZ = LA(M)
      LA(M) = LA(L)
      LA(L) = LZ
      GO TO 72
C
C     SINCE 75 IS ENTERED ONLY IF 73 IS FALSE, 75 IS NOT TENTATIVE
C     BUT 72 IS TENTATIVE, AND MUST BE CORRECTED IF NO FALSE 76 OCCURS
C
   78 L = L - 1
      GO TO 20
   80 WRITE(6,85) NSX
   85 FORMAT(/' === SORTING INCOMPLETE. SPLIT EXCEEDED',I3,' ===',/)
   90 RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    CIRCLE      CALCULATES LAT/LON OF PTS ON CIRCLE
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: 1991-06-06
C
C ABSTRACT: CALCULATES LAT/LON OF POINTS EQUALLY SPACED IN AZIMUTH
C   ON A CIRCLE OF DESIGNATED RADIUS CENTERED AT A GIVEN LAT/LONG.
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD
C
C USAGE:    CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C   INPUT ARGUMENT LIST:
C     INARG1   - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C     INARG2   - TYPE.  EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     WRKARG   - GENERIC DESCRIPTION, ETC., AS ABOVE.
C     OUTARG1  - EXPLAIN COMPLETELY IF ERROR RETURN
C     ERRFLAG  - EVEN IF MANY LINES ARE NEEDED
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     DDNAME1  - GENERIC NAME & CONTENT
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     DDNAME2  - GENERIC NAME & CONTENT AS ABOVE
C     FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
C     *****************************
C     ****  SUBROUTINE CIRCLE  ****
C     *****************************
C
      SUBROUTINE CIRCLE(DTHETA,RADIUS,RLATCZ,RLONCZ,JPTSMX,JPT,RLATP,
     1                  RLONP)
C
      SAVE

      REAL(8)  SINDEG_8,COSDEG_8,DISTSP_8
C
      DIMENSION RLATP(JPTSMX),RLONP(JPTSMX)
C
C     DEGLAT IS ONE DEGREE LATITUDE IN METERS
C
      DATA DEGLAT/111.17E3/,EPSRAD/1.E3/,NITMAX/20/,THTAMX/360./
C
      RADM  =RADIUS*1000.
      RLATC =RLATCZ
      RLONC =RLONCZ
      WRITE(6,9) RLATC,RLONC,DTHETA,RADIUS
    9 FORMAT(///' ...ENTERING CIRCLE WITH RLATC,RLONC,DTHETA,',
     1       'RADIUS(KM)=',4F9.2)
C
      JPT=0
      THETA=0.0
      DO 100 NPT=1,JPTSMX
      NITER=1
      RLATZ=RLATC
      RLONZ=RLONC
      RADLAT=RADM/DEGLAT
      THETA=THETA+DTHETA
c && 2 comments
CC    WRITE(6,7) NPT,THETA,DTHETA
CC  7 FORMAT('...BEGINNING CIRCLE FOR NPT,THETA,DTHETA=',I5,2F10.2)

   10 DLAT=RADLAT*COSDEG_8(THETA)
      DLON=RADLAT*SINDEG_8(THETA)*COSDEG_8(RLATC)
      RLATZ=RLATZ+DLAT
      RLONZ=RLONZ+DLON
      RD=DISTSP_8(RLATC,RLONC,RLATZ,RLONZ)
c && 3 comments
CC    WRITE(6,17) NITER,RLATC,RLONC,RLATZ,RLONZ,RADM,RD,DLAT,DLON
CC 17 FORMAT('...NITER,RLATC,RLONC,RLATZ,RLONZ,RADM,RD,DLAT,DLON=',/,
CC   1       4X,I5,4F9.2,2F12.1,2F9.4)
C
      IF(ABS(RD-RADM) .GT. EPSRAD)  THEN
C
      IF(NITER .EQ. NITMAX) THEN
      WRITE(6,21) NITMAX,THETA,RADIUS,RLATC,RLONC,RLATZ,RLONZ,DLAT,DLON
   21 FORMAT(/'******ITERATION ERROR IN CIRCLE, NITMAX,THETA,RADIUS,',
     1       'RLATC,RLONC,RLATZ,RLONZ,DLAT,DLON=',/,7X,I4,8F12.4)
      CALL ABRT1(' CIRCLE',21)
      ENDIF
C
      NITER=NITER+1
      RADLAT=(RADM-RD)/DEGLAT
      GO TO 10
      ENDIF
C
      JPT=JPT+1
      RLATP(JPT)=RLATZ
      RLONP(JPT)=RLONZ
      IF(THETA+DTHETA .GT. THTAMX) THEN
      WRITE(6,93) JPT,THETA,DTHETA
   93 FORMAT(/'...COMPLETED CIRCLE WITH JPT,THETA,DTHETA=',
     1       I5,2F10.2)
      RETURN
      ENDIF
C
  100 CONTINUE
      WRITE(6,101) JPTSMX,THETA,DTHETA
  101 FORMAT(/'******INSUFFICIENT SPACE TO COMPLETE CIRCLE, JPTSMX,',
     1       'THETA,DTHETA=',I5,2F10.2)
C
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    RFAC        MULTIPLICATIVE FACTOR FOR STORM RADIUS
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: 1991-06-07
C
C ABSTRACT: CALCULATES A MULTIPLICATIVE FACTOR BY WHICH THE BOGUSING
C   AREA EXCEEDS THE STORM RADIUS.
C
C PROGRAM HISTORY LOG:
C 1991-06-07  S. J. LORD
C
C USAGE:    CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C   INPUT ARGUMENT LIST:
C     INARG1   - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C     INARG2   - TYPE.  EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     WRKARG   - GENERIC DESCRIPTION, ETC., AS ABOVE.
C     OUTARG1  - EXPLAIN COMPLETELY IF ERROR RETURN
C     ERRFLAG  - EVEN IF MANY LINES ARE NEEDED
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     DDNAME1  - GENERIC NAME & CONTENT
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     DDNAME2  - GENERIC NAME & CONTENT AS ABOVE
C     FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
C     *****************************
C     ****  FUNCTION RFAC      ****
C     *****************************
C
      FUNCTION RFAC(IFSTZZ,RADIUS)
C
      DIMENSION RFAC1(2),RFAC2(2)
C
      SAVE

      DATA RFAC1/4.0,1.5/,RFAC2/1.1,1.05/,RADMIN/150./,RADMAX/750./
      DATA RFMIN/0/,RFMAX/0/
C
      IFSTZ=MIN(IFSTZZ,2)
C
      IF(IFSTZ .NE. 0)  THEN
      RFMIN=RFAC1(IFSTZ)*RADMIN
      RFMAX=RFAC2(IFSTZ)*RADMAX
      RFAC1S=RFAC1(IFSTZ)
      RFAC2S=RFAC2(IFSTZ)
      ENDIF
C
      IF(RADIUS .LE. RADMIN)  THEN
      RFAC=RFAC1S*RADIUS
      ELSE IF(RADIUS .GE. RADMAX)  THEN
      RFAC=RFAC2S*RADIUS
      ELSE
      RFAC=RFMIN+(RFMAX-RFMIN)*(RADIUS-RADMIN)/(RADMAX-RADMIN)
      ENDIF
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ZNEAR       Z NEAREST GRID POINT TO A GIVEN LAT/LON
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: 1991-06-07
C
C ABSTRACT: CALCULATES THE NEAREST LAT OR LON LOCATION TO AN EQUALLY
C   SPACED GRID OF LAT/LON POINT.
C
C PROGRAM HISTORY LOG:
C 1991-06-07  S. J. LORD
C
C USAGE:    CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C   INPUT ARGUMENT LIST:
C     INARG1   - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C     INARG2   - TYPE.  EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     WRKARG   - GENERIC DESCRIPTION, ETC., AS ABOVE.
C     OUTARG1  - EXPLAIN COMPLETELY IF ERROR RETURN
C     ERRFLAG  - EVEN IF MANY LINES ARE NEEDED
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     DDNAME1  - GENERIC NAME & CONTENT
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     DDNAME2  - GENERIC NAME & CONTENT AS ABOVE
C     FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
C     *****************************
C     ****  FUNCTION ZNEAR     ****
C     *****************************
C
      FUNCTION ZNEAR(ZIN,DELTA)
C
      INEAR=NINT(ZIN/DELTA)
      ZNEAR=DELTA*REAL(INEAR)
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    CHGRES      CHANGES RESOLUTION OF SPECTRAL COEFFS
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: 1991-06-06
C
C ABSTRACT: STANDARD NCEP GLOBAL SPECTRAL MODEL CHANGE RESOLUTION
C   CODE.
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD - COPIED FROM KANAMITSU LIBRARY
C
C USAGE:    CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C   INPUT ARGUMENT LIST:
C     INARG1   - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C     INARG2   - TYPE.  EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     WRKARG   - GENERIC DESCRIPTION, ETC., AS ABOVE.
C     OUTARG1  - EXPLAIN COMPLETELY IF ERROR RETURN
C     ERRFLAG  - EVEN IF MANY LINES ARE NEEDED
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     DDNAME1  - GENERIC NAME & CONTENT
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     DDNAME2  - GENERIC NAME & CONTENT AS ABOVE
C     FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE CHGRES(MAXWV,IROMB,WAVE,MAXWVO,IROMBO,WAVEC)
C
cc dak 7/3/05      DIMENSION WAVE(1),WAVEC(1)
      dimension wave(*),wavec(*) ! dak 7/3/05: fix bounds-check error
C
      MDIM=(MAXWV+1)*(MAXWV+1)*2
      IF(IROMB.NE.1) MDIM=(MAXWV+1)*(MAXWV+2)
C
      NCEP=0
      DO M=1,MAXWVO+1
         NEND=M+MAXWVO
         IF(IROMBO.NE.1) NEND=MAXWVO+1
         DO N=M,NEND
            NCEP=NCEP+1
            NM=(MAXWV+1)*(M-1)+N-M+1
            IF(IROMB.NE.1) NM=M*(MAXWV+1)-(MAXWV+1-N)-(M-1)*M/2
            DO II=1,2
               X=0.
               IF(NM*2-2+II.LE.MDIM) X=WAVE(NM*2-2+II)
               IF(M.GT.MAXWV+1) X=0.
               IF(IROMB.EQ.1) THEN
                  IF(N.GT.M+MAXWV) X=0.
               ENDIF
               IF(IROMB.EQ.0) THEN
                  IF(N.GT.MAXWV+1) X=0.
               ENDIF
               WAVEC(NCEP*2-2+II)=X
            ENDDO
         ENDDO
      ENDDO
C
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    UVTOZD      CONVERTS COEFFS OF WIND TO VORT/DIV
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: 1991-06-06
C
C ABSTRACT: STANDARD NCEP SPECTRAL MODEL CODE TO CONVERT COEFFS OF
C   WIND (U,V) TO COEFFS OF VORTICITY AND DIVERGENCE.
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD - COPIED FROM KANAMITSU LIBRARY
C
C USAGE:    CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C   INPUT ARGUMENT LIST:
C     INARG1   - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C     INARG2   - TYPE.  EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     WRKARG   - GENERIC DESCRIPTION, ETC., AS ABOVE.
C     OUTARG1  - EXPLAIN COMPLETELY IF ERROR RETURN
C     ERRFLAG  - EVEN IF MANY LINES ARE NEEDED
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     DDNAME1  - GENERIC NAME & CONTENT
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     DDNAME2  - GENERIC NAME & CONTENT AS ABOVE
C     FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE UVTOZD(U,V,Z,D,MEND1,IROMB,ER,MWVD2,MUWVD2)
C
C  THIS ROUTINE PERFORMS CONVERSION OF PSEUDO-SCALAR U, V TO
C  TRUE SCALAR VORTICITY (Z) AND DIVERGENCE (D) IN SPECTRAL
C  SPACE.
C
C  CALL UVTOZD(U,V,Z,D,MEND1,IROMB,ER,MWVD2,MUWVD2)
C
C  CALLING ARGUEMENTS:
C
C  U      ..... PSEUDO SCALAR ZONAL WIND (= UCOS(PHI))
C  V      .....   ..    ..    MERID WIND (= VCOS(PHI))
C  Z      ..... OUTPUT OF RELATIVE VORTICITY
C  D      .....   ..   .. DIVERGENCE
C  MEND1  ..... ZONAL WAVENUMBER + 1 FOR ZETA AND DIV
C  ER     ..... RADIUS OF EARTH
C  MWVD2  ..... DIMENSION OF Z AND D
C  MUWVD2 ..... DIMENSION OF U AND V
C
C  HUA-LU PAN   17 JANUARY 1989
C
      DIMENSION U(MUWVD2), V(MUWVD2), Z(MWVD2), D(MWVD2)
      COMPLEX AI, B(2,1000)
      REAL SUB(2,1000), DIAG(2,1000), SUP(2,1000)
      EPS(N,M) = SQRT(REAL(N*N-M*M)/REAL(4*N*N-1))
      AI = CMPLX(0.,1.)
C
C HANDLE M = 0 SEPERATELY
C
      NM = 0
      NMU = 0
      MM = 1
      M = 0
      NEND1 = MEND1
      IF(IROMB.EQ.1) NEND1 = MM + MEND1 - 1
      D2 = 0.
      DO 100 NN = MM, NEND1
      NM = NM + 1
      NMU = NMU + 1
      NMT2 = NM * 2
      NMUT2 = NMU * 2
      N = NN - 1
      D1 = D2
      IF(N.GT.0) THEN
      D2 = EPS(N,M)
      FAC1 = N / (ER * D2)
      ENDIF
      IF(N.GT.1) FAC2 = (N * D1) / ((N-1) * D2)
      IF(N.EQ.0) THEN
      Z(NMT2-1) = 0.
      Z(NMT2)   = 0.
      D(NMT2-1) = 0.
      D(NMT2)   = 0.
      ELSEIF(N.EQ.1) THEN
      Z(NMT2-1) =  U(NMUT2-3) * FAC1
      Z(NMT2)   =  U(NMUT2-2) * FAC1
      D(NMT2-1) = -V(NMUT2-3) * FAC1
      D(NMT2)   = -V(NMUT2-2) * FAC1
      ELSEIF(N.GT.1) THEN
      Z(NMT2-1) =  U(NMUT2-3) * FAC1 + Z(NMT2-5) * FAC2
      Z(NMT2)   =  U(NMUT2-2) * FAC1 + Z(NMT2-4) * FAC2
      D(NMT2-1) = -V(NMUT2-3) * FAC1 + D(NMT2-5) * FAC2
      D(NMT2)   = -V(NMUT2-2) * FAC1 + D(NMT2-4) * FAC2
      ENDIF
 100  CONTINUE
C
C  INCREMENT NMU BY ONE BECAUSE U, V HAVE AN EXTRA WAVENUMBER COMP.
C
      NMU = NMU + 1
C
C  SOLVE LINKED TRIDIAGONAL MATRICES FOR M GT 1
C  NOTE THAT THE INDEXING IS NOW BASED ON U AND V INSTEAD OF
C  Z AND D AS IN THE PREVIOUS LOOP
C
      DO 300 MM = 2, MEND1
      M = MM - 1
      NEND1 = MEND1
      IF(IROMB.EQ.1) NEND1 = MM + MEND1 - 1
      NDIM = NEND1 - MM + 1
      D2 = 0.
      NR = 0
      NMOLD = NM
      NMUOLD = NMU
      DO 200 NN = MM, NEND1
      NR = NR + 1
      N = NN - 1
      NM = NM + 1
      NMU = NMU + 1
      NMT2 = NM * 2
      NMUT2 = NMU * 2
      D1 = D2
      D2 = EPS(N+1,M)
      IF(N.EQ.M) THEN
        SUB(1,NR) = 0.
        SUB(2,NR) = 0.
      ELSE
        SUB(1,NR) = -D1 / N
        SUB(2,NR) = -SUB(1,NR)
      ENDIF
      B(1,NR) = CMPLX(U(NMUT2-1),U(NMUT2)) / ER
      B(2,NR) = CMPLX(V(NMUT2-1),V(NMUT2)) / ER
      DIAG(1,NR) = -REAL(M) / REAL(N * (N+1))
      DIAG(2,NR) = DIAG(1,NR)
      IF(NN.EQ.NEND1) THEN
        SUP(1,NR) = 0.
        SUP(2,NR) = 0.
      ELSE
        SUP(1,NR) = D2 / (N+1)
        SUP(2,NR) = -SUP(1,NR)
      ENDIF
 200  CONTINUE
      IF(NDIM.GT.1) THEN
        DO 210 I = 2, NDIM
        SUB(1,I) = SUB(1,I) / DIAG(2,I-1)
        SUB(2,I) = SUB(2,I) / DIAG(1,I-1)
        DIAG(1,I) = DIAG(1,I) + SUB(1,I) * SUP(2,I-1)
        DIAG(2,I) = DIAG(2,I) + SUB(2,I) * SUP(1,I-1)
        B(1,I) = B(1,I) + AI * SUB(1,I) * B(2,I-1)
        B(2,I) = B(2,I) + AI * SUB(2,I) * B(1,I-1)
 210    CONTINUE
      ENDIF
      B(1,NDIM) = -AI * B(1,NDIM) / DIAG(1,NDIM)
      B(2,NDIM) = -AI * B(2,NDIM) / DIAG(2,NDIM)
      IF(NDIM.GT.1) THEN
        DO 220 I = NDIM-1, 1, -1
        B(1,I) = -AI * (B(1,I) - SUP(1,I) * B(2,I+1)) / DIAG(1,I)
        B(2,I) = -AI * (B(2,I) - SUP(2,I) * B(1,I+1)) / DIAG(2,I)
 220    CONTINUE
      ENDIF
      NM = NMOLD
      NMU = NMUOLD
      NR = 0
      DO 230 NN = MM, NEND1
      N = NN - 1
      NM = NM + 1
      NMU = NMU + 1
      NR = NR + 1
      NMT2 = NM * 2
      NMUT2 = NMU * 2
      Z(NMT2-1) =  REAL(B(2,NR))
      Z(NMT2)   = AIMAG(B(2,NR))
      D(NMT2-1) =  REAL(B(1,NR))
      D(NMT2)   = AIMAG(B(1,NR))
 230  CONTINUE
      NMU = NMU + 1
 300  CONTINUE
C
C  MAKING SURE THAT THE IMAGINARY PART OF THE ZONAL (M=0) COMPONENT
C  IS ZERO AS WELL AS THE REAL PART OF N=M=0 IS ZERO
C
      Z(1) = 0.
      D(1) = 0.
      DO 400 N = 1, MEND1
      N2 = N * 2
      Z(N2) = 0.
      D(N2) = 0.
 400  CONTINUE
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    RDSUBS      READ TITLE OF SPLINE ANALYSIS RUN
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: 1991-06-06
C
C ABSTRACT: READS INPUT CARDS THAT DESCRIBE ANALYSIS RUN OF THE
C   SPLINE ANALYSIS.
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD
C
C USAGE:    CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C   INPUT ARGUMENT LIST:
C     INARG1   - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C     INARG2   - TYPE.  EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     WRKARG   - GENERIC DESCRIPTION, ETC., AS ABOVE.
C     OUTARG1  - EXPLAIN COMPLETELY IF ERROR RETURN
C     ERRFLAG  - EVEN IF MANY LINES ARE NEEDED
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     DDNAME1  - GENERIC NAME & CONTENT
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     DDNAME2  - GENERIC NAME & CONTENT AS ABOVE
C     FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE RDSUBS(ISUB)
      PARAMETER(ISUBMX=2)
C
C          ENTRY DATITL   (SET TIME AND DATE WITHOUT READING A CARD)
C                         (NOT NEEDED IF RDTITL WAS CALLED EARLIER)
C          ENTRY PRTITL
C
      COMMON /TITLE/ JOBID(ISUBMX),JOBH,TODAY,ZTIME
      CHARACTER*48  JOBID*120,TODAY*11,ZTIME*8
C
      SAVE
C
C-----------------------------------------------------------------------

      ENTRY RDTITL(ISUB)
C
C     INITIALIZE JOBID FOR IBM
C
      JOBID(ISUB)=' '
      ISUBSV=ISUB
C
C     READ JOBID
C
      READ 5,JOBID(ISUB)
    5 FORMAT(A80)
C
C
C     GET THE CURRENT TIME AND DATE
C
      CALL SPTIME(ZTIME)
      CALL SPDATE(TODAY)
      RETURN

C-----------------------------------------------------------------------

      ENTRY PRTITL(ISUB)
C
C     WRITE THE JOBID, CURRENT TIME AND CURRENT DATE
C
      WRITE(6,123) JOBID(ISUB),ZTIME,TODAY
  123 FORMAT(//5X,A120,//,20X,'*TIME=',A8,10X,'*DATE=',A11)
      ISUBSV=ISUB
      RETURN
C

C-----------------------------------------------------------------------

      ENTRY PREND
C
C     WRITE THE JOBID, END TIME AND DATE
C
      CALL SPTIME(ZTIME)
      CALL SPDATE(TODAY)
      WRITE(6,*)  '            ***  NORMAL TERMINATION OF JOB  ***'
      WRITE(6,123) JOBID(ISUBSV),ZTIME,TODAY
      RETURN
C
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    STISUB      TIME SUBROUTINES FOR SPLINE ANALYSIS
C   PRGMMR: D. A. KEYSER     ORG: NP22       DATE: 1998-07-24
C
C ABSTRACT: TIME AND DATE SUBROUTINES FOR THE SPLINE ANALYSIS.
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD
C 1998-07-24  D. A. KEYSER - Y2K/F90 COMPLIANCE
C
C USAGE:    CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C   INPUT ARGUMENT LIST:
C     INARG1   - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C     INARG2   - TYPE.  EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     WRKARG   - GENERIC DESCRIPTION, ETC., AS ABOVE.
C     OUTARG1  - EXPLAIN COMPLETELY IF ERROR RETURN
C     ERRFLAG  - EVEN IF MANY LINES ARE NEEDED
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     DDNAME1  - GENERIC NAME & CONTENT
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     DDNAME2  - GENERIC NAME & CONTENT AS ABOVE
C     FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE STISUB(ZZDATE,ZZTIME)
C
      DIMENSION IDT(8)
      CHARACTER ZZDATE*11,ZZTIME*8

C-----------------------------------------------------------------------

      ENTRY SPDATE(ZZDATE)
      ZZDATE='    :  :   '
      CALL W3LOCDAT(IDT)
      WRITE(ZZDATE(1: 4),'(I4.4)') IDT(1)
      WRITE(ZZDATE(6: 7),'(I2.2)') IDT(2)
      WRITE(ZZDATE(9:10),'(I2.2)') IDT(3)
      RETURN

C-----------------------------------------------------------------------

      ENTRY SPTIME(ZZTIME)
      ZZTIME='  :  :  '
      CALL W3LOCDAT(IDT)
      IHR=IDT(5)
      IMIN=IDT(6)
      ISEC=IDT(7)
      WRITE(ZZTIME(1:2),'(I2.2)') IHR
      WRITE(ZZTIME(4:5),'(I2.2)') IMIN
      WRITE(ZZTIME(7:8),'(I2.2)') ISEC
      RETURN

C-----------------------------------------------------------------------

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      FUNCTION ISECND(INSEC)

      DIMENSION IDT(8)
      CALL W3LOCDAT(IDT)
      IDT8 = (IDT(5) * 3600) + (IDT(6) * 60) + IDT(7)
      IF(INSEC.LE.0)  THEN
        ISECND=IDT8
      ELSE
        ISECND=IDT8-INSEC
      ENDIF
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    UVRTCN      CARTESIAN U,V TO RAD, TAN WIND
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: 1991-06-06
C
C ABSTRACT: CONVERTS CARTESIAN U,V WINDS TO RADIAL, TANGENTIAL
C   WIND AND VICE VERSA.
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD
C
C USAGE:    CALL UVRTCN(ANGLE,UWIND,VWIND,RADWND,TANWND)
C   INPUT ARGUMENT LIST:
C     ANGLE    - AZIMUTHAL ANGLE WITH RESPECT TO CENTER
C                (0-360 CLOCKWISE FROM NORTH)
C     UWIND    - WIND IN CARTESIAN X DIRECTION
C     VWIND    - WIND IN CARTESIAN Y DIRECTION
C     RADWND   - WIND IN RADIAL DIRECTION (POS. OUTWARD
C                FROM CENTER)
C     TANWND   - WIND IN TANGENTIAL DIRECTION [POS. IN THE
C                COUNTERCLOCKWISE SENSE, WHICH IS CYCLONIC
C                IN THE NORTHERN HEMISPHERE]
C
C   OUTPUT ARGUMENT LIST:   SAME DEFINITIONS AS INPUT LIST
C
C REMARKS: SPECIFY UWIND,VWIND USING UVRTCN TO GET RADWND,TANWND
C          AS OUTPUT.
C          SPECIFY RADWND,TANWND USING RTUVCN TO GET UWIND,VWIND
C          AS OUTPUT.
C          SINDEG_8 AND COSDEG_8 ARE SINE AND COSINE FUNCTIONS WITH
C          ARGUMENTS IN DEGREES.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE UVRTCN(ANGLE,UWIND,VWIND,RADWND,TANWND)

      REAL(8)  SINDEG_8,COSDEG_8

      SINANG=SINDEG_8(ANGLE)
      COSANG=COSDEG_8(ANGLE)
      RADWND= UWIND*SINANG+VWIND*COSANG
      TANWND=-UWIND*COSANG+VWIND*SINANG
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    UV2DS       CONVERTS U, V MOTION TO DIRECTION/SPEED
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: 1991-06-06
C
C ABSTRACT: CONVERTS ZONAL AND MERIDIONAL MOTION TO DIRECTION AND
C   SPEED AND VICE VERSA.
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD
C
C USAGE:    CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C   INPUT ARGUMENT LIST:
C     INARG1   - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C     INARG2   - TYPE.  EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     WRKARG   - GENERIC DESCRIPTION, ETC., AS ABOVE.
C     OUTARG1  - EXPLAIN COMPLETELY IF ERROR RETURN
C     ERRFLAG  - EVEN IF MANY LINES ARE NEEDED
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     DDNAME1  - GENERIC NAME & CONTENT
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     DDNAME2  - GENERIC NAME & CONTENT AS ABOVE
C     FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE UV2DS(UZ,VZ,DIRZ,SPDZ)

      REAL(8)  SINDEG_8,COSDEG_8

      DATA EPS/1.E-5/
C
C     THIS ENTRY CALCULATES DIRECTION,SPEED FROM U, V CARTESIAN WINDS
C        ******  IMPORTANT NOTE: DIRECTION IS DIRECTION WIND IS
C                BLOWING, THE OPPOSITE OF METEOROLOGICAL CONVENTION  ***
C
      IF(VZ .NE. -EPS)  VZ=VZ+EPS
      SPDZ=SQRT(UZ**2+VZ**2)
      DIRZ=ATAN2DEG(UZ,VZ)
      IF(DIRZ .LT. -0.000001)  DIRZ=360.+DIRZ
      RETURN

C-----------------------------------------------------------------------

      ENTRY DS2UV(UZ,VZ,DIRZ,SPDZ)
C
C     THIS ENTRY PRODUCES U, V CARTESIAN WINDS FROM DIRECTION, SPEED
C
      UZ=SPDZ*SINDEG_8(DIRZ)
      VZ=SPDZ*COSDEG_8(DIRZ)
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ATAN2DEG    ARC TAN FUNCTION FROM DEGREES INPUT
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: 1991-06-06
C
C ABSTRACT: ARC TAN FUNCTION FROM DEGREES INPUT.
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD
C
C USAGE:    CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C   INPUT ARGUMENT LIST:
C     INARG1   - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C     INARG2   - TYPE.  EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     WRKARG   - GENERIC DESCRIPTION, ETC., AS ABOVE.
C     OUTARG1  - EXPLAIN COMPLETELY IF ERROR RETURN
C     ERRFLAG  - EVEN IF MANY LINES ARE NEEDED
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     DDNAME1  - GENERIC NAME & CONTENT
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     DDNAME2  - GENERIC NAME & CONTENT AS ABOVE
C     FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      FUNCTION ATAN2DEG(ARG1,ARG2)

C  DEGRAD CONVERTS DEGREES TO RADIANS

      DATA DEGRAD/0.017453/
      IF(ARG1 .EQ. 0.0 .AND. ARG2 .EQ. 0.0)  THEN
      ATAN2DEG=0.0
      ELSE
      ATAN2DEG=ATAN2(ARG1,ARG2)/DEGRAD
      ENDIF
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    SINDEG_8    SINE FUNCTION FROM DEGREES INPUT
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: 1991-06-06
C
C ABSTRACT: SINE FUNCTION FROM DEGREES INPUT.
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD
C
C USAGE:    CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C   INPUT ARGUMENT LIST:
C     INARG1   - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C     INARG2   - TYPE.  EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     WRKARG   - GENERIC DESCRIPTION, ETC., AS ABOVE.
C     OUTARG1  - EXPLAIN COMPLETELY IF ERROR RETURN
C     ERRFLAG  - EVEN IF MANY LINES ARE NEEDED
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     DDNAME1  - GENERIC NAME & CONTENT
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     DDNAME2  - GENERIC NAME & CONTENT AS ABOVE
C     FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      FUNCTION SINDEG_8(ARG)

C  DEGRAD CONVERTS DEGREES TO RADIANS

      REAL(8) SINDEG_8
      DATA DEGRAD/0.017453/
      SINDEG_8=SIN(ARG*DEGRAD)
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    COSDEG_8    COSINE FUNCTION FROM DEGREES INPUT
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: 1991-06-06
C
C ABSTRACT: RETURNS COSINE FUNCTION FROM DEGREES INPUT
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD
C
C USAGE:    CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C   INPUT ARGUMENT LIST:
C     INARG1   - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C     INARG2   - TYPE.  EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     WRKARG   - GENERIC DESCRIPTION, ETC., AS ABOVE.
C     OUTARG1  - EXPLAIN COMPLETELY IF ERROR RETURN
C     ERRFLAG  - EVEN IF MANY LINES ARE NEEDED
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     DDNAME1  - GENERIC NAME & CONTENT
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     DDNAME2  - GENERIC NAME & CONTENT AS ABOVE
C     FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      FUNCTION COSDEG_8(ARG)

C  DEGRAD CONVERTS DEGREES TO RADIANS

      REAL(8) COSDEG_8
      DATA DEGRAD/0.017453/
      COSDEG_8=COS(ARG*DEGRAD)
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    DISTSP_8    DISTANCE ON GREAT CIRCLE
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: 1991-06-06
C
C ABSTRACT: CALCULATES DISTANCE ON GREAT CIRCLE BETWEEN TWO LAT/LON
C   POINTS.
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD
C
C USAGE:    DXY=DISTSP_8(DLAT1,DLON1,DLAT2,DLON2)
C   INPUT ARGUMENT LIST:
C     DLAT1    - LATITUDE OF POINT 1 (-90<=LAT<=90)
C     DLON1    - LONGITUDE OF POINT 1 (-180 TO 180 OR 0 TO 360)
C     DLAT2    - LATITUDE OF POINT 2 (-90<=LAT<=90)
C     DLON1    - LONGITUDE OF POINT 2
C
C
C REMARKS: DISTANCE IS IN METERS
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      FUNCTION DISTSP_8(DLAT1,DLON1,DLAT2,DLON2)
      REAL(8) DISTSP_8,XXM,XXD,YYY,SINDEG_8,COSDEG_8
      DATA REARTH/6.37E6/
C
      XXD=COSDEG_8(DLON1-DLON2)*COSDEG_8(DLAT1)*COSDEG_8(DLAT2)+
     1    SINDEG_8(DLAT1)*SINDEG_8(DLAT2)
C
      YYY=MAX(-1.0_8,XXD)
      XXM=MIN(1.0_8,YYY)
C
      DISTSP_8=ACOS(XXM)*REARTH
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    STDEV       STANDARD DEVIATION RMS DIFFERENCE
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: 1991-06-06
C
C ABSTRACT: CALCULATES STANDARD DEVIATIONS AND RMS DIFFERENCES.
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD
C
C USAGE:    CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C   INPUT ARGUMENT LIST:
C     INARG1   - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C     INARG2   - TYPE.  EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     WRKARG   - GENERIC DESCRIPTION, ETC., AS ABOVE.
C     OUTARG1  - EXPLAIN COMPLETELY IF ERROR RETURN
C     ERRFLAG  - EVEN IF MANY LINES ARE NEEDED
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     DDNAME1  - GENERIC NAME & CONTENT
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     DDNAME2  - GENERIC NAME & CONTENT AS ABOVE
C     FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE STDEV(XX,LX,NSAM,AVGX,STDX)
C
      DIMENSION XX(LX)
C
      STDX=0.0
C     N=0
      DO 10 L=1,LX
      STDX=STDX+(XX(L)-AVGX)**2
C     N=N+1
   10 CONTINUE
      STDX=SQRT(STDX/REAL(NSAM))
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ABRT1       ERROR EXIT ROUTINE
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: 1991-06-05
C
C ABSTRACT: ERROR TERMINATION ROUTINE THAT LISTS ROUTINE WHERE
C   ERROR OCCURRED AND THE NEAREST STATEMENT NUMBER.
C
C PROGRAM HISTORY LOG:
C 1991-06-05  S. J. LORD
C
C USAGE:    CALL ABRT1(ME(KENTRY,ISTMT)
C   INPUT ARGUMENT LIST:
C     KENTRY   - CHARACTER VARIABLE (*7) GIVING PROGRAM OR SUBROUTINE
C              - WHERE ERROR OCCURRED.
C     ISTMT    - STATEMENT NUMBER NEAR WHERE ERROR OCCURRED.
C
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     FT06F001 - PRINTOUT
C
C REMARKS: THIS ROUTINE IS CALLED WHENEVER AN INTERNAL PROBLEM
C          TO THE CODE IS FOUND. EXAMPLES ARE CALLING PARAMETERS THAT
C          WILL OVERFLOW ARRAY BOUNDARIES AND OBVIOUS INCONSISTENCIES
C          IN NUMBERS GENERATED BY THE CODE.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE ABRT1(KENTRY,ISTMT)
      CHARACTER*(*) KENTRY
      WRITE(6,10) KENTRY,ISTMT
   10 FORMAT(////21X,'*********************************************'/
     1           21X,'*********************************************'/
     2           21X,'****  PROGRAM FAILED DUE TO FATAL ERROR  ****'/
     3           21X,'****  IN ROUTINE ',A,' NEAR            ****'/
     4           21X,'****  STATEMENT NUMBER',I5,'.             ****'/
     5           21X,'*********************************************'/
     6           21X,'*********************************************')
      CALL W3TAGE('SYNDAT_SYNDATA')
      CALL ERREXIT(20)
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE CMPSIT(NDATAZ,STMDRZ,STMSPZ,PTOPZ,RMXCOM,RMAXZ,ONLYWI,
     1                  ONLYPS,STMNMZ,IPRTZ,IUNTBH,IHOWFR,ANGLE,RLAT,
     2                  RLON,PRESR,IRTYP,DATA,AXIPS,AXIRAD,NRDSTR,
     3                  NRADVO,NCMPVO,IUNTDH,AXIWND,PRESVO,RMAX,PCEN,
     4                  PENV,RPOT,SPDPOT,NOBWMN,STMLTZ,STMLNZ,IDATEZ,
     5                  IUTCZ)
C
      PARAMETER (NRADBN=18)
      PARAMETER (NAZIBN= 4)
      PARAMETER (NLVLBN= 4)
      PARAMETER (NCORBN= 2)
      PARAMETER (NVARBN= 3)
ccccc PARAMETER (NDATMX=1000)
      PARAMETER (NDATMX=8000)
ccccc PARAMETER (LDXDIM=1000)
      PARAMETER (LDXDIM=8000)
      PARAMETER (NVROUT=16)
      PARAMETER (IOUTMX= 6)
      PARAMETER (NRBNPS=36)
      PARAMETER (NDIM=70)
C
      CHARACTER STMNMZ*(*)
C
      LOGICAL FIRST,EQLDR,PRNT,ONLYWI,ONLYPS,YUP
C
      SAVE
C
      DIMENSION RBIN(0:NRADBN),DATA(NDATAZ),RADBIN(NRADBN),
     1          PBIN(NLVLBN+1),PSET(NLVLBN+1),
     2          COMDAT(NRADBN,NAZIBN,NLVLBN,NCORBN,NVARBN),
     3          NCOMDT(NRADBN,NAZIBN,NLVLBN,NCORBN,NVARBN),
     4          OUTMAP(NAZIBN),OUTPRT(IOUTMX),
     5          RADDAT(NVROUT,NDATMX,NRADBN,NLVLBN),STDZ(NDATMX),
     6          NSTOR(NRADBN,NLVLBN),AZIAVW(NRADBN,NVARBN,NLVLBN,2),
     7          NAZIAV(NRADBN,NLVLBN,2),STDAZW(NRADBN,NVARBN,NLVLBN)
C
      DIMENSION PSBIN(NRBNPS,2),RPSBIN(NRBNPS),NPSBIN(NRBNPS,2),
     1          PSDAT(NVROUT,NDATMX,NRBNPS),PSCOM(NRBNPS,2),
     2          STDAZP(NRBNPS)
C
      DIMENSION AXIPS(NRADVO),AXIWND(NRADVO,NCMPVO),AXIRAD(NRADVO),
     1          NRDSTR(NRADVO)
C
      DIMENSION SPLDTA(LDXDIM),WDZ(LDXDIM),YDZ(LDXDIM),SPLFIT(NDIM+1),
     1          SPLNOD(NDIM+1)
C
      NAMELIST/COMPRM/DELTAR,RADBIN,NRBIN,NABIN,NLBIN,PBIN
C
C     DELRPS IS THE HARDWIRED RADIAL BIN SEPARATION (KM)
C     HUNDKM IS ONE HUNDRED KM IN METERS
C     EPSPS IS THE TOLERANCE FOR 1-D FITTED SPLINE FITTED DATA
C       TO BE CLASSIFIED AS INCREASING OR DECREASING
C     EPSRD IS SUBTRACTED FROM RADII TO DETERMINE COMPOSITING BIN
C     IPLVL IS PRINT OUTPUT LEVEL FOR 1-D FILTERED SPLINE: 0=NO PRINT,
C             - 1: DATA LISTINGS, 2: DATA LISTINGS AND GRAPHS
C
      DATA PSET/1100.,900.,700.,300.,100./,OUTMAP/4,1,3,2/,DELRPS/50./,
     1     FIRST/.TRUE./,ITMXPS/8/,EPSPS/0.40/,HUNDKM/1.E5/,EPSRD/1.0/,
     2     IPLVL/2/
C
C     NRADBN: MAXIMUM NUMBER OF SLOTS RADIALLY
C     NAZIBN:   "       "    "    "   AZIMUTHALLY
C     NCORBN:   "       "    "    "   FOR COORDINATES
C             (1=EARTH ORIENTED: NE, SE, SW, NW
C              2=STORM DIRECTION ORIENTED: AHEAD RIGHT, BEHIND RIGHT
C                                          BEHIND LEFT, AHEAD LEFT
C     NVARBN: MAXIMUM NUMBER OF SLOTS FOR VARIABLES
C             (1=TANGENTIAL WIND, 2=RADIAL WIND, 3=WIND SPEED)
C
C     INPUT DATA IS IN "DATA" ARRAY. CURRENTLY WE EXPECT THREE SLOTS:
C        1: U (ZONAL WIND)   2: V (MERIDIONAL WIND)  3: SURFACE PRES.
C

C-----------------------------------------------------------------------

      ENTRY SETCOM(NDATAZ,IUNTDH,STMDRZ,STMSPZ,PTOPZ,RMXCOM,RMAXZ,RPOT,
     1             ONLYWI,ONLYPS,STMNMZ)
      NDATA=NDATAZ
C
C     SAVE STORM PARAMETERS INCLUDING RMAX, DIRECTION AND SPEED
C       AT THE COMPOSITING TIME
C
      NOBWND=0
      NOBPS=0
      STMDR0=STMDRZ
      STMSP0=STMSPZ
      PTOP=PTOPZ
      RMAXM=RMAXZ*1.E3
      RPOTM=RPOT*1.E3
      CALL DS2UV(USTM,VSTM,STMDR0,STMSP0)
      WRITE(6,1) STMNMZ,PTOP,USTM,VSTM,STMDR0,STMSP0,RMXCOM,
     1           ONLYWI,ONLYPS
    1 FORMAT(//30X,'***********************************************'/
     1         30X,'***********************************************'/
     2         30X,'****  COMPOSITE ANALYSIS OF OBSERVATIONS   ****'/
     3         30X,'****     WITHIN THE TROPICAL CYCLONE       ****'/
     4         30X,'****     ENVIRONMENT.  STORM=',A,2X,'****'/
     5         30X,'***********************************************'/
     6         30X,'***********************************************'//
     7         ' ...ENTERING SETCOM, PTOP,USTM,VSTM,STMDR0,STMSP0,',
     8         'RMXCOM(KM),ONLYWI,ONLYPS=',5F8.2,-3PF8.2,2L3)
C
      IF(.NOT. ONLYWI)  GO TO 60
C
C     INITIALIZE STORAGE
C
      COMDAT=0.0
      NCOMDT=0
      NSTOR=0
      NAZIAV=0
      AZIAVW=0.0
C
C     SET COUNTER FOR OBS PROCESSED BUT NOT PRINTED IN DATA LIST
C
      NMSNG=0
C
C     DEFAULT BIN SETUP
C
      NRBIN=NRADBN
      NABIN=4
      NLBIN=4
      NLBIN1=NLBIN+1
      WRITE(6,3)
    3 FORMAT(/'...SETTING UP PRESSURE BINS:')
      DO 5 NL=1,NLBIN1
      PBIN(NL)=PSET(NL)
      WRITE(6,4) NL,PBIN(NL)
    4 FORMAT('...NL,PBIN=',I5,F10.2)
    5 CONTINUE
C
C     DEFAULT RADIAL BINS ARE 100 KM EQUALLY DISTANT
C
      DELTAR=100.E3

      RBIN(1:NRADBN)=1.E10
C
C     CHANGE BIN SETUP BY READING INPUT NAMELIST
C
      IF(FIRST)  THEN
         READ(5,COMPRM)
         WRITE(6,COMPRM)
      END IF
      FIRST=.FALSE.
C
C     DEFINE SECTOR WIDTH
C
      ASECTR=360./REAL(NABIN)
C
C     CHECK NUMBER OF DATA SLOTS ONCE AND FOR ALL
C
      IF(NDATA .GT. NVARBN)  THEN
      WRITE(6,16) NDATA,NVARBN
   16 FORMAT(/'...NUMBER OF PIECES OF DATA TO BE COMPOSITED EXCEEDS',
     1       ' AVAILABLE SPACE, NDATA, NVARBN=',2I5)
      CALL ABRT1(' SETCOM',16)
      ENDIF
C
      IF(NRBIN .GT. NRADBN)  THEN
      WRITE(6,17) NRBIN,NRADBN
   17 FORMAT(/'...NUMBER OF RADIAL BINS EXCEEDS AVAILABLE SPACE',
     1       ' NRBIN, NRADBN=',2I5)
      CALL ABRT1(' SETCOM',17)
      ENDIF
C
      IF(NABIN .GT. NAZIBN)  THEN
      WRITE(6,18) NABIN,NAZIBN
   18 FORMAT(/'...NUMBER OF AZIMUTHAL BINS EXCEEDS AVAILABLE SPACE',
     1       ' NABIN, NAZIBN=',2I5)
      CALL ABRT1(' SETCOM',18)
      ENDIF
C
C     WHEN THE INPUT RADIUS INCREMENT IS NEGATIVE, UNEQUAL RADIAL
C       SPACING IS ASSUMED. INPUT IS VIA NAMELIST
C
      IF(DELTAR .LE. 0)  THEN
      EQLDR=.FALSE.
C
      RBIN(0)=0.0
      DO 30 NRB=1,NRBIN
      RBIN(NRB)=RADBIN(NRB)
      IF(NRB .GT. 1)  THEN
        IF(RBIN(NRB) .LE. RBIN(NRB-1))  THEN
        WRITE(6,27) NRB,RBIN(NRB),RBIN(NRB-1)
   27   FORMAT(/'******ERROR IN BIN SETUP, RADII DECREASE OUTWARD,',
     1         ' NRB, RBIN(NRB),RBIN(NRB-1)=',/,10X,I5,2F12.3)
        ENDIF
        CALL ABRT1(' SETCOM',27)
      ENDIF
   30 CONTINUE
      ELSE
      EQLDR=.TRUE.
C
      DO 40 NRB=0,NRBIN
      RBIN(NRB)=REAL(NRB)*DELTAR
   40 CONTINUE
      ENDIF
C
C     **** IMPORTANT NOTE: WE RE-DEFINE NUMBER OF RADIAL BINS
C                          TO MATCH RMXCOM, THE MAXIMUM RADIUS
C                          WITHIN WHICH COMPOSITING WILL TAKE
C                          PLACE FOR EACH STORM  ****
C
      NRBINZ=NRBIN
      NRBRPT=1
      DO 50 NRB=1,NRBINZ
      NRBIN=NRB
C
C     FIND THE BIN INDEX CORRESPONDING TO RPOT
C
      IF(NRB .LT. NRBINZ)  THEN
c && 3 comments
CC    WRITE(6,47) NRB,RPOTM,RBIN(NRB),RBIN(NRB+1)
CC 47 FORMAT('...CHECKING FOR RPOT BIN: NRB,RPOT,RBIN(NRB),',
CC   1       'RBIN(NRB+1)=',I4,-3P,3F12.1)
      IF(RBIN(NRB) .LE. RPOTM .AND. RBIN(NRB+1) .GT. RPOTM)
     1   NRBRPT=NRB
      ENDIF
C
      IF(RBIN(NRB) .GT. RMXCOM)  GO TO 55
   50 CONTINUE
      WRITE(6,51) RBIN(NRBIN),RMXCOM,NRBIN
   51 FORMAT(/'######MAXIMUM BIN RADIUS=',-3PF9.2,' KM IS NOT LARGE ',
     1       'ENOUGH TO ENCOMPASS RMXCOM=',F9.2,' KM.',/,8X,'MAKE',
     2       'PARAMETER NRADBN LARGER THAN',I5)
C
   55 CONTINUE
C
      WRITE(6,57) (NR,RBIN(NR),NR=1,NRBIN)
   57 FORMAT(/'...SETTING UP RADIAL BINS (KM) FOR WIND:',/,
     1       (' ...NR,RBIN=',I5,-3PF10.2))
      WRITE(6,59) RPOT,NRBRPT
   59 FORMAT(/'...RADIAL BIN INDEX CORRESPONDING TO RPOT=',F7.2,
     1       ' IS',I3)
C
   60 IF(.NOT. ONLYPS)  RETURN
      PSCLOS =-9999.9
      HOWFMN=1.E10
      DRPSM =DELRPS*1.E3
      NVRPS =6
      NCOMPS=1
      DIFMN =1.E10
C
      DO 65 NRPS=1,NRBNPS
      NBINPS=NRPS
      RPSBIN(NRPS)=DRPSM*REAL(NRPS)
        IF(ABS(RPSBIN(NRPS)-RMAXM) .LT. DIFMN)  THEN
        NPSRMX=NRPS
        DIFMN=ABS(RPSBIN(NRPS)-RMAXM)
        ENDIF
C
      PSBIN (NRPS,:)=0.0
      NPSBIN(NRPS,:)=0
C
      IF(RPSBIN(NRPS) .GT. RMXCOM)  GO TO 70
   65 CONTINUE
      WRITE(6,66) NRBNPS,DRPSM,RMXCOM
   66 FORMAT('######WARNING: MAXIMUM NUMBER OF SFC PRES BINS IS ',
     1       'NOT SUFFICIENT TO SPAN RMXCOM.',/,7X,' NO. BINS, DRPSM,',
     2       ' RMXCOM=',I5,2E12.3)
C
   70 CONTINUE
      NPSRM1=NPSRMX+1
C
      WRITE(6,73) (NR,RPSBIN(NR),NR=1,NBINPS)
   73 FORMAT(/'...SETTING UP RADIAL BINS (KM) FOR SURFACE PRESSURE:',/,
     1       (' ...NR,RPSBIN=',I5,-3PF10.2))
      RETURN
C

C-----------------------------------------------------------------------

      ENTRY OWNCOM(IPRTZ,IHOWFR,ANGLE,RLAT,RLON,PRESR,IRTYP,NDATAZ,DATA)
      IPRT=IPRTZ
      IF(IPRT .GT. 0)
     1        WRITE(6,101) IHOWFR,ANGLE,PRESR,(DATA(N),N=1,2)
  101 FORMAT('...ENTERING OWNCOM, IHOWFR,ANGLE,PRESR,DATA=',I12,2F12.2/
     1       (14X,5F12.3))
C
      ANGZ=ANGLE
      DO 170 NCOR=1,NCORBN
C
C     NCOR=1 : EARTH COORDINATE SYSTEM
C     NCOR=2 : STORM-RELATIVE SYSTEM (STORM SPEED SUBTRACTED OUT)
C
      IF(NCOR .EQ. 1)  THEN
      NAZ =IFIX(ANGZ/ASECTR)+1
C
      IF(EQLDR)  THEN
        NRA=INT((IHOWFR-NINT(EPSRD))/DELTAR)+1
        IF(NRA .GT. NRADBN)  THEN
        WRITE(6,107) IHOWFR,DELTAR,NRA,NRADBN
  107   FORMAT('******NRA EXCEEDS LIMITS IHOWFR,DELTAR,NRA=',
     1         I13,F13.2,2I7,/,10X,'OBSERVATION WILL NOT BE PROCESSED')
        RETURN
        ENDIF
      ELSE
      DO 110 NRAZ=1,NRBIN
      NRA=NRAZ
      IF(REAL(IHOWFR) .LE. RBIN(NRAZ))  GO TO 115
  110 CONTINUE
      WRITE(6,111) NRA,IHOWFR,RBIN(NRA)
  111 FORMAT('******EXCEEDED FORMAL SETUP OF RADIAL BINS, NRA,',
     1       'IHOWFR,RBIN(NRA)=',I5,I12,F12.3)
      NRA=MIN(NRBIN+1,NRADBN)
      WRITE(6,112) NRA,NRADBN
  112 FORMAT('...THE FIX IS TO PLACE OBS IN BIN=',I5,' WHERE',
     1       ' MAXIMUM BIN=',I5)
C
      ENDIF
C
  115 DO 130 NLBZ=1,NLBIN
      NLB=NLBZ
      IF(NINT(PRESR*10.) .LT. NINT(PBIN(NLBZ)*10.) .AND.
     $   NINT(PRESR*10.) .GE. NINT(PBIN(NLBZ+1)*10.))  GO TO 140
  130 CONTINUE
      WRITE(6,131) NLB,PRESR,PBIN(NLB)
  131 FORMAT('******EXCEEDED FORMAL SETUP OF VERTICAL BINS, NLB,',
     1       'PRESR,PBIN(NLB)=',I5,2F12.3)
      NLB=MIN(NLBIN1+1,NLVLBN)
      WRITE(6,132) NLB,NLVLBN
  132 FORMAT('...THE FIX IS TO PLACE OBS IN BIN=',I5,' WHERE',
     1       ' MAXIMUM BIN=',I5)
C
C     FOR STORM RELATIVE COORDINATE, WE CALCULATE THE ANGLE WITH RESPECT
C       TO THE STORM MOTION AND SUBTRACT OUT THE STORM MOTION.
C
      ELSE IF(NCOR .EQ. 2) THEN
      NAZ=IFIX(MOD(360.-STMDR0+ANGZ,360.)/ASECTR)+1
      DATA(1)=DATA(1)-USTM
      DATA(2)=DATA(2)-VSTM
      ELSE
      WRITE(6,137) NCOR,NCORBN
  137 FORMAT(/'******ILLEGAL VALUE OF NCOR=',I5,' NCORBN=',I5)
      CALL ABRT1(' OWNCOM',137)
      ENDIF
C
  140 CONTINUE
      IF(IPRT .GT. 0)
     1      WRITE(6,151) NCOR,NAZ,NRA,NLB,(DATA(N),N=1,2)
  151 FORMAT('...GOING TO STORE COMPOSITED DATA, NCOR,NAZ,NRA,NLB,',
     1       'DATA=',4I5,/,(10X,5F12.3))
C
      CALL UVRTCN(ANGZ,DATA(1),DATA(2),VRAD,VTAN)
      IF(IPRT .GT. 0)
     1      WRITE(6,161) NCOR,ANGZ,DATA(1),DATA(2),VRAD,VTAN
  161 FORMAT('...U,V TO RAD, TAN: NCOR,ANGZ,UWIND,VWIND,VRAD,VTAN=',/,
     1       10X,I3,5F12.3)
C
C     STORE DATA
C
      COMDAT(NRA,NAZ,NLB,NCOR,1)=COMDAT(NRA,NAZ,NLB,NCOR,1)+VRAD
      COMDAT(NRA,NAZ,NLB,NCOR,2)=COMDAT(NRA,NAZ,NLB,NCOR,2)+VTAN
      COMDAT(NRA,NAZ,NLB,NCOR,3)=COMDAT(NRA,NAZ,NLB,NCOR,3)+
     1                           SQRT(VRAD**2+VTAN**2)
      NCOMDT(NRA,NAZ,NLB,NCOR,1)=NCOMDT(NRA,NAZ,NLB,NCOR,1)+1
C
C     STORE THE DATA VALUES BY RADIAL BIN AND LEVEL
C
      IF(NCOR .EQ. 1)  THEN
        IF(NSTOR(NRA,NLB) .LT. NDATMX)  THEN
        NSTOR(NRA,NLB)=NSTOR(NRA,NLB)+1
        NOBWND=NOBWND+1
        NCOM=NSTOR(NRA,NLB)
        RADDAT( 1,NCOM,NRA,NLB)=RLAT
        RADDAT( 2,NCOM,NRA,NLB)=RLON
        RADDAT( 3,NCOM,NRA,NLB)=PRESR
        RADDAT( 4,NCOM,NRA,NLB)=REAL(IRTYP)
        RADDAT( 5,NCOM,NRA,NLB)=DATA(1)
        RADDAT( 6,NCOM,NRA,NLB)=DATA(2)
        CALL UV2DS(DATA(1),DATA(2),DIRZ,SPDZ)
        RADDAT( 7,NCOM,NRA,NLB)=DIRZ
        RADDAT( 8,NCOM,NRA,NLB)=SPDZ
        RADDAT( 9,NCOM,NRA,NLB)=VRAD
        RADDAT(10,NCOM,NRA,NLB)=VTAN
        RADDAT(11,NCOM,NRA,NLB)=ANGZ
        ELSE
        NMSNG=NMSNG+1
        WRITE(6,169) NRA,NLB,NSTOR(NRA,NLB),NDATMX,NMSNG
  169   FORMAT('******STORAGE FOR OBSERVATIONS EXCEEDED, NRA,NLB,',
     1         'NSTOR,NDATMX,NONPRINTED OBS=',5I6)
        ENDIF
C
        ELSE
        RADDAT(12,NCOM,NRA,NLB)=SQRT(VRAD**2+VTAN**2)
        RADDAT(13,NCOM,NRA,NLB)=VRAD
        RADDAT(14,NCOM,NRA,NLB)=VTAN
        RADDAT(15,NCOM,NRA,NLB)=MOD(360.-STMDR0+ANGZ,360.)
        RADDAT(16,NCOM,NRA,NLB)=REAL(IHOWFR)
      ENDIF
  170 CONTINUE
      RETURN
C

C-----------------------------------------------------------------------

      ENTRY OPSCOM(IPRTZ,IHOWFR,ANGLE,RLAT,RLON,IRTYP,NDATAZ,DATA)
C
      IPRT=IPRTZ
      NOBPS=NOBPS+1
      NRAPS=MIN(1+INT(IHOWFR/DRPSM),NBINPS)
      NPSBIN(NRAPS,NCOMPS)=NPSBIN(NRAPS,NCOMPS)+1
      IF(NPSBIN(NRAPS,NCOMPS).GT. NDATMX)  THEN 
         print *, 'NDATMX limit (',NDATMX,') exceeded - ',
     $    'NPSBIN(NRAPS,NCOMPS)=',NPSBIN(NRAPS,NCOMPS),', return'
         return
      endif
      PSBIN(NRAPS,NCOMPS)=PSBIN(NRAPS,NCOMPS)+DATA(3)
      PSDAT(1,NPSBIN(NRAPS,NCOMPS),NRAPS)=RLAT
      PSDAT(2,NPSBIN(NRAPS,NCOMPS),NRAPS)=RLON
      PSDAT(3,NPSBIN(NRAPS,NCOMPS),NRAPS)=REAL(IHOWFR)
      PSDAT(4,NPSBIN(NRAPS,NCOMPS),NRAPS)=ANGLE
      PSDAT(5,NPSBIN(NRAPS,NCOMPS),NRAPS)=REAL(IRTYP)
      PSDAT(6,NPSBIN(NRAPS,NCOMPS),NRAPS)=DATA(3)
C
C     PICK UP CLOSEST SURFACE PRESSURE OBSERVATION TO
C       THE STORM CENTER AND ANGLE
C
      IF(REAL(IHOWFR) .LT. HOWFMN)  THEN
      HOWFMN=REAL(IHOWFR)
      ANGLMN=ANGLE
      PSCLOS=DATA(3)
      ENDIF
C
      IF(IPRT .GT. 0) WRITE(6,191) RLAT,RLON,IRTYP,REAL(IHOWFR),DATA(3),
     1                 NRAPS,NBINPS,DRPSM,NPSBIN(NRAPS,NCOMPS),
     2                 PSBIN(NRAPS,NCOMPS)
  191 FORMAT('....COMPOSITING PSFC, RLAT,RLON,IRTYP,IHOWFR(KM),',
     1       'DATA(3),NRAPS,NBINPS,DRPSM(KM),NPSBIN(NRAPS,NCOMPS),',
     2       'PSBIN=',/,7X,2F9.2,I5,-3PF10.3,0P,F9.3,2I5,-3PF8.2,I5,
     3       0P,F14.2)
C
      RETURN
C

C-----------------------------------------------------------------------

      ENTRY VPSCOM(AXIPS,AXIRAD,NRDSTR,NRADVO)
C
      NCOMPS=2
C     NRMXPS=-1
C     NRMXWN=-1
c && 6 comments
CC    WRITE(6,201) (AXIPS(NRA),NRA=1,NRADVO)
CC201 FORMAT(/'...ENTERING VPSCOM WITH SURFACE PRESSURE=',/,
CC   1       (5X,10F10.2))
CC    WRITE(6,203) (AXIRAD(NRA),NRA=1,NRADVO)
CC203 FORMAT(/'...ENTERING VPSCOM WITH RADII=',/,
CC   1       (5X,10F10.2))
C
      DO 230 NRADV=1,NRADVO
C
      NRAPS=MIN(1+IFIX(AXIRAD(NRADV)/DRPSM),NBINPS)
C     NRMXPS=MAX(NRAPS,NRMXPS)
      NPSBIN(NRAPS,NCOMPS)=NPSBIN(NRAPS,NCOMPS)+1
      PSBIN (NRAPS,NCOMPS)=PSBIN (NRAPS,NCOMPS)+AXIPS(NRADV)
C
C     SET RADIAL BIN INDICES FOR WINDS ONCE AND FOR ALL
C
      IF(EQLDR)  THEN
      NRA=IFIX((AXIRAD(NRADV)-EPSRD)/DELTAR)+1
        IF(NRA .GT. NRADBN)  THEN
        WRITE(6,207) AXIRAD(NRADV),DELTAR,NRA,NRADBN
  207   FORMAT('******NRA EXCEEDS LIMITS FOR COMPOSITING VORTEX, ',
     1         'AXIRAD,DELTAR,NRD=',2F13.2,2I7,/,10X,
     2         'VORTEX DATA WILL NOT BE PROCESSED')
        RETURN
        ENDIF
      ELSE
      DO 210 NRAZ=1,NRBIN
      NRA=NRAZ
      IF(AXIRAD(NRADV) .LE. RBIN(NRAZ))  GO TO 220
  210 CONTINUE
      WRITE(6,211) NRA,IHOWFR,RBIN(NRA)
  211 FORMAT('******EXCEEDED FORMAL SETUP OF RADIAL BINS, NRA,',
     1       'IHOWFR,RBIN(NRA)=',I5,I12,F12.3)
      NRA=MIN(NRBIN+1,NRADBN)
      WRITE(6,212) NRA,NRADBN
  212 FORMAT('...THE FIX IS TO PLACE OBS IN BIN=',I5,' WHERE',
     1       ' MAXIMUM BIN=',I5)
C
      ENDIF
C
  220 NRDSTR(NRADV)=NRA
C     NRMXWN=MAX(NRA,NRMXWN)
C
      IF(IPRT .GT. 0)  WRITE(6,229) NRADV,NRAPS,NPSBIN(NRAPS,NCOMPS),
     1                 AXIRAD(NRADV),AXIPS(NRADV),RPSBIN(NRAPS),
     2                 NRA,NRDSTR(NRADV)
  229 FORMAT('...COMPOSITING VORTEX PSFC: NRADV,NRAPS,NPSBIN,AXIRAD,',
     1       'AXIPS,RPSBIN,NRA,NRDSTR(NRADV)=',/,10X,3I5,3F10.2,2I5)
  230 CONTINUE
      RETURN
C

C-----------------------------------------------------------------------

      ENTRY VWNCOM(NRADVO,NCMPVO,PRESVO,AXIWND,nrdstr)
C
c && 6 comments
CC    WRITE(6,301) NRADVO,NCMPVO,PRESVO
CC301 FORMAT(/'...ENTERING VWNCOM WITH NRADVO,NCMPVO,PRESVO=',2I5,F9.1)
CC    DO NC=1,NCMPVO
CC    WRITE(6,303) NC,(AXIWND(NR,NC),NR=1,NRADVO)
CC303 FORMAT(/'...NC,AXIWND=',I3,(15F7.1,/))
CC    ENDDO
C
      DO 310 NLBZ=1,NLBIN
         NLB=NLBZ
         IF(NINT(PRESVO*10.) .LT. NINT(PBIN(NLBZ)*10.) .AND.
     $      NINT(PRESVO*10.) .GE. NINT(PBIN(NLBZ+1)*10.))  GO TO 320
  310 CONTINUE
      WRITE(6,311) NLB,PRESVO,PBIN(NLB)
  311 FORMAT('******EXCEEDED FORMAL SETUP OF VERTICAL BINS, NLB,',
     1       'PRESVO,PBIN(NLB)=',I5,2F12.3)
      NLB=MIN(NLBIN1+1,NLVLBN)
      WRITE(6,313) NLB,NLVLBN
  313 FORMAT('...THE FIX IS TO PLACE OBS IN BIN=',I5,' WHERE',
     1       ' MAXIMUM BIN=',I5)
C
  320 CONTINUE
      IF(IPRT .GT. 0)  WRITE(6,321) NLB,PBIN(NLB),PBIN(NLB+1)
  321 FORMAT(/'...COMPOSITING VORTEX WIND: PRESSURE, NLB,PBIN(NLB),',
     1       'PBIN(NLB+1)=',I5,2F10.2)
C
C     ****  SET UP FOR COMPOSITING TANGENTIAL WIND ONLY  ****
C     ****  IMPORTANT NOTE: WE DO NOT COMPOSITE THE CENTRAL WIND
C                           (INDEX=1) SINCE IT IS IDENTICALLY ZERO
C
      DO 350 NRADV=2,NRADVO
         NCOM=NRDSTR(NRADV)
         AZIAVW(NCOM,1,NLB,2)=AZIAVW(NCOM,1,NLB,2)+AXIWND(NRADV,1)
cdak  fix 9/5/14 vvvvvvvvvv
c---------------------------------------------------------------------
c changes here to prevent array overflow in 2nd element of AXIWND when
c  this entry is called out of subroutine MM2DVO where NCMPVO is passed
c  in with value of 1 and debugging is turned on at run time
c (Note: may not be correct solution but yields same output bogus winds
c        as when this change is not made and code runs w/o debugging
c        turned on at run time  --> this fix allows code to run to
c        completion when debugging is turned on at run time)
c---------------------------------------------------------------------
cccccc   AZIAVW(NCOM,2,NLB,2)=AZIAVW(NCOM,2,NLB,2)+AXIWND(NRADV,2)
cccccc   AZIAVW(NCOM,3,NLB,2)=AZIAVW(NCOM,3,NLB,2)+
ccccc1                       SQRT(AXIWND(NRADV,1)**2+AXIWND(NRADV,2)**2)
         if(NCMPVO.gt.1) then
            AZIAVW(NCOM,2,NLB,2)=AZIAVW(NCOM,2,NLB,2)+AXIWND(NRADV,2)
            AZIAVW(NCOM,3,NLB,2)=AZIAVW(NCOM,3,NLB,2)+
     1                      SQRT(AXIWND(NRADV,1)**2+AXIWND(NRADV,2)**2)
         endif
         NAZIAV(NCOM,NLB,2)=NAZIAV(NCOM,NLB,2)+1
         IF(IPRT .GT. 0)  THEN
ccccc       WRITE(6,349) NRADV,NCOM,AXIWND(NRADV,1),AXIWND(NRADV,2)
            if(NCMPVO.gt.1) then
               WRITE(6,349) NRADV,NCOM,AXIWND(NRADV,1),AXIWND(NRADV,2)
            else
               WRITE(6,349) NRADV,NCOM,AXIWND(NRADV,1)
            endif
cdak  fix 9/5/14 ^^^^^^^^^^
         ENDIF
  349 FORMAT('...COMPOSITING AXISYMMETRIC WIND, NRADV,NCOM,AXIWND=',
     1       2I5,2F10.2)
  350 CONTINUE
C
      RETURN
C

C-----------------------------------------------------------------------

      ENTRY ANLCOM(RPOT,SPDPOT,NOBWMN,IUNTDH,ONLYWI,ONLYPS)
C
      SPDPOT=-99.0
      IF(.NOT. ONLYWI)  GO TO 500
C
      DO NCOR=1,NCORBN
      IF(NCOR .EQ. 1)  WRITE(6,404)
      IF(NCOR .EQ. 2)  WRITE(6,406)
  404 FORMAT(////33X,'**** WIND COMPOSITE: EARTH COORDINATES ****')
  406 FORMAT(////32X,'**** WIND COMPOSITE: STORM RELATIVE COORDINATES ',
     1       '****')
C
      NAZIAV(1:NRBIN,1:NLBIN,1)=0
      AZIAVW(1:NRBIN,:,1:NLBIN,1)=0.0
C
      DO  NL=1,NLBIN
      NL1=NL+1
      IF(NINT(PTOP*10.) .GE. NINT(PBIN(NL)*10.))  GO TO 450
      WRITE(6,413) NL,PBIN(NL),PBIN(NL1)
  413 FORMAT(//21X,'*****   NL=',I3,' LAYER BOUNDED BY PRESSURES',F10.1,
     1       ' AND',F10.1,3X,'*****')
C
      DO 440 NA=1,NABIN,2
      NAZ1=OUTMAP(NA)
      NAZ2=OUTMAP(NA+1)
      DO 430 NR=1,NRBIN
      PRNT=.FALSE.

      OUTPRT=-9999.9

      IF(NCOMDT(NR,NAZ1,NL,NCOR,1) .NE. 0) THEN
      PRNT=.TRUE.
C
      NAZIAV(NR,NL,1)=NAZIAV(NR,NL,1)+NCOMDT(NR,NAZ1,NL,NCOR,1)
      DO 421 NV=1,NVARBN
      AZIAVW(NR,NV,NL,1)=AZIAVW(NR,NV,NL,1)+COMDAT(NR,NAZ1,NL,NCOR,NV)
  421 CONTINUE
C
      COMDAT(NR,NAZ1,NL,NCOR,1)=COMDAT(NR,NAZ1,NL,NCOR,1)/
     1                          REAL(NCOMDT(NR,NAZ1,NL,NCOR,1))
      COMDAT(NR,NAZ1,NL,NCOR,2)=COMDAT(NR,NAZ1,NL,NCOR,2)/
     1                          REAL(NCOMDT(NR,NAZ1,NL,NCOR,1))
      COMDAT(NR,NAZ1,NL,NCOR,3)=COMDAT(NR,NAZ1,NL,NCOR,3)/
     1                          REAL(NCOMDT(NR,NAZ1,NL,NCOR,1))
      OUTPRT(1)=COMDAT(NR,NAZ1,NL,NCOR,1)
      OUTPRT(2)=COMDAT(NR,NAZ1,NL,NCOR,2)
      OUTPRT(3)=COMDAT(NR,NAZ1,NL,NCOR,3)
      ENDIF
C
      IF(NCOMDT(NR,NAZ2,NL,NCOR,1) .NE. 0) THEN
      PRNT=.TRUE.
C
      NAZIAV(NR,NL,1)=NAZIAV(NR,NL,1)+NCOMDT(NR,NAZ2,NL,NCOR,1)
      DO 423 NV=1,NVARBN
      AZIAVW(NR,NV,NL,1)=AZIAVW(NR,NV,NL,1)+COMDAT(NR,NAZ2,NL,NCOR,NV)
  423 CONTINUE
C
      COMDAT(NR,NAZ2,NL,NCOR,1)=COMDAT(NR,NAZ2,NL,NCOR,1)/
     1                          REAL(NCOMDT(NR,NAZ2,NL,NCOR,1))
      COMDAT(NR,NAZ2,NL,NCOR,2)=COMDAT(NR,NAZ2,NL,NCOR,2)/
     1                          REAL(NCOMDT(NR,NAZ2,NL,NCOR,1))
      COMDAT(NR,NAZ2,NL,NCOR,3)=COMDAT(NR,NAZ2,NL,NCOR,3)/
     1                          REAL(NCOMDT(NR,NAZ2,NL,NCOR,1))
      OUTPRT(4)=COMDAT(NR,NAZ2,NL,NCOR,1)
      OUTPRT(5)=COMDAT(NR,NAZ2,NL,NCOR,2)
      OUTPRT(6)=COMDAT(NR,NAZ2,NL,NCOR,3)
      ENDIF
      IF(NR .EQ. 1)  WRITE(6,425) NAZ1,NAZ2
  425 FORMAT(/26X,'QUADRANT=',I2,18X,'|',19X,'QUADRANT=',I2,25X,'|',
     1 /,8X,'RADIUS(KM)',4X,'VRAD',6X,'VTAN',5X,'SPEED',3X,'#OBS  |',
     2   8X,'RADIUS(KM)',4X,'VRAD',6X,'VTAN',5X,'SPEED',3X,'#OBS  |')
      IF(PRNT)  WRITE(6,427) NR,RBIN(NR),OUTPRT(1),OUTPRT(2),OUTPRT(3),
     1                       NCOMDT(NR,NAZ1,NL,NCOR,1),
     2                       NR,RBIN(NR),OUTPRT(4),OUTPRT(5),OUTPRT(6),
     3                       NCOMDT(NR,NAZ2,NL,NCOR,1)
  427 FORMAT(4X,I5,-3P,F7.1,0P,3F10.2,3X,I4,'  |',
     1       4X,I5,-3P,F7.1,0P,3F10.2,3X,I4,'  |')
  430 CONTINUE
      WRITE(6,437)
  437 FORMAT(/7X,'________________________________________________|'
     1      ,'_______________________________________________________|')
  440 CONTINUE
C
      DO 448 NR=1,NRBIN
C
      IF(NAZIAV(NR,NL,1) .GT. 0)  THEN
      DO 443 NV=1,NVARBN
      AZIAVW(NR,NV,NL,1)=AZIAVW(NR,NV,NL,1)/REAL(NAZIAV(NR,NL,1))
  443 CONTINUE
C
C     CALCULATE STANDARD DEVIATIONS
C
      INDZ=8
      NSMX=NSTOR(NR,NL)
        IF(NSMX .GE. 2)  THEN

        STDZ(1:NSMX)=RADDAT(INDZ,1:NSMX,NR,NL)

        CALL STDEV(STDZ,NSMX,NSMX-1,AZIAVW(NR,3,NL,1),STDAZW(NR,3,NL))
c && 3 comments
CC      WRITE(6,4445) NR,NL,NSMX,AZIAVW(NR,3,NL,1),STDAZW(NR,3,NL)
C4445   FORMAT(/'...CALCULATING STANDARD DEVIATION, NR,NL,NSMX,AVG,',
CC   1         'STDEV=',/,6X,3I5,2F10.2)
C
        ELSE
        STDAZW(NR,3,NL)=-9999.9
        ENDIF
      ELSE
      STDAZW(NR,3,NL)=-9999.9
      AZIAVW(NR,:,NL,1)=-9999.9
C
      ENDIF
  448 CONTINUE
C
C       EXTRACT THE OBSERVED AZIMUTHALLY AVERAGED LOWEST LEVEL WIND
C         IF THERE ARE SUFFICIENT OBSERVATIONS
C
      IF(NL .EQ. 1)  THEN
      IF(NAZIAV(NRBRPT  ,NL,1) .GE. NOBWMN .AND.
     1   NAZIAV(NRBRPT+1,NL,1) .GE. NOBWMN)  THEN
      SPDPOT=AZIAVW(NRBRPT,3,NL,1)+(AZIAVW(NRBRPT+1,3,NL,1)-
     1       AZIAVW(NRBRPT,3,NL,1))*(RPOTM-RBIN(NRBRPT))/
     2       (RBIN(NRBRPT+1)-RBIN(NRBRPT))
      ENDIF
      ENDIF
C
  450 CONTINUE
      ENDDO
      ENDDO
C
      WRITE(6,451)
  451 FORMAT(////30X,'**** LISTING OF WIND OBSERVATIONS FOLLOWS ****'/)
      WRITE(IUNTDH,453) NOBWND
  453 FORMAT(' WIND...NUMBER OF OBSERVATIONS=',
     1       I5,/,5X,'LAT',6X,'LONG',3X,'PRESR',2X,'TYPE',3X,'UWIND',
     2       2X,'VWIND',2X,'DIRCTN',3X,'SPD',3X,'VRAD',2X,'VTAN',
     3       3X,'ANGLE',4X,'SPD',3X,'VRAD',3X,'VTAN',2X,'ANGLE',
     4       3X,'DIST',/,64X,2('(E)',4X),'(E)',3X,3('(STR)',2X),'(STR)',
     5       3X,'(KM)')
      DO 480 NL=1,NLBIN
      NL1=NL+1
      IF(NINT(PTOP*10.) .GE. NINT(PBIN(NL)*10.))  GO TO 480
      IF(NL .NE. 1)  THEN
         print *, ' '
         print *, ' '
      ENDIF
      WRITE(6,455) NL,PBIN(NL),PBIN(NL1)
  455 FORMAT(//10X,'*****   NL=',I3,' LAYER BOUNDED BY PRESSURES',F10.1,
     1       ' AND',F10.1,3X,'*****')
      DO 460 NRA=1,NRBIN
      IF(NSTOR(NRA,NL) .GT. 0)  THEN
      WRITE(6,457) RBIN(NRA),NSTOR(NRA,NL)
  457 FORMAT(///10X,'R <',-3PF7.1,' KM   ...NUMBER OF OBSERVATIONS=',
     1       I5,/,12X,'LAT',6X,'LONG',3X,'PRESR',2X,'TYPE',3X,'UWIND',
     2       2X,'VWIND',2X,'DIRCTN',3X,'SPD',3X,'VRAD',2X,'VTAN',
     3       3X,'ANGLE',4X,'SPD',3X,'VRAD',3X,'VTAN',2X,'ANGLE',
     4       3X,'DIST',/,72X,2('(E)',4X),'(E)',3X,3('(STR)',2X),'(STR)',
     5       3X,'(KM)')
C
      WRITE(6,458)  ((RADDAT(NVOUT,NCOM,NRA,NL),NVOUT=1,NVROUT),
     1                NCOM=1,NSTOR(NRA,NL))
  458 FORMAT(5X,'...',F8.3,F9.3,13F7.1,-3P,F8.1,0P)
      WRITE(IUNTDH,459)  ((RADDAT(NVOUT,NCOM,NRA,NL),NVOUT=1,NVROUT),
     1                     NCOM=1,NSTOR(NRA,NL))
  459 FORMAT(1X,F8.3,F9.3,13F7.1,-3P,F8.1,0P)
      ENDIF
  460 CONTINUE
  480 CONTINUE
C
  500 IF(.NOT. ONLYPS)  RETURN
C
      DO 550 NRPS=1,NBINPS
      PSCOM(NRPS,1)=-9999.9
      IF(NPSBIN(NRPS,1) .GT. 0)  PSCOM(NRPS,1)=PSBIN(NRPS,1)/
     1                                         REAL(NPSBIN(NRPS,1))
C
C     CALCULATE STANDARD DEVIATIONS
C
      NSMX=NPSBIN(NRPS,1)
      INDZ=6
      INDR=3
      LDXX=0
      YNT=-99.0
C
      IF(NSMX .GE. 2)  THEN
        DO 544 NS=1,NSMX
        if(ns.GT. NDATMX)  THEN 
           print *, 'NDATMX limit (',NDATMX,') exceeded - NS=',NS,
     $      ', return'
           return
        endif
        
        STDZ(NS)=PSDAT(INDZ,NS,NRPS)
  544   CONTINUE
        CALL STDEV(STDZ,NSMX,NSMX-1,PSCOM(NRPS,1),STDAZP(NRPS))
c && 3 comments
CC      WRITE(6,5445) NRPS,NSMX,PSCOM(NRPS,1),STDAZP(NRPS)
C5445   FORMAT(/'...CALCULATING STANDARD DEVIATION, NR,NSMX,AVG,',
CC   1         'STDEV=',/,6X,2I5,2F10.2)
      ELSE
        STDAZP(NRPS)=-9999.9
      ENDIF
  550 CONTINUE
C
      WRITE(6,551)
  551 FORMAT(////30X,'****  LISTING OF SURFACE PRESSURE OBSERVATIONS ',
     1       'FOLLOWS  ****'/)
      WRITE(IUNTDH,552) NOBPS
  552 FORMAT(' PSFC...NUMBER OF OBSERVATIONS=',
     1       I5,/,5X,'LAT',7X,'LONG',5X,'DIST.',4X,'ANGLE',5X,
     2       'TYPE',4X,'PRESR')
      DO 570 NRPS=1,NBINPS
C 
      if(NPSBIN(NRPS,1) .GT. NDATMX)  THEN
         print *, 'NDATMX limit (',NDATMX,') exceeded - ',
     $    'NPSBIN(NRPS,1)=',NPSBIN(NRPS,1),', return'
         return
      endif

      IF(NPSBIN(NRPS,1) .NE. 0)  THEN
      WRITE(6,553) RPSBIN(NRPS),NPSBIN(NRPS,1)
  553 FORMAT(///30X,'R <',-3PF7.1,' KM   ...NUMBER OF OBSERVATIONS=',
     1       I5,/,38X,'LAT',7X,'LONG',5X,'DIST.',4X,'ANGLE',5X,
     2       'TYPE',4X,'PRESR')
      WRITE(6,557)  ((PSDAT(NVR,NPS,NRPS),NVR=1,NVRPS),
     1                NPS=1,NPSBIN(NRPS,1))
  557 FORMAT(30X,'...',F8.3,3X,F8.3,2X,-3P,F7.1,2X,0P,F7.1,
     1       2X,F7.0,F10.2//)
      WRITE(IUNTDH,558)  ((PSDAT(NVR,NPS,NRPS),NVR=1,NVRPS),
     1                     NPS=1,NPSBIN(NRPS,1))
  558 FORMAT(F8.3,3X,F8.3,2X,-3P,F7.1,2X,0P,F7.1,2X,F7.0,F10.2)
      ENDIF
C
C     STORE OBS FOR SPLINE FITTING
C
      NMSNG=0
      DO 560 NSPL=1,NPSBIN(NRPS,1)
         IF(LDXX+1 .LE. LDXDIM .and.
     $    nspl.le. ndatmx)  then
            LDXX=LDXX+1
            SPLDTA(LDXX)=PSDAT(INDZ,NSPL,NRPS)
            YDZ(LDXX)=PSDAT(INDR,NSPL,NRPS)*1.E-3
            WDZ(LDXX)=1.0
            YNT=MAX(YNT,YDZ(LDXX))
         ELSE
            NMSNG=NMSNG+1
            WRITE(6,559) LDXDIM,ldxx,NDATMX,nspl,NMSNG
  559 FORMAT(/'######STORAGE LIMIT EXCEEDED FOR SPLINE FITTING,',
     1       ' LDXDIM=',I5,'; LDXX=',i5,'; NDATMX=',i5,'; NSPL =',i5,
     2       '; NONPRINTED OBS=',I5)
         ENDIF
  560 CONTINUE
  570 CONTINUE
C
      RETURN
C

C-----------------------------------------------------------------------

      ENTRY ANLVOR(ONLYWI,ONLYPS)
C
      DO 620 NRPS=1,NBINPS
      PSCOM(NRPS,2)=-9999.9
      IF(NPSBIN(NRPS,2) .GT. 0)  PSCOM(NRPS,2)=PSBIN(NRPS,2)/
     1                                         REAL(NPSBIN(NRPS,2))
  620 CONTINUE
C
      DO 680 NL=1,NLBIN
C
      NL1=NL+1
      IF(NINT(PTOP*10.) .GE. NINT(PBIN(NL)*10.))  GO TO 680
C
      DO 670 NR=1,NRBIN
C
      IF(NAZIAV(NR,NL,2) .GT. 0)  THEN
      DO 650 NV=1,NVARBN
      AZIAVW(NR,NV,NL,2)=AZIAVW(NR,NV,NL,2)/REAL(NAZIAV(NR,NL,2))
  650 CONTINUE
C
      ELSE

      AZIAVW(NR,:,NL,2)=-9999.9
C
      ENDIF
  670 CONTINUE
  680 CONTINUE
C
      RETURN
C

C-----------------------------------------------------------------------

      ENTRY FITOBS(IUNTBH,RMAX,PCEN,PENV,ONLYWI,ONLYPS,STMLTZ,STMLNZ,
     1             IDATEZ,IUTCZ,STMNMZ)
C
      WRITE(6,801) STMNMZ,RMAX,PCEN,PENV
  801 FORMAT(///'...ENTERING FITOBS FOR ',A,' WITH RMAX(KM),PCEN,PENV=',
     1       F9.2,2F10.2)
      IF(ONLYPS)  THEN
C
C     SPLINE-FIT OBSERVATIONS IF THERE ARE ANY
C
C     INITIALIZE SPLFIT
C
      SPLFIT=-9999.9
C
      IF(LDXX .GT. 0)  THEN
C
C     IF THERE ARE NO SURFACE PRESSURE POINTS WITHIN RMAX,
C       ADD ONE AT THE CENTER WITH A SMALL COMPARATIVE
C       WEIGHT TO KEEP THE SPLINE FIT SOMEWHAT WELL BEHAVED
C
      RCRIT=HUNDKM
      IF(HOWFMN .GT. RCRIT)  THEN
      LDXX=LDXX+1
      if(LDXX .GT. LDXDIM)  THEN
         print *, 'LDXDIM limit (',LDXDIM,') exceeded - ',
     $    'LDXX=',LDXX,', return'
         return
      endif
      YDZ(LDXX)=0.0
      WDZ(LDXX)=0.1
      SPLDTA(LDXX)=PCEN
      WRITE(6,811) RCRIT,PCEN,PSCLOS,HOWFMN,RMAXM
  811 FORMAT(/'...DUE TO LACK OF OBSERVATIONS INSIDE RCRIT=',-3PF8.2,
     1       ' KM, WE ARE ADDING CENTRAL SFC. PRESSURE.',/,4X,
     2       'ADDED PRESSURE IS',0P,F8.2,' AT CENTER.',/,4X,
     3       'CLOSEST OBSERVATION IS ',F8.2,' MB AT ',-3PF8.2,
     4       ' KM, WHILE RMAX IS',-3PF8.2,' KM.')
      ENDIF
C
      IF(HOWFMN .GT. RMAXM)  THEN
      LDXX=LDXX+1
      if(LDXX .GT. LDXDIM)  THEN
         print *, 'LDXDIM limit (',LDXDIM,') exceeded - ',
     $    'LDXX=',LDXX,', return'
         return
      endif
      YDZ(LDXX)=RMAX
      WDZ(LDXX)=0.1
      SPLDTA(LDXX)=PENV
      WRITE(6,813) RMAXM,PENV,PSCLOS,HOWFMN
  813 FORMAT(/'...DUE TO LACK OF OBSERVATIONS INSIDE RMAX=',-3PF8.2,
     1       ' KM, WE ARE ADDING CENTRAL ENVIRONMENTAL ',
     2       'PRESSURE.',/,4X,'ADDED PRESSURE IS ',0P,F8.2,
     3       ' AT RMAX.',/,4X,'CLOSEST OBSERVATION IS ',F8.2,
     4       ' MB AT ',-3PF8.2,' KM.')
      ENDIF
C
      IVARZ=1
      YNB=0.0
      IYNT=IFIX(YNT/DELRPS)
      YNT=REAL(IYNT+1)*DELRPS
      NX=MIN(IYNT+1,NDIM)
      KYBC1=2
      KYBC2=2
      YBCWL1=3.0
      YBCWL2=3.0
C
      ITERPS=0
      YDCWL=REAL(NINT(RMAX*0.5/DELRPS))
      YDCWMX=REAL(NX/2)
C
C     ITERATE FILTER WAVELENGTH TO PRODUCE AN (ALMOST) INCREASING
C       FUNCTION WITH RADIUS
C
  820 CONTINUE
      ITERPS=ITERPS+1
      WRITE(6,823) ITERPS,NX,YNB,YNT,YDCWL
  823 FORMAT(/'...CALLING XSPLCM WITH ITERPS,NX,YNB,YNT,YDCWL=',
     1       2I5,2F10.2,F7.1)
C
C     SPLINE FITTING WITH DERIVATIVE CONSTRAINT.  INPUT PARAMETERS ARE:
C       NX - NUMBER OF NODAL INTERVALS. NODES ARE SET UP TO CORRESPOND
C            TO COMPOSITING BINS FOR THE VARIABLE BEING FITTED, EXCEPT
C            THAT THE FIRST BIN CORRESPONDS TO RADIUS = 0.
C       YNB - CENTER, AT RADIUS=0
C       YNT - MAXIMUM RADIUS (KM)
C       YDCWL - FILTER WAVELENGTH, UNITS ARE # OF NODAL INTERVALS
C       KYBC1 - INNER BOUNDARY CONDITION
C       KYBC2 - OUTER BOUNDARY CONDITION
C       YBCWL1 - INNER BOUNDARY CONDITION WAVELENGTH
C       YBCWL2 - OUTER BOUNDARY CONDITION WAVELENGTH
C       SPLDATA - INPUT DATA, NUMBER=LDXX
C       YDZ - RADIUS FOR EACH DATUM
C       WDZ - WEIGHT FOR EACH DATUM
C       LDXX - NUMBER OF DATA POINTS
C       SPLFIT - FITTED VALUES AT EACH NODE
C       SPLNOD - RADIAL DISTANCE (KM) OF EACH NODE
C       IVARZ - 1 (SURFACE PRESSURE)
C       STMLTZ,STMLNZ,IUTCZ,IDATEZ,STMNMZ - STORM PARAMETERS
C
      CALL XSPLCM(NX,YNB,YNT,YDCWL,KYBC1,KYBC2,YBCWL1,YBCWL2,SPLDTA,YDZ,
     1            WDZ,LDXX,SPLFIT,SPLNOD,IVARZ,IPLVL,STMLTZ,STMLNZ,
     2            IUTCZ,IDATEZ,STMNMZ)
C
      WRITE(6,825) (SPLFIT(NN),NN=2,NX+1)
  825 FORMAT(/'...SPLINE FITTED DATA AT EACH COMPOSITE BIN ARE:',/,
     1       (10X,10F12.3))
C
C     TEST TO SEE IF FITTED DATA ARE AN INCREASING FUNCTION OF RADIUS
C
      CALL FUNINC(NX+1,SPLNOD,SPLFIT,MIN((RPSBIN(NPSRMX)+HUNDKM)*1.E-3,
     1            RPSBIN(NBINPS)*1.E-3),EPSPS,NXYUP,YUP)
C
C     SOME PRINTOUT
C
      IF(.NOT. YUP)  THEN
        WRITE(6,827) ITERPS,EPSPS,NXYUP,RPSBIN(NXYUP-1)
  827   FORMAT(/'...ITERATING 1-D FILTER, ITER. #',I3,', SPLINE FIT ',
     1       'NOT MONOTONICALLY INCREASING. IT DECREASES MORE ',
     2       'THAN',F5.1,' MB.',/,4X,'SPLINE FIT INDEX WHERE FIT ',
     3       'DECREASES IS',I3,', WHICH IS AT COMPOSITE RADIUS=',
     4       -3PF8.1,' KM.')
C
      ELSE
        WRITE(6,829) ITERPS,RPSBIN(NXYUP-1),EPSPS
  829   FORMAT(/'...SUCESSFULLY FINISHED ITERATING 1-D FILTER, ITER.',
     1         '#',I3,/,' ...SPLINE FIT IS MONOTONICALLY INCREASING ',
     2         'OUT TO',-3PF8.1,' KM WITH A TOLERANCE OF',0PF5.1,' MB.')
      ENDIF
C
C     ITERATE WITH LARGER WAVELENGTH FILTERS IF FUNCTION DOES NOT
C       INCREASE
C
      IF(.NOT. YUP .AND. ITERPS .LT. ITMXPS)  THEN
        IF(YDCWL .EQ. YDCWMX)  THEN
        YDCLKM=YDCWL*DELRPS
        WRITE(6,831) YDCWMX,ITERPS,ITMXPS,EPSPS,YDCLKM
  831   FORMAT(/'######WE ARE AT MAX. ALLOWED FILTER WAVELENGTH FOR ',
     1         'SPLINE FITTING SURFACE PRESSURE.',/,7X,'YDCWMX,',
     2         'ITERPS,ITMXPS,EPSPS,YDCLKM=',F7.1,2I5,F6.1,F8.1,' KM')
        GO TO 840
        ENDIF
C
      YDCWL=YDCWL+1.
      GO TO 820
C
      ELSE IF(.NOT. YUP .AND. ITERPS .EQ. ITMXPS)  THEN
      YDCLKM=YDCWL*DELRPS
      WRITE(6,833) ITERPS,YDCLKM
  833 FORMAT(/'######WE ARE AT MAXIMUM ALLOWED ITERATIONS FOR ',
     1       'SPLINE FITTING SURFACE PRESSURE.',/,7X,
     2       'ITERPS,YDCLKM=',I5,F8.1,' KM')
C
      ENDIF
C
  840 CONTINUE
      WRITE(6,857) STMNMZ,RMAX,PENV,SPLFIT(NPSRM1),NPSRMX
      WRITE(IUNTBH,857) STMNMZ,RMAX,PENV,SPLFIT(NPSRM1),NPSRMX
  857 FORMAT(/'...COMPARING FOR STORM ',A,': PENV WITH COMPOSITED ',
     1       'PSFC AT R=RMAX=',F8.2,' KM.',/,4X,'PENV=',F10.2,' AND ',
     2       'THE 1-D FILTERED PSFC=',F10.2,' AT THE COMPOSITING ',
     3       'INDEX=',I3)
C
      WRITE(6,858) PCEN,PSCLOS,HOWFMN,ANGLMN
      WRITE(IUNTBH,858) PCEN,PSCLOS,HOWFMN,ANGLMN
  858 FORMAT(/'...COMPARING PARAMETER PCEN WITH MINIMUM OBS. PSFC:',
     1       /,4X,'PCEN=',F10.2,', WHEREAS THE CLOSEST PSFC=',F8.2,
     2       ' IS AT A DISTANCE OF',-3PF9.2,' KM AND AN ANGLE OF',
     3       0P,F7.1,'.')
      WRITE(6,859) SPLFIT(1)
      WRITE(IUNTBH,859) SPLFIT(1)
  859 FORMAT('...THE 1-D FITTED CENTRAL PRESSURE=',F8.2)
C
C     THERE ARE NO OBSERVATIONS TO COMPARE WITHIN THE COMPOSITING
C       DOMAIN, SO THE 1-D FITTING WILL NOT BE CALLED HERE.  HOWEVER,
C       IT WILL BE CALLED TO FILTER THE VORTEX SURFACE PRESSURE.
C
      ELSE
      WRITE(6,861)
      WRITE(IUNTBH,861)
  861 FORMAT(/'...THERE ARE NO OBSERVATIONS TO COMPARE TO WITHIN ',
     1       'THE COMPOSITING DOMAIN.  THE VORTEX STANDS.')
      ENDIF
C
      WRITE(6,871)
      WRITE(IUNTBH,871)
  871 FORMAT(////3X,'**** OBSERVED SURFACE PRESSURE COMPOSITE ',
     1       '****',13X,'**** VORTEX SURFACE PRESSURE COMPOSITE ****',
     2       //,9X,'BIN',2X,'RADIUS',5X,'PSFC',5X,'SPLFIT',4X,'STDEV',
     3       3X,'# OBS',T69,3X,'PSFC',3X,'# COMVAL',3X,'RADIUS(KM)')
      DO 880 NRPS=1,NBINPS
      WRITE(6,877) NRPS,RPSBIN(NRPS),PSCOM(NRPS,1),SPLFIT(NRPS+1),
     1             STDAZP(NRPS),NPSBIN(NRPS,1),PSCOM(NRPS,2),
     2             NPSBIN(NRPS,2),RPSBIN(NRPS)
      WRITE(IUNTBH,877) NRPS,RPSBIN(NRPS),PSCOM(NRPS,1),SPLFIT(NRPS+1),
     1                  STDAZP(NRPS),NPSBIN(NRPS,1),PSCOM(NRPS,2),
     2                  NPSBIN(NRPS,2),RPSBIN(NRPS)
  877 FORMAT(2X,'... ',I4,1X,-3P,F7.1,2X,0P,F9.2,1X,F9.2,1X,F9.2,
     1          2X,I4,T62,'... ',3X,0P,F9.2,3X,I4,5X,-3P,F7.1)
  880 CONTINUE
C
      ENDIF
C
      IF(ONLYWI)  THEN
C
C     AZIMUTHAL WIND AVERAGES FOR EACH LAYER: OBSERVED AND VORTEX
C
      DO 980 NL=1,NLBIN
C
      IF(MOD(NL,2) .EQ. 1)  THEN
         print *, ' '
         print *, ' '
      ENDIF
      NL1=NL+1
      IF(NINT(PTOP*10.) .GE. NINT(PBIN(NL)*10.))  GO TO 980
      WRITE(6,455) NL,PBIN(NL),PBIN(NL1)
      WRITE(IUNTBH,455) NL,PBIN(NL),PBIN(NL1)
      WRITE(6,941)
      WRITE(IUNTBH,941)
  941 FORMAT(///5X,'**** OBSERVED AZIMUTHAL AVG. STM. REL. WINDS ****',
     1       T70,'**** SYMMETRIC VORTEX AVERAGES ****',/,
     2       /,6X,'RADIUS(KM)',2X,'# OBS',6X,'VRAD',4X,'VTAN',3X,
     3       'SPEED',3X,'STDEV',5X,'# COMVAL',7X,'VRAD',4X,
     4       'VTAN',3X,'SPEED',5X,'RADIUS(KM)',/)
      DO 950 NR=1,NRBIN
      WRITE(6,943) NR,RBIN(NR),NAZIAV(NR,NL,1),
     1             (AZIAVW(NR,NV,NL,1),NV=1,NVARBN),STDAZW(NR,3,NL),
     2             NAZIAV(NR,NL,2),(AZIAVW(NR,NV,NL,2),NV=1,NVARBN),
     3              RBIN(NR)
      WRITE(IUNTBH,943) NR,RBIN(NR),NAZIAV(NR,NL,1),
     1                 (AZIAVW(NR,NV,NL,1),NV=1,NVARBN),STDAZW(NR,3,NL),
     2                 NAZIAV(NR,NL,2),(AZIAVW(NR,NV,NL,2),NV=1,NVARBN),
     3                 RBIN(NR)
  943 FORMAT('...',I3,2X,-3P,F7.1,3X,I3,3X,0P,4F8.2,
     1       T65,'...',I3,3X,0P,3F8.2,4X,-3P,F7.1)
C
  950 CONTINUE
C
  980 CONTINUE
      ENDIF
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE MM2DVO(IUNTBH,DELXZ,SP1DWL,XLATC,XLONC,RMAXZ,PCZ,PBZ,
     1                  PTOPZ,PCENF,A2DVOR,MAXVOR,MAXVOP,MAXVOV,MAXPL,
     2                  IMAXP2,IDATEZ,IUTCZ,STMNMZ)
C
      PARAMETER(MMDIMP=12)
      PARAMETER(MMDIMR=70)
      PARAMETER(NDIM  =70)
ccccc PARAMETER(LDXDIM=NDIM+1)
      PARAMETER(LDXDIM=8000)
C
      CHARACTER STMNMZ*(*)
C
      SAVE
C
      DIMENSION XMODZ(MMDIMP),PSTD(MMDIMP),A2DVOR(MAXVOR,MAXVOP,MAXVOV)
C
      DIMENSION PSA(MMDIMR),DPSA(MMDIMR),VT(MMDIMR),
     1          R(MMDIMR),RDR(MMDIMR),NRDSTR(MMDIMR)
C
      DIMENSION PA(MMDIMR,MMDIMP),RM(MMDIMR,MMDIMP),
     1          VG(MMDIMR,MMDIMP),Z(MMDIMR,MMDIMP)
C
      DIMENSION SPLDTA(LDXDIM),WDZ(LDXDIM),YDZ(LDXDIM),SPLFIT(NDIM+1),
     1          SPLNOD(NDIM+1)
C
      LOGICAL FIRST
C
      DATA PSTD/1000.0,850.0,700.0,500.0,400.0,300.0,250.0,200.0,150.0,
     1          100.0,70.0,50.0/
C
C     IMPORTANT NOTE:  THE VALUES OF R200, R280 BELOW ARE ERRONEOUS,
C                      BUT WERE THE ONES USED IN THE BOGUS "PRA"
C                      RUN.  THEY SHOULD BE CHANGED TO THE CORRECT
C                      VALUES ONCE COMPARISON TESTS ARE COMPLETED.
C
      DATA ALFA/100./,DELV/0.00/,PIA/3.1415926/,FIRST/.TRUE./,
     1     VTFAC/1.2/,DEGLAT/111.1775E3/,IONE/1/,IPLVL/2/,
     2     P150/150./,P200/200./,R200/200.E3/,R280/280.E3/
C
      DATA XMODZ/132.0,1547.0,3182.0,5588.0,7595.0,9682.0,10935.0,
     1           12396.0,14177.0,16568.0,18652.0,20743.0/
C
C     PC, PB IN MB  --  RMAXZ IN KM  --   XLATC IN DEGREES
C
C
C     SET UP INITIAL CONSTANTS AND DO SOME SPACE CHECKS
C
      IF(FIRST)  THEN
      IF(MAXVOR .LT. MMDIMR)  THEN
      WRITE(6,11) MAXVOR,MMDIMR
   11 FORMAT(/'******INSUFFICIENT RADIAL SPACE TO STORE 2-D VORTEX ',
     1       'IN MM2DVO, MAXVOR,MMDIMR=',2I5)
      CALL ABRT1(' MM2DVO',11)
      ENDIF
C
      IF(MAXVOP .LT. MMDIMP)  THEN
      WRITE(6,13) MAXVOP,MMDIMP
   13 FORMAT(/'******INSUFFICIENT VERTICAL SPACE TO STORE 2-D VORTEX ',
     1       'IN MM2DVO, MAXVOP,MMDIMP=',2I5)
      CALL ABRT1(' MM2DVO',13)
      ENDIF
C
      TOMEGA=14.58E-5
      PID=PIA/180.0
      MAXPL=MMDIMP
      IMAX=MMDIMR
      IMAXM1=IMAX-1
C
      EE=2.718
      REE=1.0/EE
C
      DELX=DELXZ*1000.0
      DXOG =DELX/9.806
C
      DO 20  I=1,IMAX
      R(I)=(I-1)*DELX
   20 CONTINUE
c && 2 comments
CC    WRITE(6,11) DELXZ,ALFA,DELV
C1016 FORMAT( //'  DELX,ALFA,DELV FOR MM2DVO=',5F10.3)
C
c && 2 comments
CC    WRITE(6,13) (XMODZ(K),K=1, MAXPL)
C1064 FORMAT(/10X,'...MODIFIED XMODZ=',/,(14X,12F8.0))
C
      ENDIF
C
      WRITE(6,21) DELXZ,ALFA,DELV,XLATC,VTFAC,STMNMZ
      WRITE(IUNTBH,21) DELXZ,ALFA,DELV,XLATC,VTFAC,STMNMZ
   21 FORMAT(////21X,'*******************************************'
     1          /21X,'*******************************************'
     2          /21X,'****                                   ****'
     3          /21X,'****   MATHUR 2-D VORTEX ROUTINE       ****'
     4          /21X,'****   DELX(KM)=',F6.1,'  ALFA=',F6.1,'    ****'
     5          /21X,'****',3X,'DELV=',F5.1,'  XLATC=',F7.2,7X,'****'
     6          /21X,'****',3X,'VTFAC=',F4.1,2X,'STORM=',A12,'  ****'
     7          /21X,'****                                   ****'
     8          /21X,'*******************************************'
     9          /21X,'*******************************************')
C
      PB=PBZ
      PC=PCZ
C
      RMAX=RMAXZ*1000.0
      IMAXA=1+RMAX/DELX
      IMXAP1=IMAXA+1
      IMAXP2=IMAXA+2
C
      IF(IMAXP2 .GT. MMDIMR)  THEN
      WRITE(6,23) IMAXP2,MMDIMR
   23 FORMAT(/'******VORTEX RADIUS TOO LARGE FOR AVAILABLE ',
     1       'STORAGE IN MM2DVO, IMAXP2,MMDIMR=',2I5)
      CALL ABRT1(' MM2DVO',23)
      ENDIF
C
      WRITE(6,27) PB,PC,RMAXZ,IMAXA
      WRITE(IUNTBH,27) PB,PC,RMAXZ,IMAXA
   27 FORMAT(/15X,'...PENV=',F8.2,3X,'PCEN=',F8.2,3X,'RMAX(KM)=',F7.1,
     1       3X,'IMAXA=',I4)
C
      WRITE(6,29) (R(I),I=1,IMXAP1)
   29 FORMAT(/15X,'...RADII ARE ',/,(16X,12(-3PF8.1)))
C
C   ***************************
C   ****  INITIALIZE  PSA  ****
C   ***************************
C
C
      PSA(1:IMAX)=PB
C
C --  QLM  TYPE
C
      DELP=SQRT(1.0+ALFA)
      DELP=(PB-PC)/(1.0-REE/DELP)
C
      PMAX=PC+DELP
      WRITE(6,33) ALFA,DELP,PMAX,PC,PB
   33 FORMAT(//,16X,'...ALFA,DELP,PMAX,PC,PB=',5F10.4)
C
C  -- CALC  SFC  PRES
C
      RDR(1:IMAX)=R(1:IMAX)/RMAX
C
c && 2 comments
CC    WRITE(6,41)(RDR(I),I=2,IMAXA)
CC 41 FORMAT(//,16X,'...RDR=R/RMAX =',/(2X,11F8.4))
C
      DO 50 I=1,IMAXA
      RSQ=RDR(I)**2
      PSA(I)=PMAX-DELP*EXP(-RSQ)/SQRT(1.0+ALFA*RSQ)
   50 CONTINUE
C
      WRITE(6,51) (PSA(I),I=1,IMAXP2)
      WRITE(IUNTBH,51) (PSA(I),I=1,IMAXP2)
   51 FORMAT(//,16X,'...PSA ARE:',/(19X,10F10.2))
C
C     WE FILTER THE SURFACE PRESSURE TO CALCULATE A CENTRAL PRESSURE
C       APPROPRIATE FOR BOGUSING.
C     SPLINE FITTING WITH DERIVATIVE CONSTRAINT.  INPUT PARAMETERS ARE:
C       NX - NUMBER OF NODAL INTERVALS. HERE, NODES CORRESPOND TO
C            GRID POINTS WHERE SURFACE PRESSURE IS DEFINED.  THE FIRST
C            BIN CORRESPONDS TO RADIUS = 0.
C       YNB - CENTER, AT RADIUS=0
C       YNT - MAXIMUM RADIUS (KM)
C       YDCWL - FILTER WAVELENGTH, UNITS ARE # OF NODAL INTERVALS
C       KYBC1 - INNER BOUNDARY CONDITION
C       KYBC2 - OUTER BOUNDARY CONDITION
C       YBCWL1 - INNER BOUNDARY CONDITION WAVELENGTH
C       YBCWL2 - OUTER BOUNDARY CONDITION WAVELENGTH
C       SPLDATA - INPUT DATA, NUMBER=LDXX
C       YDZ - RADIUS FOR EACH DATUM
C       WDZ - WEIGHT FOR EACH DATUM
C       LDXX - NUMBER OF DATA POINTS
C       SPLFIT - FITTED VALUES AT EACH NODE
C       SPLNOD - RADIAL DISTANCE (KM) OF EACH NODE
C       IVARZ - 1: SURFACE PRESSURE
C       STMLTZ,STMLNZ,IUTCZ,IDATEZ,STMNMZ - STORM PARAMETERS
C       IPLVL - PRINT OUTPUT LEVEL FOR 1-D FILTERED SPLINE: 0=NO PRINT,
C             - 1: DATA LISTINGS, 2: DATA LISTINGS AND GRAPHS
C
      IVARZ=1
      STMLTZ=XLATC
      STMLNZ=XLONC
      YNB=0.0
      YNT=R(IMAXA)/1000.
      NX=MIN(IMAXA-1,NDIM)
      DYNODE=R(IMAXA)/REAL(NX)
      KYBC1=21
      KYBC2=21
      YBCWL1=120.E3/DYNODE
      YBCWL2=120.E3/DYNODE
C
      YDCWL=SP1DWL*DEGLAT/DYNODE
      LDXX=IMAXA
      DO 55 I=1,IMAXA
      if(I .GT. LDXDIM)  THEN
         print *, 'LDXDIM limit (',LDXDIM,') exceeded - ',
     $    'I=',I,', return'
         return
      endif
      YDZ(I)=R(I)/1000.
      WDZ(I)=1.0
      SPLDTA(I)=PSA(I)
      SPLNOD(I)=YDZ(I)
   55 CONTINUE
C
      WRITE(6,57) SP1DWL
   57 FORMAT(/'...CALLING 1-D SPLINE FILTER FOR SURFACE PRESSURE, ',
     1       'FILTER WAVELENGTH IS',F5.1,' DEG. LAT.')
C
      CALL XSPLCM(NX,YNB,YNT,YDCWL,KYBC1,KYBC2,YBCWL1,YBCWL2,
     1            SPLDTA,YDZ,WDZ,LDXX,SPLFIT,SPLNOD,IVARZ,IPLVL,
     2            STMLTZ,STMLNZ,IUTCZ,IDATEZ,STMNMZ)
C
      PCENF=SPLFIT(1)
      WRITE(6,59) PCENF
   59 FORMAT(/'...1-D SPLINE FILTERED SURFACE PRESSURE=',F8.2,' MB.')
C
C   **********************************************************
C   -- CALC       PRES    DERIVATIVES
C   **********************************************************
C
      DPSA(1:IMAX)=0.0
C
      DO 70 I=2,IMXAP1
C
      IF(R(I) .GT. RMAX)  GO TO 70
C
      RSQ=RDR(I)**2
      DRSQ=1+RSQ*ALFA
      UDRSQ=SQRT(DRSQ)
      SMU=RDR(I)*DELP*EXP(-RSQ)/UDRSQ
      DPSA(I)=SMU*(2.+ALFA/DRSQ)/RMAX
   70 CONTINUE
C
c && 2 comments
CC    WRITE(6,71) (DPSA(I   ),I=2,IMAXP2)
CC 71 FORMAT(///'     DPSA  FIRST DERIVATIVE =',/(2X,5E12.4))
C
      CORF=ABS(TOMEGA*SIN(XLATC*PID))
      CORFS=CORF**2
C
      VT(1:IMAX)=0.0
C
C
      VT(2:IMAXP2)=VTFAC*(-CORF+(CORFS+4.0*DPSA(2:IMAXP2)*80.0/
     1 R(2:IMAXP2))**.5)/(2.0/R(2:IMAXP2))
C
      WRITE(6,91) (VT(I  ),I=1,IMAXP2)
      WRITE(IUNTBH,91) (VT(I  ),I=1,IMAXP2)
   91 FORMAT(//,16X,'...VT ARE',/,(19X,10F10.2))
C
C     CASE DELV = 0  -   NO ADJUSTMENT OF WIND AT BOUNDARY
      IF(DELV .LE. 0.0)  GO TO 150
C
      DO 100 I=2,IMAXP2
      IK=I
      IF(VT(I)  .LE. 0.1  )   GO TO  120
  100 CONTINUE
      WRITE(6,101)  IK  , VT(IK-1),  VT(IK) , VT(IK+1) ,RMAX
  101 FORMAT( // '  UNABLE TO FIND  ZERO WIND ', I5,2X,4F12.2)
      GO TO 150
C
  120 CONTINUE
C
C     CONSIDER TWO GRID POINTS INSIDE RMAX - NOTE AT RMAX WIND IS ZERO
C
      IK=IK-1
      I8=VT(IK-1)/DELV
C
      IKP=IK+I8
      WRITE(6,123) I8,IK,IKP,VT(IK-1), VT(IK),VT(IK+1),RMAX
  123 FORMAT(//'  WIND ZERO FOUND  ',3I4,4F12.2)
      IF(I8 .LT. 1)   GO TO 150
      DO 130 I=IK,IKP
      VT(I)=VT(I-1)-DELV
      IF(VT(I) .LE. 0.0)  VT(I)=0.0
  130 CONTINUE
      WRITE(6,91) (VT(I  ),I=1,IMAXP2)
  150 CONTINUE
C
C  **************************************************************
C     CALC  WINDS  AT  UPPER   LEVELS
C  **************************************************************
C
      VG(1:IMAX,1) = VT(1:IMAX)
C
      DO KK=1,MAXPL
      DO I=1,IMAX
C
C -------  NEW  WAY ---    CHANGE  --------------------------
C
      PA(I,KK)=1./COSH((PSTD(KK)-P150)/P200)
C
      PA(I,KK)=PA(I,KK)/(COSH((R(I)-R280)/R200))
C
C--   RM MAKES VERT GRADIENT CONCENTRATED IN THE UPPER TROP
C
      XX=PIA*(PSTD(KK)-P150)/P200
C
      RM(I,KK)=.5*(1.+TANH(XX))-PA(I,KK)
C
C     RM(I,KK)=RM(I,KK)-PA(I,KK)
C
C     TRANSFER SIGN OF LATITUDE TO OUTPUT VORTEX
C
      VG(I,KK)=RM(I,KK)*VT(I)
      A2DVOR(I,KK,2)=SIGN(VG(I,KK),XLATC)
C
C ------------   END NEW WAY  -----------------
C
      ENDDO
      ENDDO
C
      WRITE(6,201)   ((VG(I,KK),KK=1,MMDIMP),I=1,IMAXP2)
      WRITE(IUNTBH,201)   ((VG(I,KK),KK=1,MMDIMP),I=1,IMAXP2)
  201 FORMAT(//,'...VG ARE',/(2X,12F10.1))
C
C **************************************************************
C  ---FIND   HEIGHTS OF STND PRESSURE LEVELS
C **************************************************************
C
C
      DO 220 K=1,MAXPL
         Z(1:IMAX,K)= XMODZ(K)
         A2DVOR(1:IMAX,K,1)=XMODZ(K)
  220 CONTINUE
C
C     FIND Z USING GRADIENT BALANCE
C
      IMAXM2= IMAXM1-1
      DO 250 K=1,MAXPL
      DO 240 IR=1,IMAXM2
      I=IMAX-IR
      IP=I+1
      VX=VG(I,K)
      VXS=VX**2
      RX=REAL(I-1)*DELX
C     RX=RX*DELX
C
      Z(I,K)=Z(IP,K)-(CORF*VX+(VXS/RX))*DXOG
  240 CONTINUE
      Z(1,K)=Z(2,K)
C
  250 CONTINUE
C
C     CALCULATE D-VALUE
C
      A2DVOR(1:IMAXP2,1:MMDIMP,1)=Z(1:IMAXP2,1:MMDIMP)
C
      WRITE(6,261)  ((Z(I,KK),KK=1,MMDIMP),I=1,IMAXP2)
      WRITE(IUNTBH,261)  ((Z(I,KK),KK=1,MMDIMP),I=1,IMAXP2)
  261 FORMAT(//,'...Z ARE',/(2X,12F10.1))
C
C     COMPOSITE SURFACE PRESSURE IN THE SAME WAY AS THE OBSERVATIONS
C     **** WARNING:  RADIAL BIN INDICES ARE STORED IN VPSCOM.
C                    THEREFORE, VPSCOM MUST BE CALLED FIRST.  ****
C
      CALL VPSCOM(PSA,R,NRDSTR,IMAXP2)
C
C     COMPOSITE WINDS IN THE SAME WAY AS THE OBSERVATIONS
C
      DO 500 ILV=1,MMDIMP
      IF(NINT(PSTD(ILV)*10.) .GE. NINT(PTOPZ*10.))  THEN
      PRESVO=PSTD(ILV)
      CALL VWNCOM(IMAXP2,IONE,PRESVO,VG(1,ILV),nrdstr)
      ENDIF
  500 CONTINUE
C
      WRITE(6,999)
  999 FORMAT(/'...LEAVING MM2DVO')
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: AS2DVO         CREATES A 2-DIM (R-Z) BOGUS VORTEX
C   PRGMMR: S. J. LORD       ORG: NP22        DATE: 1991-07-01
C
C ABSTRACT: THIS SUBROUTINE CREATES AN AXISYMMETRIC BOGUS VORTEX. LAT,
C   CENTRAL PRESSURE OF THE HURRICANE(PC), PRESSURE OF THE OUTERMOST
C   CLOSE ISOBAR(PB), AND ITS DISTANCE FROM THE CENTER(RMAX) ARE
C   INPUT PARAMETERS.  THE BULK OF THE PROGRAM IS CONTAINED IN
C   THE SUBROUTINE CSWRL6 (WHICH CONTAINS ITS OWN ABSTRACT)
C
C
C PROGRAM HISTORY LOG:
C 1989-10-19  SHAPIRO
C 1990-10-29  LORD  CONVERT TO SUBROUTINE FOR SYNDATA
C 1991-07-01  LORD  VORTICITY-DIVERGENCE BOGUSING
C 2017-04-03  D. A. KEYSER  PARAMETER LDXDIM (STORAGE LIMIT FOR NUMBER
C        OF OBSERVATIONS IN STORM VICINITY) INCREASED FROM 2500 TO 8000.
C        BENEFIT: There can be > 1000 obs in the storm vicinity. This
C                 change ensures that all obs are processed and
C                 eliminates partial processing of statistics in cases
C                 where code does not abort but there are > 1000 obs
C                 going into certain subroutines. The value for
C                 parameter LDXDIM is standardized throughout the code.
C
C USAGE:
C   INPUT ARGUMENT LIST:
C     XLATC - LATITUDE OF STORM CENTER
C     XLONC - LONGITUDE OF STORM CENTER
C     PC - CENTRAL PRESSURE (HPA)
C     PB - PRESSURE OF THE OUTERMOST CLOSED ISOBAR (HPA)
C     RMAX - RADIUS OF OUTERMOST CLOSED ISOBAR (KM)
C     VPOT - SWIRLING WIND AT R=RMAX
C     UPOT - RADIAL WIND AT R=RMAX (MUST BE < 0)
C     DELXZ- GRID INTERVAL (KM) FOR SAMPLING THE WIND FIELDS
C
C   OUTPUT FILES:  VELOCITY AND PERTURBATION HEIGHT FIELDS STORED
C                  ON UNIT 6
C
C   SUBPROGRAMS CALLED:
C     UNIQUE:    - CSWRL6
C
C   EXIT STATES: NONE
C
C REMARKS: YOU ARE FREE TO TWEAK A NUMBER OF PARAMETERS APPEARING IN
C          THE MAIN PROGRAM E.G.: TANGENTIAL VELOCITY COMP AT RMAX,
C          RADIAL VELOCITY COMP AT RMAX. YOU MAY ALSO CHANGE SOME
C          PARAMETERS APPEARING IN SUBROUTINE CSWRL6, EG. B.L. DEPTH,
C          DP, CHARACTERISTIC EYE WALL UPDRAFT VELOCITY.  NOTE: IF DP
C          IS CHANGED IN CSWRL6 IT SHOULD ALSO BE CHANGED WHEN THE
C          SURFACE PRESSURE IS RECALCULATED ON THE COARSE GRID AFTER
C          CSWRL6.
C
C          YOU MAY ALSO TWEAK A NUMBER OF PARAMETERS APPEARING IN
C          THE VERTICAL SPECIFICATION OF THE TANGENTIAL AND RADIAL
C          WIND COMPONENTS.  THESE PARAMETERS APPEAR IN THE MAIN
C          PROGRAM AFTER SUBROUTINE CSWRL6.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
C*****************************************************************
      SUBROUTINE AS2DVO(IUNTBH,IUNTVD,IVOTYP,DELXZ,DELSP,SP1DWL,XLATC,
     1                  XLONC,RMAXZ,PCZ,PBZ,PTOPZ,VPOT,UPOT,RPOTZ,VTBOG,
     2                  DIVFAC,PCENF,A2DVOR,MAXVOR,MAXVOP,MAXVOV,MAXPL,
     3                  IMAXA,IDATEZ,IUTCZ,IER,VORDIV,STMNMZ)
C
      PARAMETER(MMDIMP=12)
      PARAMETER(MMDIMR=1000)
      PARAMETER(NDIM=70)
ccccc PARAMETER(LDXDIM=2500)
      PARAMETER(LDXDIM=8000)
      PARAMETER(MAXPTS=20)
C
      SAVE
C
C**DIAG
C     PARAMETER (NCALMX=100)
C     COMMON/DI/IDT(NCALMX),IUT(NCALMX),PCN(NCALMX),PEN(NCALMX),ICALL,
C    1          PTP(NCALMX),VORC(NCALMX),DIVC(NCALMX),STMN(NCALMX)
C     CHARACTER*12 STMN
C
      CHARACTER STMNMZ*(*)
C
      LOGICAL FIRST,VORDIV
C

      REAL(8)  SINDEG_8

      DIMENSION PSTD(MMDIMP),XMODZ(MMDIMP),R(MMDIMR),NRDSTR(MMDIMR),
     1          PSA(MMDIMR),VT(MMDIMR),URAD(MMDIMR),
     2          VG(MMDIMR,MMDIMP),Z(MMDIMR,MMDIMP),UR(MMDIMR,MMDIMP),
     3          W(MMDIMR,MMDIMP),AXIWND(2*MMDIMR)
C
      DIMENSION A2DVOR(MAXVOR,MAXVOP,MAXVOV),
     1          VORT(MMDIMR,MMDIMP),DIV(MMDIMR,MMDIMP),
     2          VFCEN(MMDIMP),DFCEN(MMDIMP),RHCEN(MMDIMP)
C
      DIMENSION SPLDTA(LDXDIM),WDZ(LDXDIM),YDZ(LDXDIM),SPLFIT(NDIM+1),
     1          SPLNOD(NDIM+1),SPLVOR(LDXDIM),SPLDIV(LDXDIM)
C
      DIMENSION RLATP(MAXPTS),RLONP(MAXPTS)
C
      DATA PSTD/1000.0,850.0,700.0,500.0,400.0,300.0,250.0,200.0,150.,
     1          100.0,70.0,50.0/
C
      DATA XMODZ/132.0,1547.0,3182.0,5588.0,7595.0,9682.0,10935.0,
     1           12396.0,14177.0,16568.0,18652.0,20743.0/
C
C     DEGLAT: ONE DEGREE LATITUDE IN KM
C
      DATA PI/3.1415927/,FIRST/.TRUE./,DEGLAT/111.1775/,
     1     ITWO/2/,EE/2.718/,ALFA/200./,VORVAR/5.E-6/,DIVVAR/5.E-6/,
     2     RHVAR/0.2/,DTHETA/45./,RHCEN/MMDIMP*0.9/
C****************************************************************
C
C
C          XLATC: LATITUDE OF STORM CENTER (DEGREES NORTH)
C          XLONC: LONGITUDE OF STORM CENTER (DEGREES EAST)
C          PCZ  : CENTRAL PRESSURE (MB)
C          PBZ  : PRESSURE OF THE OUTERMOST CLOSED ISOBAR (MB)
C          RMAXZ: RADIUS OF THE OUTERMOST CLOSED ISOBAR (KM)
C          RPOTZ: RADIUS FOR BEGINNING OF INWARD INTEGRATION
C          VPOT : SWIRLING WIND AT RPOT
C          UPOT : RADIAL INFLOW AT RPOT
C     ***** IMPORTANT NOTE:  UPOT MUST BE NON-ZERO AND NEGATIVE *****
C     ***** IMPORTANT NOTE:  XLONC IS IN DEGREES EAST *****
C          DELX : COARSE GRID SPACING.
C          IMAXA: NUMBER OF RADIAL GRID POINTS ON COARSE GRID
C
      IF(FIRST)  THEN
      FIRST=.FALSE.
      PI486 =PI*4.0/86400.
      MAXPL=MMDIMP
      DELX = DELXZ*1000.0
      REE=1.0/EE
      DO 5 I=1,MMDIMR
      R(I)=(I-1)*DELX
    5 CONTINUE
C
C     SET UP INITIAL CONSTANTS AND DO SOME SPACE CHECKS
C
      IF(MAXVOR .LT. MMDIMR)  THEN
      WRITE(6,7) MAXVOR,MMDIMR
    7 FORMAT(/'******INSUFFICIENT RADIAL SPACE TO STORE 2-D VORTEX ',
     1       'IN AS2DVO, MAXVOR,MMDIMR=',2I5)
      CALL ABRT1(' AS2DVO',7)
      ENDIF
C
      IF(MAXVOP .LT. MMDIMP)  THEN
      WRITE(6,9) MAXVOP,MMDIMP
    9 FORMAT(/'******INSUFFICIENT VERTICAL SPACE TO STORE 2-D VORTEX ',
     1       'IN AS2DVO, MAXVOP,MMDIMP=',2I5)
      CALL ABRT1(' AS2DVO',9)
      ENDIF
C
C     WRITE VORTICITY/DIVERGENCE ERROR VARIANCES TO FILE IF
C       VORTICTY/DIVERGENCE BOGUSING IS IN EFFECT
C
      IF(VORDIV)  THEN
      WRITE(IUNTVD,*)  VORVAR
      WRITE(IUNTVD,*)  DIVVAR
      WRITE(IUNTVD,*)  RHVAR
      ENDIF
      ENDIF
C
C     DEPTH1 AND DEPTH2 ARE E-FOLDING DEPTHS (MB) OF GAUSSIAN
C     INFLOW AND OUTFLOW LAYERS.  SEE MORE COMPLETE COMMENTS BELOW
C     REGARDING VERTICAL EXTENSION OF THE VORTEX.
C
      DEPTH1 = 200.0
      IF(NINT(PTOPZ*10.) .LT. 3000)  THEN
      DEPTH2 = 100.0
      ELSE IF(NINT(PTOPZ*10.) .LT. 5000)  THEN
      DEPTH2 = 200.0
      ELSE
      DEPTH2 = 300.0
      ENDIF
C
      RMAX = RMAXZ*1000.0
      RPOT = RPOTZ*1000.0
      PC=PCZ
      PB=PBZ
      CORF = PI486*SINDEG_8(XLATC)
      IMAXA = 1 + RMAX/DELX
      IMXPOT= 1 + RPOT/DELX
C
C**DIAG
C     STMN(ICALL)=STMNMZ
C     PCN(ICALL)=PC
C     PEN(ICALL)=PB
C     PTP(ICALL)=PTOPZ
C
      WRITE(6,11) DELXZ,XLATC,STMNMZ,SP1DWL,DEPTH1,DEPTH2,PTOPZ
      WRITE(IUNTBH,11) DELXZ,XLATC,STMNMZ,SP1DWL,DEPTH1,DEPTH2,PTOPZ
   11 FORMAT(//21X,'*******************************************'
     1        /21X,'*******************************************'
     2        /21X,'****                                   ****'
     3        /21X,'****   SHAPIRO 2-D VORTEX ROUTINE      ****'
     5        /21X,'****',3X,'DELXZ=',F6.1,' KM, XLATC=',F7.2,'  ****'
     6        /21X,'****',3X,'STORM=',A12,' SP1DWL=',F4.1,2X,'****'
     7        /21X,'****',3X,'DEPTH1=',F5.1,' DEPTH2=',F5.1,7X,'****'
     8        /21X,'****',3X,'PTOP=',F5.1,' MB',19X,'****'
     9        /21X,'****                                   ****'
     O        /21X,'*******************************************'
     1        /21X,'*******************************************')
      WRITE(6,13) PB,PC,RMAX,RPOT,XLATC,XLONC,VPOT,UPOT,
     1            IMXPOT,IMAXA
      WRITE(IUNTBH,13) PB,PC,RMAX,RPOT,XLATC,XLONC,VPOT,UPOT,
     1                 IMXPOT,IMAXA
   13 FORMAT(/'...PB=',F6.1,' MB,', 6X, 'PC=',F6.1,' MB,',3X,'RMAX=',
     1       -3PF6.1,' KM,',3X,'RPOT=',F6.1,' KM,',3X,'LAT=',0PF6.1,
     2       ', LON=',F7.1,/,4X,'VPOT=', F6.1,' M/S,', 3X,
     3       'UPOT=', F6.1,' M/S',3X,',IMXPOT=',I3,3X,', IMAXA=',I3)
C
      IF(IMAXA .GT. MMDIMR)  THEN
         WRITE(6,15) IMAXA,MMDIMR
   15 FORMAT(/'******IMAXA=',I5,' EXCEEDS AVAILABLE SPACE, MMDIMR=',I5)
         CALL ABRT1(' AS2DVO',15)
      ENDIF
C
C     INITIALIZE PRESSURE AND VELOCITY FIELDS
C
      VT= 0.0
      URAD= 0.0
      PSA= 0.0
      VG= 0.0
      UR= 0.0
      W= 0.0
      Z= 0.0
      VORT= 0.0
      DIV= 0.0
      AXIWND=0.0
C
C     PRELIMINARY ESTIMATE OF SURFACE PRESSURE COMES FROM THE
C       FUJITA FORMULA AS IMPLEMENTED IN THE QLM.  THE PURPOSE
C       HERE IS TO PROVIDE AN ESTIMATE AT THE RADIUS OF 15 M/S
C       WINDS ONLY
C
      DELP=SQRT(1.0+ALFA)
      DELP=(PB-PC)/(1.0-REE/DELP)
C
      PMAX=PC+DELP
      WRITE(6,19) ALFA,DELP,PMAX,PC,PB
   19 FORMAT(//,16X,'...ALFA,DELP,PMAX,PC,PB=',5F10.4)
C
      DO 20 I=1,IMAXA
         RDR=R(I)/RMAX
         RSQ=RDR**2
         PSA(I)=PMAX-DELP*EXP(-RSQ)/SQRT(1.0+ALFA*RSQ)
   20 CONTINUE
C
      WRITE(6,21) (PSA(I),I=1,IMAXA)
      WRITE(IUNTBH,21) (PSA(I),I=1,IMAXA)
   21 FORMAT(//,16X,'...PRELIMINARY PSA ARE:',/(19X,10F10.2))
C
C     SAMPLE PSA AT INDEX IMXPOT
C
      PPOT=PSA(IMXPOT)
C
C     NOW CALL THE SUBROUTINE (CSWRL6) THAT CALCULATES THE SEA LEVEL
C     VELOCITY FIELD SATISFYING THE RADIAL AND TANGENTIAL EQUATIONS OF
C     MOTION. THE SUBROUTINE SAMPLES THE VELOCITY PROFILE ON THE
C     COARSE GRID PRIOR TO OUTPUT.
C
      CALL CSWRL6(IER,IUNTBH,IMXPOT,UPOT,VPOT,RPOT,PC,PPOT,XLATC,
     1            MMDIMR,DELX,VT,URAD,PSA)
      IF(IER .NE. 0)  THEN
         WRITE(6,23) IER
         WRITE(IUNTBH,23) IER
   23 FORMAT(/'******CSWRL6 HAS UNRECOVERABLE ERROR=',I5,' THEREFORE,',
     1       ' WE CALL MM2DVO AS A BACKUP.')
         RETURN
      ENDIF
C
C     VG IS NOW THE SWIRLING WIND COMPONENT AND UR IS THE INFLOW
C     COMPONENT.
C     PICK OUT THE RADIUS OF MAXIMUM SWIRLING WIND.
C
      IMXZRO=0
      VTZZ=0.0
      DO 25 I = 1, IMXPOT
         IF(ABS(VT(I)) .GT. VTZZ) THEN
            IMXZRO=I
            VTZ=VT(I)
            VTZZ=ABS(VTZ)
         ENDIF
         VG(I,1) = VT(I)
         UR(I,1) = URAD(I)
   25 CONTINUE
C
C     A DIRTY FIX FOR ZERO TANGENTIAL WINDS INSIDE THE RADIUS OF
C        MAXIMUM WIND: SOLID BODY ROTATION, NO INFLOW OR OUTFLOW
C     ****IMPORTANT NOTE: TANGENTIAL WINDS CALCULATED BY CSWRL6
C                         INSIDE THE RADIUS OF MAXIMUM SWIRLING WIND
C                         ARE OVERWRITTEN BY THE FOLLOWING LOOP!! ****
C
      DO 30 I=2,IMXZRO-1
         VT(I)=VTZ*REAL(I-1)/REAL(IMXZRO-1)
         VG(I,1) = VT(I)
   30 CONTINUE
C
C     EXTEND THE VORTEX RADIALLY OUTWARD (LINEARLY) FROM THE RADIUS OF
C        15 M/S WINDS TO THE RADIUS OF THE OUTERMOST CLOSED ISOBAR
C        WHERE THE VORTEX IS VTBOG.  VTBOG IS DEFINED AS THE STORM
C        SPEED IF THERE IS NO VORTEX IN THE GUESS FIELD, BUT IS
C        DEFINED FROM THE AZIMUTHAL MEAN WIND IN THE GUESS FIELD IF
C        THERE IS A VORTEX PRESENT.
C
      IPTS=IMAXA-IMXPOT
      DO 40 I=IMXPOT+1,IMAXA
         VT(I)  =SIGN(VTBOG+(VPOT-VTBOG)*(IMAXA-I)/REAL(IPTS),CORF)
         URAD(I)=UPOT*(IMAXA-I)/REAL(IPTS)
         VG(I,1) = VT(I)
         UR(I,1) = URAD(I)
   40 CONTINUE
C
C     PRINT OUT THE SAMPLED SURFACE PRESSURE AND VELOCITY FIELDS.
C     (NOTE: THIS SAMPLED SURFACE PRESSURE DISTRIBUTION WILL BE IGNORED
C     IN FAVOR OF A HEIGHT FIELD IN BALANCE WITH THE SAMPLED VELOCITY
C     FIELD--TO BE CALCULATED LATER)
C
      WRITE(6,1100) (PSA(I), I=1, IMAXA)
      WRITE(IUNTBH,1100) (PSA(I), I=1, IMAXA)
1100  FORMAT(//,16X,'...PSA ARE:',/,(19X,10F10.2))
C
C     WE FILTER THE SURFACE PRESSURE TO CALCULATE A CENTRAL PRESSURE
C       APPROPRIATE FOR BOGUSING.
C     SPLINE FITTING WITH DERIVATIVE CONSTRAINT.  INPUT PARAMETERS ARE:
C       NX - NUMBER OF NODAL INTERVALS. HERE, NODES CORRESPOND TO
C            GRID POINTS WHERE SURFACE PRESSURE IS DEFINED.  THE FIRST
C            BIN CORRESPONDS TO RADIUS = 0.
C       YNB - CENTER, AT RADIUS=0
C       YNT - MAXIMUM RADIUS (KM)
C       YDCWL - FILTER WAVELENGTH, UNITS ARE # OF NODAL INTERVALS
C       KYBC1 - INNER BOUNDARY CONDITION
C       KYBC2 - OUTER BOUNDARY CONDITION
C       YBCWL1 - INNER BOUNDARY CONDITION WAVELENGTH
C       YBCWL2 - OUTER BOUNDARY CONDITION WAVELENGTH
C       SPLDATA - INPUT DATA, NUMBER=LDXX
C       YDZ - RADIUS FOR EACH DATUM
C       WDZ - WEIGHT FOR EACH DATUM
C       LDXX - NUMBER OF DATA POINTS
C       SPLFIT - FITTED VALUES AT EACH NODE
C       SPLNOD - RADIAL DISTANCE (KM) OF EACH NODE
C       IVARZ - 1: SURFACE PRESSURE
C       IPLVL - PRINT OUTPUT LEVEL: 0=NO PRINT, 1:DATA LISTINGS
C             - 2: DATA LISTINGS AND GRAPHS
C       STMLTZ,STMLNZ,IUTCZ,IDATEZ,STMNMZ - STORM PARAMETERS
C
      IVARZ=1
      IPLVL=0
      STMLTZ=XLATC
      STMLNZ=XLONC
      YNB=0.0
      YNT=R(IMAXA)/1000.
      DYNODE=DELSP
      YDCWL=SP1DWL*DEGLAT/DYNODE
      KYBC1=21
      KYBC2=21
      YBCWL1=120./DYNODE
      YBCWL2=120./DYNODE
C
      NX=0
      SPLNOD(1)=0.0
      DO 43 IN=2,IMAXA
         IF(SPLNOD(IN-1) .LE. YNT)  THEN
            SPLNOD(IN)=SPLNOD(IN-1)+DYNODE
            NX=NX+1
C
            IF(NX .GT. NDIM)  THEN
               WRITE(6,42) NX,NDIM
   42 FORMAT(/'******NUMBER OF NODAL INTERVALS=',I4,' EXCEEDS ',
     1       'PARAMETER NDIM=',I4)
               CALL ABRT1(' AS2DVO',42)
            ENDIF
C
         ELSE
            GO TO 44
         ENDIF
   43 CONTINUE
   44 CONTINUE
C
      LDXX=IMAXA

      YDZ(1:IMAXA)=R(1:IMAXA)/1000.
      WDZ(1:IMAXA)=1.0
      SPLDTA(1:IMAXA)=PSA(1:IMAXA)
C
      WRITE(6,47) SP1DWL
   47 FORMAT(/'...CALLING 1-D SPLINE FILTER FOR SURFACE PRESSURE, ',
     1       'FILTER WAVELENGTH IS',F5.1,' DEG. LAT.')
C
      CALL XSPLCM(NX,YNB,YNT,YDCWL,KYBC1,KYBC2,YBCWL1,YBCWL2,
     1            SPLDTA,YDZ,WDZ,LDXX,SPLFIT,SPLNOD,IVARZ,IPLVL,
     2            STMLTZ,STMLNZ,IUTCZ,IDATEZ,STMNMZ)
C
      PCENF=SPLFIT(1)
      WRITE(6,49) PCENF
      WRITE(IUNTBH,49) PCENF
   49 FORMAT(/'...1-D SPLINE FILTERED SURFACE PRESSURE=',F8.2,' MB.')
C
c && 1 comment
CC    WRITE(6,1200) (VT(I), I=1, IMAXA)
C     WRITE(IUNTBH,1200) (VT(I), I=1, IMAXA)
c && 2 comments
C1200 FORMAT(//,16X,'...VT ARE:', /,(19X,10F10.2))
CC    WRITE(6,1300) (URAD(I), I=1, IMAXA)
C     WRITE(IUNTBH,1300) (URAD(I), I=1, IMAXA)
c && 1 comment
C1300 FORMAT(//,16X,'...URAD ARE:', /,(19X,10F10.2))
C
C     EXTEND VORTEX SPECIFICATION THROUGHOUT THE VERTICAL. EPS
C     IS AN ATTENUATION FACTOR.  IT REDUCES THE CYCLONIC WIND AT THE
C     PRESSURE LEVEL (KHIGH) AT THE FIRST RADIAL GRID POINT TO A
C     FRACTION EPS OF ITS SURFACE VALUE.  EPS IN COMBINATION WITH
C     THE LOW LEVEL ANGULAR MOMENTUM IN THE CORE CONTROLS THE RADIUS
C     AT WHICH ANTICYCLONIC WINDS FIRST APPEAR AT THE LEVEL KHIGH.
C     IF YOU WISH TO SPECIFY THIS RADIUS OF SWIRL REVERSAL (CALL
C     IT RV) THEN EPS SHOULD BE SPECIFIED ACCORDING TO THE FORMULA:
C     EPS = (CORF*RV**2)/(2.*VT(2)*DELX) BUT NOTE THAT THIS VALUE OF
C     EPS MAY TURN OUT TO BE GREATER THAN 1 IMPLYING AN INCREASE OF
C     SWIRL WITH HEIGHT IN THE CORE REGION.
C
C
C     RV = 150.0*1000.
C     EPS = (CORF*RV*RV)/(2.*VT(2)*DELX)
      EPS = 0.8
      KHIGH = 8
      PHIGH = PSTD(KHIGH)
C
C     KINF  IS THE PRESSURE LEVEL NEAR WHICH ANTICYCLONIC WINDS APPEAR
C
      KINF = KHIGH-1
      PINF = PSTD(KINF)
      PLOW = PSTD(1)
      VG(1,KHIGH) = 0.0
      DO 60 IR = 2, IMAXA
         RR = DELX*(IR-1)
         VG(IR,KHIGH) = ( EPS*VT(2)*DELX + CORF*DELX*DELX/2.0 )/RR
     1                  - CORF*RR/2.0
   60 CONTINUE
C
C    FF IS A WEIGHTING FUNCTION TO SPECIFY WINDS BETWEEN LEVEL 1
C    AND LEVEL KHIGH
C
      DO 100 K = 1, KHIGH-1
         XNUMER = TANH(PSTD(K)/PINF) - TANH(PLOW/PINF)
         DENOM = TANH(PHIGH/PINF) - TANH(PLOW/PINF)
         FF = XNUMER/DENOM
         DO 90 IR = 1, IMAXA
            VG(IR,K) = (1.0-FF)*VT(IR) + FF*VG(IR,KHIGH)
   90    CONTINUE
  100 CONTINUE
C
C     CAT IS THE ATTENUATION FACTOR FROM K = KHIGH TO 50 MB.
C
      CAT = 0.5
      KMAX = MMDIMP
      DO 120 K = KHIGH, KMAX
         DO 110 IR = 1, IMAXA
            VG(IR,K) = VG(IR,KHIGH)*(CAT*KHIGH-KMAX+(1.-CAT)*K)
     1                 /(KHIGH-KMAX)
  110    CONTINUE
  120 CONTINUE
C
C     NOW SPECIFY RADIAL WIND. DEPTH1 AND DEPTH2 ARE E-FOLDING
C     DEPTHS (IN MB) OF GAUSSIAN INFLOW AND OUTFLOW LAYERS.  C3 IS
C     CHOSEN SO THAT MASS IN = MASS OUT. MAX INFLOW/OUTFLOW ARE
C     SET TO OCCUR AT PRESSURE LEVELS 1 AND 10 RESPECTIVELY
C
      C1 = 0.0
      C2 = 0.0
      KKMAX = MMDIMP-1
      DO 150  KK=1,KKMAX
         PSMID = ( PSTD(KK+1) + PSTD(KK) )/2.0
         ARG1 = ABS( (PSMID - PSTD(1))/DEPTH1 )
         ARG1 = ARG1*ARG1
         C1 = C1 + EXP(-ARG1)*( PSTD(KK)-PSTD(KK+1) )
         ARG2 = ABS( (PSMID - PSTD(KHIGH))/DEPTH2 )
         ARG2 = ARG2*ARG2
         C2 = C2 + EXP(-ARG2)*( PSTD(KK)-PSTD(KK+1) )
  150 CONTINUE
      C3 = -C1/C2
c && 2 comments
CC    WRITE(6,1400) C1, C2, C3
C1400 FORMAT('...C1, C2, C3=', 3(3X, E12.5) )
C
C     WHICH INDEX CORRESPONDS TO THE REPORTED DEPTH OF THE
C       CYCLONIC CIRCULATION (PTOPZ)?
C
      KPTOP=KHIGH
      DO KK=1,MMDIMP
         IF(NINT(PSTD(KK)*10.) .GE. NINT(PTOPZ*10.))   KPTOP=KK
         DO I = 1, IMAXA
            ARG1 = ABS( (PSTD(KK) - PSTD(1))/DEPTH1 )
            ARG1 = ARG1*ARG1
            ARG2 = ABS( (PSTD(KK) - PSTD(KHIGH))/DEPTH2 )
            ARG2 = ARG2*ARG2
            UR(I,KK) = UR(I,1) * ( EXP(-ARG1) + C3*EXP(-ARG2) )
         ENDDO
      ENDDO
C
C     CALCULATE HEIGHTS FROM RADIAL EQUATION OF MOTION WITH IMPOSED
C     MERIDIONAL CIRCULATION. TURBULENT STRESS INCLUDED AT LOWEST
C     LAYER ONLY.
C
C     *********************** IMPORTANT NOTE **********************
C     THE HEIGHT FIELD Z(I,K) IS REALLY THE PERTURBATION HEIGHT
C     FIELD, I.E., Z(BOUNDARY,K) = 0. ON THE OTHER HAND, IN THE QLM
C     CODE Z(I,K) IS THE FULL HEIGHT FIELD WITH Z(BOUNDARY,K) = WHATEVER
C     THE AZIMUTHALLY AVERAGED ANALYSIS SAYS IT SHOULD BE.
C     *************************************************************
      IMAXM1 = IMAXA - 1
      DO 300 K = 1, MMDIMP
         KM1 = K - 1
         DO 250 IR = 1, IMAXM1
            I = IMAXA - IR
            IP = I + 1
            RX = (I - 1) * DELX
            RXP1 = RX + DELX
            RXSQ = RX * RX
            RXP1SQ = RXP1 * RXP1
            TERM1 = (0.5/9.8) * ( UR(IP,K)*UR(IP,K) - UR(I,K)*UR(I,K) )
C
            IF(K.EQ.1) THEN
               W(I,K) = 0.0
               TERM2 = 0.0
            ELSE
               DPK = 100.0 * ( PSTD(KM1) - PSTD(K) )
               W(I,K) = W(I,KM1) + DPK * (RXP1 *(UR(IP,KM1) + UR(IP,K))
     1                  - RX * ( UR(I,KM1) + UR(I,K) ) )/(RXP1SQ - RXSQ)
               TERM2 = (0.5*DELX/(9.8*DPK)) * ( W(IP,K)*( UR(IP,KM1)
     1                 - UR(IP,K) ) + W(I,K)*( UR(I,KM1) - UR(I,K) ) )
            END IF
C
            IF(I.EQ.1) THEN
               TERM3 = - (0.5*DELX/9.8) * ( VG(IP,K)*VG(IP,K)/RXP1 +
     1                  CORF*VG(IP,K) )
            ELSE
               TERM3 = - (0.5*DELX/9.8) * ( VG(IP,K)*VG(IP,K)/RXP1 +
     1               CORF*VG(IP,K) + VG(I,K)*VG(I,K)/RX + CORF*VG(I,K) )
            END IF
C
            IF(K.EQ.1) THEN
               DZ = 1000.0
               CDRG = 0.001 * ( 0.7 + 0.07*VG(I,K) )
               CDRGP1 = 0.001 * ( 0.7 + 0.07*VG(IP,K) )
               TERM4 = (0.5*DELX/(9.8*DZ)) * ( UR(IP,K)*VG(IP,K)*CDRGP1
     1                 + UR(I,K)*VG(I,K)*CDRG )
            ELSE
               TERM4 = 0.0
            END IF
C
            Z(I,K)=Z(IP,K)+TERM1+TERM2+TERM3+TERM4
C
  250    CONTINUE
  300 CONTINUE
C
C     GET THE LAT/LON OF POINTS ON A CIRCLE AT R=RMAX
C
      CALL CIRCLE(DTHETA,RMAXZ,STMLTZ,STMLNZ,MAXPTS,NPTS,RLATP,RLONP)
      WRITE(6,309) DTHETA,(RLATP(NP),RLONP(NP),NP=1,NPTS)
  309 FORMAT(/'...LAT/LON FOR POINTS ON A CIRCLE WITH DTHETA=',F6.1,
     1       ' ARE:',/,(5X,2F9.2))
C
C     PREPARE FOR 1-D SPLINE FILTERING OF VORTICITY, DIVERGENCE
C       BASIC GEOMETRY HAS BEEN ESTABLISHED BY FILTERING OF SURFACE
C       PRESSURE ABOVE
C
      ZVORT=0.0
      VGMX=-1.E10
C     VORTMX=-1.E10
      URMX=1.E10
C     DIVMX=1.E10
      SCLFAC=1.0E5
      KYBC1=1
      KYBC2=0
C
      DO 470 K=1,KMAX
         DO 400 I=1,IMAXA
            Z(I,K)=Z(I,K)+XMODZ(K)
            A2DVOR(I,K,1)=Z(I,K)
            A2DVOR(I,K,2)=VG(I,K)
            A2DVOR(I,K,3)=UR(I,K)
            IF(I .NE. IMAXA .AND. I .NE. 1)  THEN
               VORT(I,K)=(R(I+1)*VG(I+1,K)-R(I-1)*VG(I-1,K))/
     1                   (2.0*DELX*R(I))
               DIV (I,K)=(R(I+1)*UR(I+1,K)-R(I-1)*UR(I-1,K))/
     1                   (2.0*DELX*R(I))
               IF(VG(I,K) .GE. VGMX)  THEN
                  VGMX=VG(I,K)
                  IVGMX=I
               ENDIF
               IF(UR(I,K) .LE. URMX)  THEN
                  URMX=UR(I,K)
                  IURMX=I
               ENDIF
            ENDIF
  400    CONTINUE
C
         IF(K .LE. KPTOP)  THEN
C
            IF(VORDIV)  THEN
               LDXX=0
               DO 410 I=IVGMX,IMAXA-1
                  LDXX=LDXX+1
      if(LDXX .GT. LDXDIM)  THEN
         print *, 'LDXDIM limit (',LDXDIM,') exceeded - ',
     $    'LDXX=',LDXX,', return'
         return
      endif
                  SPLDTA(LDXX)=VORT(I,K)*SCLFAC
                  YDZ(LDXX)=R(I)/1000.
                  WDZ(LDXX)=1.0
  410          CONTINUE
c && 3 comments
CC    IF(K .EQ. 1) WRITE(6,413) IFIX(PSTD(K)),(SPLDTA(LD),LD=1,LDXX)
CC413 FORMAT(/'...',I5,' MB UNFILTERED VORTICITY * 10**5 IS',/,
CC   1       (4X,10F10.3))
C
               IVARZ=4
               CALL XSPLCM(NX,YNB,YNT,YDCWL,KYBC1,KYBC2,YBCWL1,YBCWL2,
     1                     SPLDTA,YDZ,WDZ,LDXX,SPLVOR,SPLNOD,IVARZ,
     1                     IPLVL,STMLTZ,STMLNZ,IUTCZ,IDATEZ,STMNMZ)
C
               LDXX=0
               DO 430 I=IURMX,IMAXA-1
                  LDXX=LDXX+1
      if(LDXX .GT. LDXDIM)  THEN
         print *, 'LDXDIM limit (',LDXDIM,') exceeded - ',
     $    'LDXX=',LDXX,', return'
         return
      endif
                  SPLDTA(LDXX)=DIV(I,K)*SCLFAC
                  YDZ(LDXX)=R(I)/1000.
                  WDZ(LDXX)=1.0
  430          CONTINUE
c && 3 comments
CC    IF(K .EQ. 1) WRITE(6,433) IFIX(PSTD(K)),(SPLDTA(LD),LD=1,LDXX)
CC433 FORMAT(/'...',I5,' MB UNFILTERED DIVERGENCE * 10**5 IS',/,
CC   1       (4X,10F10.3))
C
               IVARZ=5
               CALL XSPLCM(NX,YNB,YNT,YDCWL,KYBC1,KYBC2,YBCWL1,YBCWL2,
     1                     SPLDTA,YDZ,WDZ,LDXX,SPLDIV,SPLNOD,IVARZ,
     1                     IPLVL,STMLTZ,STMLNZ,IUTCZ,IDATEZ,STMNMZ)
C
c && 2 comments
CC             WRITE(6,*) STMLTZ,STMLNZ,PSTD(K),SPLVOR(1)/SCLFAC,
CC   1                    SPLDIV(1)/SCLFAC,RHCEN(K)
               WRITE(IUNTVD,*) STMLTZ,STMLNZ,PSTD(K),SPLVOR(1)/SCLFAC,
     1                      SPLDIV(1)/SCLFAC,RHCEN(K)
C              WRITE(IUNTBH,*) STMLTZ,STMLNZ,PSTD(K),SPLVOR(1)/SCLFAC,
C    1                      SPLDIV(1)/SCLFAC,RHCEN(K)
               VFCEN(K)=SPLVOR(1)
               DFCEN(K)=SPLDIV(1)
C**DIAG
C              IF(K .EQ. 1)  THEN
C                 VORC(ICALL)=SPLVOR(1)
C                 DIVC(ICALL)=SPLDIV(1)
C              ENDIF
               DO 450 NP=1,NPTS
c && 2 comments
CC                WRITE(6,*) RLATP(NP),RLONP(NP),PSTD(K),ZVORT,
CC   1                       SPLDIV(1)*DIVFAC/SCLFAC,RHCEN(K)
                  WRITE(IUNTVD,*) RLATP(NP),RLONP(NP),PSTD(K),ZVORT,
     1                            SPLDIV(1)*DIVFAC/SCLFAC,RHCEN(K)
C                 WRITE(IUNTBH,*) RLATP(NP),RLONP(NP),PSTD(K),ZVORT,
C    1                            SPLDIV(1)*DIVFAC/SCLFAC,RHCEN(K)
  450          CONTINUE
            ENDIF
         ENDIF

  470 CONTINUE
C
      WRITE(6,471) (PSTD(KK),KK=1,MMDIMP)
C     WRITE(IUNTBH,471) (PSTD(KK),KK=1,MMDIMP)
  471 FORMAT(/9X,12F10.1)
      WRITE(6,473) (R(I),(VG(I,KK), KK=1,MMDIMP),I=1,IMXPOT)
C     WRITE(IUNTBH,473) (R(I),(VG(I,KK), KK=1,MMDIMP),I=1,IMXPOT)
  473 FORMAT(/'...VG ARE:', /, (3X,-3P,F6.1,0P,12F10.1))
      WRITE(6,471) (PSTD(KK),KK=1,MMDIMP)
C     WRITE(IUNTBH,471) (PSTD(KK),KK=1,MMDIMP)
      WRITE(6,475) (R(I),(UR(I,KK), KK=1,MMDIMP),I=1,IMXPOT)
C     WRITE(IUNTBH,475) (R(I),(UR(I,KK), KK=1,MMDIMP),I=1,IMXPOT)
  475 FORMAT(/'...UR ARE:', /, (3X,-3P,F6.1,0P,12F10.1))
      WRITE(6,471) (PSTD(KK),KK=1,MMDIMP)
C     WRITE(IUNTBH,471) (PSTD(KK),KK=1,MMDIMP)
      WRITE(6,477) (R(I),(Z(I,KK), KK=1,MMDIMP),I=1,IMXPOT)
C     WRITE(IUNTBH,477) (R(I),(Z(I,KK), KK=1,MMDIMP),I=1,IMXPOT)
  477 FORMAT(//, ' Z ARE;', /, (3X,-3P,F6.1,0P,12F10.1))
      IF(VORDIV)  THEN
         WRITE(6,471) (PSTD(KK),KK=1,MMDIMP)
C        WRITE(IUNTBH,471) (PSTD(KK),KK=1,MMDIMP)
         WRITE(6,479) (R(I),(VORT(I,KK), KK=1,MMDIMP),I=1,IMXPOT)
C        WRITE(IUNTBH,479) (R(I),(VORT(I,KK), KK=1,MMDIMP),I=1,IMXPOT)
  479 FORMAT(//, ' VORTICITY *10**5 ARE;', /, (3X,-3P,F6.1,5P,12F10.1))
         WRITE(6,471) (PSTD(KK),KK=1,MMDIMP)
C        WRITE(IUNTBH,471) (PSTD(KK),KK=1,MMDIMP)
         WRITE(6,481) (R(I),(DIV(I,KK), KK=1,MMDIMP),I=1,IMXPOT)
C        WRITE(IUNTBH,481) (R(I),(DIV(I,KK), KK=1,MMDIMP),I=1,IMXPOT)
  481 FORMAT(//, ' DIVERGENCE *10**5 ARE;', /, (3X,-3P,F6.1,5P,12F10.1))
C
C     PRINT PROFILE OF CENTRAL VORTICITY, DIVERGENCE AND REL. HUMIDITY
C
         WRITE(6,487)
         WRITE(IUNTBH,487)
  487 FORMAT(/3X,'VERTICAL PROFILE OF FILTERED VORTICITY AND ',
     1       'DIVERGENCE',/,9X,'PRES',4X,'REL.HUM.',2X,'VORTICITY',3X,
     2       'DIVERGENCE * 10**5/SEC')
         DO 490 K=KPTOP,1,-1
            WRITE(6,489)  PSTD(K),RHCEN(K),VFCEN(K),DFCEN(K)
            WRITE(IUNTBH,489)  PSTD(K),RHCEN(K),VFCEN(K),DFCEN(K)
  489 FORMAT(5X,F8.1,2F10.1,2X,F10.1)
  490    CONTINUE
      ENDIF
C
C     COMPOSITE SURFACE PRESSURE IN THE SAME WAY AS THE OBSERVATIONS
C     **** WARNING:  RADIAL BIN INDICES ARE STORED IN VPSCOM.
C                    THEREFORE, VPSCOM MUST BE CALLED FIRST.  ****
C
      CALL VPSCOM(PSA,R,NRDSTR,IMAXA)
C
C     COMPOSITE WINDS IN THE SAME WAY AS THE OBSERVATIONS
C
      DO 550 ILV=1,KPTOP
         DO 500 I=1,IMAXA
            IF(IVOTYP .EQ. 2)  AXIWND(I)=UR(I,ILV)
            AXIWND(IMAXA+I)=VG(I,ILV)
  500    CONTINUE
         PRESVO=PSTD(ILV)
c && 2 comments
CC       WRITE(6,501) (AXIWND(NZ),NZ=1,2*IMAXA)
CC501 FORMAT(/'...CALLING VWNCOM WITH AXIWND=',/,(3X,12F7.1))
         CALL VWNCOM(IMAXA,ITWO,PRESVO,AXIWND,nrdstr)
  550 CONTINUE
C
      WRITE(6,901)
  901 FORMAT(/'...LEAVING AS2DVO.')
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE CSWRL6(IER,IUNTBH,IMAXA,UPOT,VPOT,RMAX,PC,PB,XLATC,
     1                  MMDIMR,DELRMM,VT,URAD,PSA)
C
C
C     *******************    PROGRAM CSWRL6   *************************
C
C     THIS PROGRAM DETERMINES THE STEADY AZIMUTHAL VELOCITY FIELD AND
C     PRESSURE DISTRIBUTION GENERATED BY A STEADY SPECIFIED MERIDIONAL
C     CIRCULATION IN A SLAB BOUNDARY LAYER ON AN F-PLANE.  THE
C     VORTEX IS CONSIDERED TO BE HYDROSTATIC AND AXISYMMETRIC.  THE
C     MERIDIONAL CIRCULATION IS CHARACTERIZED BY AN ANNULAR GAUSSIAN
C     UPDRAFT AND AN OUTER REGION OF CONSTANT BOUNDARY LAYER MASS FLUX.
C     AN AERODYNAMIC DRAG LAW IS USED TO PARAMETERIZE THE TURBULENT
C     STRESS AT THE SEA SURFACE.  THE AZIMUTHAL VELOCITY IS SET TO ZERO
C     OR SOME BACKGROUND ENVIRONMENTAL VALUE AT THE STORM RADIUS.  A
C     SMALL RADIAL INFLOW IS REQUIRED AT THE STORM RADIUS.
C
C
C     THE MODEL VORTEX IS INTENDED AS A "BOGUS" VORTEX CANDIDATE FOR
C     NUMERICAL HURRICANE MODELS.  INPUT PARAMETERS ARE THE CORIOLIS
C     PARAMETER, STORM RADIUS (E.G. RADIUS OF OUTERMOST CLOSED ISOBAR),
C     PRESSURE OF OUTERMOST CLOSED ISOBAR AND CENTRAL PRESSURE.
C
C
C     THE VELOCITY AND PRESSURE FIELDS ARE CALCULATED ON A FINE GRID
C     BY AN ITERATIVE PROCEDURE:
C     (1) A LARGE VALUE OF UPDRAFT RADIUS IS GUESSED.
C     (2) RADIAL AND VERTICAL VELOCITY FIELDS ARE COMPUTED
C     (3) TANGENTIAL WIND IS RECOVERED FROM TANGENTIAL EQUATION OF
C         MOTION
C     (4) PRESSURE IS COMPUTED FROM RADIAL EQUATION OF MOTION
C     (5) COMPUTED CENTRAL PRESSURE IS COMPARED WITH OBSERVED CENTRAL
C         PRESSURE.  IF THE COMPUTED VALUE IS TOO LARGE THEN THE UPDRAFT
C         RADIUS IS DECREASED A TINY BIT (SAY 100 M) AND WE GO BACK
C         TO STEP (1)
C
C             **********    NOTE *************
C     DIMENSIONAL QUANTITIES ARE EXPRESSED IN SI UNITS EXCEPT POSSIBLY
C     WHEN INPUT TO OR OUTPUT FROM PROGRAM.
C
C     THE INDEPENDENT VARIABLE IS:
C
C     R: CYLINDRICAL POLAR RADIUS
C
C     THE DEPENDENT VARIABLES ARE:
C
C     V(R):      AZIMUTHAL "SWIRLING" VELOCITY
C     U(R):      RADIAL VELOCITY
C     W(R):      "VERTICAL" VELOCITY, DP/DT
C     XM(R):     RELATIVE ANGULAR MOMENTUM
C     P(R):      SEA LEVEL PRESSURE
C
C     THE GOVERNING AND DERIVED PARAMETERS ARE:
C
C     XLATC:    LATITUDE OF STORM CENTER
C     F:      CORIOLIS PARAMETER
C     G:      ACCELERATION DUE TO GRAVITY
C     CD:     DRAG COEFFICIENT (VARIES LINEARLY WITH WIND SPEED)
C     DP:     CHARACTERISTIC PRESSURE THICKNESS OF BOUNDARY LAYER
C     PC:     CENTRAL SEA LEVEL PRESSURE
C     PB:     SEA LEVEL PRESSURE OF OUTERMOST CLOSED ISOBAR
C     RHOS:   CHARACTERISTIC SURFACE DENSITY
C     RMAXU:  RADIUS OF MAXIMUM RADIAL INFLOW
C     RUP:    UPDRAFT RADIUS
C     R18:    RADIUS OF 18 M/S WIND
C     R33:    RADIUS OF 33 M/S WIND (HURRICANE FORCE WIND)
C     RMW:    RADIUS OF MAXIMUM AZIMUTHAL VELOCITY
C     RPOT:   POTENTIAL RADIUS.  IN PRACTICE IT MAY BE TAKEN AS THE
C             RADIUS OF THE OUTERMOST CLOSED ISOBAR.
C     VPOT:   VELOCITY AT THE POTENTIAL RADIUS.  MAY BE SET TO ZERO
C             OR SOME MEAN ENVIRONMENTAL VALUE AT RPOT.
C     VRMW:   V(RMW), PEAK AZIMUTHAL VELOCITY
C     Q:      MERIDIONAL BOUNDARY LAYER VOLUME FLUX
C     D:      UPDRAFT DIAMETER: DISTANCE BETWEEN E-FOLDING RADII.
C     S:      D/(2*SQRT(2))
C     XK:      A NON-DIMENSIONAL PARAMETER IN THE ODE
C
C     ******************************************************************
C
C
      SAVE
C
      LOGICAL FIRST

      REAL(8)  SINDEG_8
C
      DIMENSION  R(2001), X(2001), U(2001), E(2001), VV(2001),
     1       V(2001), W(2001), P(2001), SUMCO(2001), SUMCL(2001),
     2       SUMDR(2001), PCO(2001), PMER(2001), PCL(2001), PDR(2001),
     3       XM(2001), VT(MMDIMR), URAD(MMDIMR), PSA(MMDIMR),
     4       VORTFM(2001),DIVFM(2001)
      DATA PI/3.1415927/,FIRST/.TRUE./
C
C
C2500 FORMAT(///, '***** OUTPUT FROM RUNGE-KUTTA SCHEME *****', //)
C2600 FORMAT(' IX', 7X, 'X(IX)', 11X, 'Y', 9X, //)
C3900 FORMAT(2X, 'IR', 5X, 'R (KM)', 10X, 'M', 10X, 'V (M/S)', //)
C
C
C     SPECIFY INPUT AND GRID PARAMETERS.  PB, PC, XLATC, AND RMAX ARE
C     SUPPLIED BY THE MAIN PROGRAM (WHICH GETS THEM FROM THE NATIONAL
C     HURRICANE CENTER).  PC AND PB WILL BE CONVERTED TO PASCALS FOR USE
C     IN THIS SUBROUTINE.  PRESSURE WILL BE CONVERTED BACK TO MILLIBARS
C     AT THE END OF THE SUBROUTINE.
C
      IF(FIRST)  THEN
      FIRST=.FALSE.
      IOUT = 6
      G = 9.806
      RHOS = 1.1
      RHOSG=RHOS*G
      DP = 0.10E+5
      SQRT2=SQRT(2.)
      SQRPI2=SQRT(PI/2.)
      PI486=4.0*PI/86400.
      ENDIF
C
      VORTFM=0.0
      DIVFM=0.0

      NBLOW=0
      RPOT = RMAX
      NR=NINT(RPOT*1.E-3)
      DELR = RPOT/(NR - 1.)
      PB = PB * 100.
      PC = PC * 100.
      F = ABS(PI486*SINDEG_8(XLATC))
      Q = - UPOT * RPOT
C
      SQRQBF=SQRT(Q/F)
      SQRFBQ=SQRT(F/Q)
      SQRQTF=SQRT(Q*F)
      XK = SQRQBF*RHOSG/DP
      HDELR=0.5*DELR
C
C
C     THE UPCOMING DO LOOP TAKES UP MOST OF THE PROGRAM.  Q AND THE
C     MAXIMUM UPDRAFT VELOCITY ARE PRESCRIBED.  THE UPDRAFT WIDTH IS
C     A FUNCTION OF Q AND THE UPDRAFT RADIUS.  THE UPDRAFT RADIUS
C     IS PRESCRIBED AND THE VELOCITY AND PRESSURE FIELDS ARE CALCULATED.
C     IF THE COMPUTED CENTRAL SEA LEVEL PRESSURE IS GREATER THAN THE
C     OBSERVED VALUE THEN THE UPDRAFT RADIUS IS DECREASED AND THE FLOW
C     RECALCULATED.  THIS PROCESS CONTINUES UNTIL  P(1) = OBSERVED
C     CENTRAL SEA LEVEL PRESSURE.
C
C
 9999 ITER=0
      RESIDO=1.E10
      IF(NBLOW .EQ. 0)  THEN
      RUP = MIN(100.,RPOT*0.50E-3) * 1000.
      RUPSV = RUP
      ENDIF
      PDIF = PB - PC
      IF(PDIF .LT. 10.*100.) THEN
        A = 1.0 * RHOSG/DP
      ELSE
        A = 2.0 * RHOSG/DP
      END IF
      WRITE(IOUT,2000) DELR,NR,F,Q,RUP,PB*0.01
      WRITE(IUNTBH,2000) DELR,NR,F,Q,RUP,PB*0.01
2000  FORMAT(/'...DELR=',-3PF7.1,' KM',4X,'NR=',I4,4X,'F=',0PE12.5,4X,
     1       'Q=', E12.5,' RUP=',-3PF8.2,' KM, PB=',0PF9.3,' MB.', //)
      DO 30 L = 1, 1000
      ITER=ITER+1
      S = Q/(A*RUP*SQRT(2.*PI))
      D = 2.*SQRT2*S
      XNARG = RUP/(S*SQRT2)
      IF(XNARG.GT.5.) THEN
        C1 = 0.
      ELSE
        C1 = EXP( -XNARG*XNARG )
      END IF
      C2 = - ERRF(XNARG)
      C3 = C1*S - RUP*SQRPI2*(C2 - 1.)
C
C
C     NON-DIMENSIONALIZE (ND) THE VARIABLES.  X IS ND RADIUS.  XUP,
C     ETC. ARE ND RUP, RMAXU, RPOT, ETC. .
C
C
      DELX = DELR * SQRFBQ
      XUP = RUP * SQRFBQ
C
C
C     EVALUATE SPECIFIED DIMENSIONAL MERIDIONAL VELOCITY FIELD.  "VV"
C     IS THE VERTICAL VELOCITY, DZ/DT (M/S).  ALSO, A USEFUL ND
C     QUANTITY, E(IX), IS COMPUTED FOR USE THROUGHOUT THE PROGRAM.
C     SINCE THE COEFFICIENTS IN THE ODE AS WELL AS THE RADIAL VELOCITY
C     COMPONENT APPROACH INDETERMINATE FORMS 0/0 AS THE RADIUS GOES
C     TO 0, A TINY NON-ZERO QUANTITY IS USED IN PLACE OF 0.
C
C
      X(1) = 0.001 * XUP
      R(1) = SQRQBF * X(1)
      XNARG = ( R(1) - RUP )/(S*SQRT2)
      IF(XNARG.LT.-5.) THEN
        E(1) = ( -S*C1 + RUP*SQRPI2*(C2 - ERRF(XNARG)) )/C3
        W(1) = 0.
      ELSE
        E(1) = ( S*( EXP(-XNARG*XNARG) - C1 ) +
     1             RUP*SQRPI2*(C2 - ERRF(XNARG)) )/C3
        W(1) = - A*DP*EXP(-XNARG*XNARG)
      END IF
      U(1) = Q*E(1)/R(1)
      VV(1) = - W(1)/(RHOSG)
      NX = NR
      DO 40 IX = 2, NX
        X(IX) = (IX - 1.)*DELX
        R(IX) = SQRQBF * X(IX)
        XNARG = (R(IX)-RUP)/(S*SQRT2)
        IF(XNARG.GT.5.) THEN
          E(IX) = - 1.0
          W(IX) = 0.0
        ELSE IF(XNARG.LT.-5.) THEN
          E(IX) = ( -S*C1 + RUP*SQRPI2*(C2 - ERRF(XNARG)) )/C3
          W(IX) = 0.0
        ELSE
          E(IX) = ( S*( EXP(-XNARG*XNARG) - C1 ) +
     1             RUP*SQRPI2*(C2 - ERRF(XNARG)) )/C3
          W(IX) = - A*DP*EXP(-XNARG*XNARG)
        END IF
        U(IX) = Q*E(IX)/R(IX)
        VV(IX) = - W(IX)/(RHOSG)
40      CONTINUE
C
C
C     THE AZIMUTHAL EQUATION OF MOTION IS A FIRST ORDER NONLINEAR ODE
C     FOR THE ANGULAR MOMENTUM.  A FOURTH ORDER RUNGE-KUTTA SCHEME IS
C     NOW EMPLOYED TO SOLVE IT NUMERICALLY.
C
C
C     WRITE(IOUT,2500)
C     WRITE(IOUT,2600)
      Y =  RPOT*VPOT/Q
      H = - DELX
      DO 70 IX = NX, 2, -1
C       IF( (Y.LT.0.0025).AND. (R(IX) .LT. RPOT/2.) ) THEN
C       IF(Y.LT.0.0025)  THEN
        IF(E(IX).GT.-1.E-4) THEN
          XM(IX) = 0.
          GO TO 7000
        ELSE
          XM(IX) = Y
        END IF
        ARG = X(IX)
C       XK1 = H*FCN(ARG, Y, XK, XUP, S, F, Q, C1, C2, C3)
        XK1 = H*FCN(ARG,Y,XK,XUP,S,SQRT2,SQRQBF,SQRQTF,SQRPI2,C1,C2,C3)
        ARG = X(IX) + 0.5*H
C
C     ***BLOWUP CATCHERS IN OPERATION****
C
        IF(Y .LT. 0.0 .OR. ABS(XK1) .GT. 1.E3)  THEN
        NBLOW=NBLOW+1
        WRITE(6,8126) NBLOW,ARG,Y,H,XK3,XK2,XK1
        WRITE(IUNTBH,8126) NBLOW,ARG,Y,H,XK3,XK2,XK1
 8126   FORMAT('******BLOWUP AT XK1 CALCULATION, NBLOW,ARG,',
     1         'Y,H,XK3,XK2,XK1=',/,10X,I3,6E16.8)
        RUP=RUPSV*0.5
        IF(NBLOW .EQ. 1)  GO TO 9999
        IER=8126
        RETURN
        ENDIF
        XK2 = H*FCN(ARG, Y + 0.5*H*XK1,XK,XUP,S,SQRT2,SQRQBF,SQRQTF,
     1              SQRPI2,C1,C2,C3)
        IF(Y .LT. 0.0 .OR. ABS(XK2) .GT. 1.E4)  THEN
        NBLOW=NBLOW+1
        WRITE(6,8127) NBLOW,ARG,Y,H,XK3,XK2,XK1
        WRITE(IUNTBH,8127) NBLOW,ARG,Y,H,XK3,XK2,XK1
 8127   FORMAT('******BLOWUP AT XK2 CALCULATION, NBLOW,ARG,',
     1         'Y,H,XK3,XK2,XK1=',/,10X,I3,6E16.8)
        RUP=50.E3
        IF(NBLOW .EQ. 1)  GO TO 9999
        IER=8127
        RETURN
        ENDIF
C       XK3 = H*FCN(ARG, Y + 0.5*H*XK2, XK, XUP, S, F, Q, C1, C2, C3)
        XK3 = H*FCN(ARG, Y + 0.5*H*XK2,XK,XUP,S,SQRT2,SQRQBF,SQRQTF,
     1              SQRPI2,C1,C2,C3)
        IF(IX.EQ.2) THEN
          ARG = X(1)
        ELSE
          ARG = X(IX) + H
        END IF
C
        IF(Y .LT. 0.0 .OR. ABS(XK3) .GT. 1.E5)  THEN
        NBLOW=NBLOW+1
        WRITE(6,8128) NBLOW,ARG,Y,H,XK3,XK2,XK1
        WRITE(IUNTBH,8128) NBLOW,ARG,Y,H,XK3,XK2,XK1
 8128   FORMAT('******BLOWUP AT XK4 CALCULATION, NBLOW,ARG,',
     1         'Y,H,XK3,XK2,XK1=',/,10X,I3,6E16.8)
        RUP=50.E3
        IF(NBLOW .EQ. 1)  GO TO 9999
        IER=8128
        RETURN
        ENDIF
C
        XK4 = H*FCN(ARG, Y + H*XK3,XK,XUP,S,SQRT2,SQRQBF,SQRQTF,
     1              SQRPI2,C1,C2,C3)
C**DEBUG
c  && 3 comments
CC      WRITE(6,6987) IX,ARG,Y,XK4,XK3,XK2,XK1,Y+H*XK3
C6987   FORMAT('...DEBUGGING, IX,ARG,Y,XK4,XK3,XK2,XK1,Y+H*XK3',/,
CC   1         I5,7E16.6)
        Y = Y + (XK1+XK4)*0.16666667+(XK2+XK3)*0.3333333
7000    CONTINUE
70      CONTINUE
C
C
C     THE TANGENTIAL VELOCITY FIELD AND RELATIVE ANGULAR MOMENTUM ARE
C     DIMENSIONALIZED AND THEN PRINTED OUT.
C
C
C     WRITE(IOUT,3900)
      DO 140 IR = 1, NR
        XM(IR) = Q*XM(IR)
        V(IR) = XM(IR)/R(IR)
C       WRITE(IOUT,4000) IR, R(IR)/1000, XM(IR), V(IR)
C4000   FORMAT(I4, 2X, 3(E10.3, 4X))
140     CONTINUE
C
C
C     COMPUTE SURFACE PRESSURE FIELD FROM RADIAL EQUATION OF MOTION
C     INTEGRATED OVER RADIUS WITH THE TRAPEZOIDAL FORMULA.  THE PREFIX
C     "TRAP" IS THE AREA UNDER A TRAPEZOID.  THE PREFIX "SUM" IS THE SUM
C     OF THE TRAPS.  THE TOTAL PRESSURE, P, IS THE SUM OF THE PRESSURE
C     WHICH SUPPORTS THE CORIOLIS FORCE, PCO, CENTRIFUGAL FORCE, PCL,
C     MERIDIONAL CIRCULATION, PMER, AND THE FRICTIONAL DRAG, PDR.
C
C
      SUMCO(1) = 0.
      SUMCL(1) = 0.
      SUMDR(1) = 0.
      DO 160 IR = 2, NR
        TRAPCL = HDELR*(V(IR)*V(IR)/R(IR) +   V(IR-1)*V(IR-1)/R(IR-1))
        TRAPCO = HDELR * F*( V(IR) + V(IR-1) )
        TRAPDR = - HDELR*(0.001*RHOSG/DP)*((0.7       +0.07*V(IR))
     1           *V(IR)*U(IR) + (0.7+0.07*V(IR-1))*V(IR-1)*U(IR-1))
        SUMCO(IR) = SUMCO(IR-1) + TRAPCO
        SUMCL(IR) = SUMCL(IR-1) + TRAPCL
        SUMDR(IR) = SUMDR(IR-1) + TRAPDR
160     CONTINUE
      DO 180 IR = 1, NR
        PCO(IR) = PB + RHOS*( SUMCO(IR) - SUMCO(NR) )
        PCL(IR) = PB + RHOS*( SUMCL(IR) - SUMCL(NR) )
        PDR(IR) = PB + RHOS*( SUMDR(IR) - SUMDR(NR) )
        PMER(IR) = PB + RHOS*( U(NR)*U(NR) - U(IR)*U(IR) )/2.
        P(IR) = PCO(IR) + PCL(IR) + PDR(IR) + PMER(IR) - 3.*PB
180     CONTINUE
      RESID=P(1)-PC
C       THE BEST VALUE OF UPDRAFT RADIUS FOR EMPIRICALLY DETERMINED Q
C       HAS JUST BEEN FOUND SO NOW YOU CAN JUMP OUT OF THE BIG DO LOOP.
      IF(ABS(RESID) .GT. ABS(RESIDO))  GO TO 6000
C     WRITE(IOUT,2099) ITER, RUP,RPOT,D,RESID
C2099 FORMAT('...ITER=',I5,' RUP=',-3PF7.1, ' KM', 4X, 'RPOT=', F7.1,
C    1        ' KM',4X,'D=',F7.1, ' KM  RESID=',F12.3)
C       THE BEST VALUE OF UPDRAFT RADIUS FOR EMPIRICALLY DETERMINED Q
C       HAS NOT YET BEEN FOUND.  INCREASE OR DECREASE RUP
C       AND RECOMPUTE V, P.
      RESIDO=RESID
      IF(RESID .GT. 0.0) THEN
        RUP = RUP - 100.
      ELSE
        RUP=RUP+100.
      END IF
30    CONTINUE
6000  CONTINUE
      WRITE(IOUT,2100) ITER, RUP,RPOT,D,RESID
      WRITE(IUNTBH,2100) ITER, RUP,RPOT,D,RESID
 2100 FORMAT('...ITER=',I5,', RUP=',-3PF7.1,' KM,',4X,' RPOT=',F7.1,
     1        ' KM,',4X,'D=',F7.1, ' KM,  RESID=',F12.3)
C
C
C     IDENTIFY RADIUS OF MAXIMUM TANGENTIAL WIND (RMW), RADIUS OF
C     HURRICANE FORCE WIND, R33, RADIUS OF 18 M/S WIND, R18, ETC., AS
C     DETERMINED FROM THE SOLUTION.
C
C
      DO 190 IR = 2, NR-1
        IF(V(IR).GT.V(IR+1).AND.V(IR).GT.V(IR-1).AND.V(IR).GT.1.)   THEN
          VMAX = V(IR)
          RMW = R(IR)
          WRITE(IOUT,4100) RMW, VMAX
          WRITE(IUNTBH,4100) RMW, VMAX
4100      FORMAT('...RMW=',-3PF7.1,' KM,',4X,'VMAX=',0PF5.1,' M/S')
        END IF
        IF(V(IR).GE.15..AND.V(IR+1).LT.15.) THEN
          R15 = R(IR)
          WRITE(IOUT,4200) R15
          WRITE(IUNTBH,4200) R15
4200      FORMAT('...R15=',-3PF7.1,' KM')
        END IF
        IF(V(IR).GE.33..AND.V(IR+1).LT.33.) THEN
          R33 = R(IR)
          WRITE(IOUT,4300) R33
          WRITE(IUNTBH,4300) R33
4300      FORMAT('...R33=',-3PF7.1,' KM')
        END IF
        IF(U(IR).LT.U(IR+1).AND.U(IR).LT.U(IR-1).AND.U(IR).LT.-1.)THEN
          RMAXU = R(IR)
          WRITE(IOUT,4400) RMAXU
          WRITE(IUNTBH,4400) RMAXU
4400      FORMAT('...RMAXU=',-3PF7.1, ' KM')
        END IF
190     CONTINUE
C     WRITE(IOUT,4500)
C4500 FORMAT('...R (KM)', 6X, 'U', 7X, 'W (M/S)', 5X, 'V', 6X,
C    1       'PRES (MB)  VORT      DIV (*10**6)', //)
      DO 200 IR = 1, NR
      IF(IR .GT. 1)  THEN
      IF(ABS(U(IR-1)) .GT. 1.E-2 .AND. ABS(V(IR-1)) .GT. 1.E-2)  THEN
      VORTFM(IR)=(R(IR+1)*V(IR+1)-R(IR-1)*V(IR-1))/(R(IR)*(R(IR+1)-
     1            R(IR-1)))
      DIVFM(IR)=(R(IR+1)*U(IR+1)-R(IR-1)*U(IR-1))/(R(IR)*(R(IR+1)-
     1           R(IR-1)))
C
C     GUARANTEE SOME BOUNDARY LAYER CONVERGENCE
C
      DIVFM(IR)=MIN(DIVFM(IR),-0.1E-5)
      ENDIF
      ENDIF
C     WRITE(IOUT,4600) R(IR),U(IR),VV(IR),V(IR),P(IR),VORTFM(IR),
C    1                 DIVFM(IR)
C4600 FORMAT(-3PF7.1, 3X,0PF7.1,3X, F7.2, 3X, F7.1, 5X,-2PF7.1,6P,
C    1       2F10.2)
 200  CONTINUE
C
C
C
C
C     NOW SAMPLE THE VELOCITY AND PRESSURE PROFILES AT THE APPROPRIATE
C     QLM GRID SPACING.  CHANGE NOTATION, CONVERT PRESSURE TO MILLIBARS
C     AND RETURN VARIABLES TO MAIN PROGRAM.
C
C
      DO 300 J = 1, IMAXA
C       IX = 1 + INT( (J - 1.)*(NX - 1.)/(IMAXA - 1.) + .01 )
        IX = 1 + NINT(REAL(J-1)*DELRMM/DELR)
        VT(J) = SIGN(V(IX),XLATC)
        URAD(J) = U(IX)
        PSA(J) = P(IX)/100.
300     CONTINUE
      IER=0
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      FUNCTION FCN(ARG,Y,XK,XUP,S,SQRT2,SQRQBF,SQRQTF,SQRPI2,C1,C2,C3)
C
      CD = 0.001 * (0.7 + 0.07*SQRQTF*Y/ARG)
      XNARG = SQRQBF*(ARG - XUP)/(S*SQRT2)
      IF(XNARG.GT.5.) THEN
        E = - 1.0
      ELSE IF(XNARG.LT.-5.) THEN
        E = (-S*C1 + SQRQBF*XUP*SQRPI2*(C2 - ERRF(XNARG)) )/C3
      ELSE
        E = ( S*( EXP(-XNARG*XNARG) - C1 ) +
     1            SQRQBF*XUP*SQRPI2*(C2 - ERRF(XNARG)) )/C3
      END IF
      COEFF = -XK*CD/E
      FCN = - ARG + COEFF*Y*Y
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      FUNCTION ERRF(XNARG)
C
C     ERRF IS THE ERROR FUNCTION EVALUATED BY AN APPROXIMATE RATIONAL
C     EXPRESSION (EQUATION #7.1.26, PG.299, ABRAMOWITZ AND STEGUN).
C     NOTE THAT FOR NEGATIVE ARGUMENTS, ERRF(-XNARG) = - ERRF(XNARG).
C
        X = ABS(XNARG)
        P = 0.3275911
        A1 = 0.254829592
        A2 = - 0.284496736
        A3 = 1.421413741
        A4 = - 1.453152027
        A5 = 1.061405429
        T = 1./(1. + P*X)
        T2 = T*T
        T3 = T*T2
        T4 = T*T3
        T5 = T*T4
      IF(XNARG.GT.5.) THEN
        ERRF = 1.
      ELSE IF(XNARG.LE.5. .AND. XNARG.GE.0.) THEN
        ERRF = 1. - (A1*T + A2*T2 + A3*T3 + A4*T4 + A5*T5)*EXP(-X*X)
      ELSE IF(XNARG.GE.-5. .AND. XNARG.LT.0.) THEN
        ERRF = -1. + (A1*T + A2*T2 + A3*T3 + A4*T4 + A5*T5)*EXP(-X*X)
      ELSE IF(XNARG.LT.-5.) THEN
        ERRF = -1.
      END IF
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: MAKHRD         ??????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22        DATE: ????-??-??
C
C ABSTRACT: ????????????????????????????????????????????????????????
C   ????????????????????????????????????????????????????????????????
C
C
C PROGRAM HISTORY LOG:
C ????-??-??  LORD
C
C USAGE: CALL MAKHRD(IRTYP,IYR,DAYZ,RLAT,RLON,PRESR,UWIND,VWIND)
C
C   INPUT ARGUMENT LIST:
C     DAYZ     - FRACTIONAL NUMBER OF DAYS SINCE 365 DAYS PRIOR TO
C              - 00Z ON NCEP DATE
C
C   OUTPUT FILES:
C
C   SUBPROGRAMS CALLED:
C     UNIQUE:
C
C   EXIT STATES:
C
C REMARKS:
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE MAKHRD(IRTYP,IYR,DAYZ,RLAT,RLON,PRESR,UWIND,VWIND)
C
      SAVE
C
      CHARACTER FLAG*4

      DATA FLAG/'0000'/,RMISS/-99.0/
C
      CALL YTIME(IYR,DAYZ,IDATE,IUTC)
C
C     CONVERT PREPBUFR REPORT TYPE TO HRD DATA TYPE
C
      IF(IRTYP .EQ. 110 .OR. IRTYP .EQ. 210)  ITYP=12
      IF(IRTYP .EQ. 240 .OR. IRTYP .EQ. 250)  ITYP=24
      IF(IRTYP .EQ. 242 .OR. IRTYP .EQ. 252)  ITYP=27
      IF(IRTYP .EQ. 243 .OR. IRTYP .EQ. 253)  ITYP=28
C
C     CONVERT LONGITUDE TO DEG WEST
C
      RLONW=360.-RLON
C
      WRITE(6,111) ITYP,IDATE,IUTC,RLAT,RLONW,PRESR,RMISS,RMISS,RMISS,
     1             UWIND,VWIND,FLAG
      WRITE(13,112) ITYP,IDATE,IUTC,RLAT,RLONW,PRESR,RMISS,RMISS,RMISS,
     1             UWIND,VWIND,FLAG
  111 FORMAT(1X,I2,1X,I9,1X,I4,1X,F7.3,F8.3,1X,3(F6.1,1X),F7.1,
     1       2(F6.1,1X),A4)
  112 FORMAT(I2,1X,I9,1X,I4,1X,F7.3,F8.3,1X,3(F6.1,1X),F7.1,
     1       2(F6.1,1X),A4)
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE FUNINC(NZ,DST,FUNC,DSTMX,EPS,NZYUP,YUP)
C
      SAVE
C
      LOGICAL YUP
C
      DIMENSION FUNC(NZ),DST(NZ)
C
      CHECK=FUNC(1)
      NZYUP=NZ
      YUP=.TRUE.
      DO 10 N=2,NZ
      IF(DST(N) .GT. DSTMX)  GO TO 20
      IF(FUNC(N)+EPS .LT. CHECK)  THEN
      YUP=.FALSE.
      NZYUP=MIN(NZYUP,N)
      ENDIF
      CHECK=MAX(FUNC(N-1),CHECK)
   10 CONTINUE
      RETURN
C
   20 CONTINUE
      NZYUP=N
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE SPLDAT
C
C                     SPLDAT **  06/12/88
C               MODIFICATION OF XSPLINEX FOR ODW DATA
C         ++ THE MAIN PROGRAM READS DOMAIN PARAMETERS, DISK I/O AND
C                  BOUNDARY CONDITIONS IN NAMELIST FORMAT ON DATA
C                  CARDS IN THE RUN DECK (CARD IMAGES)  ++
C
      PARAMETER (MDIM=35,NDIM=35)
      PARAMETER (LDXDIM=8000)
      PARAMETER (NFXDIM=20)
      PARAMETER (KLDIM= 8)
C
      PARAMETER (KVDIM=20,KDTDIM=5)
C**SGI      PARAMETER (KVDIM= 7,KDTDIM=5)
      PARAMETER (NEXDIM=5)
      PARAMETER (KPXDIM=KVDIM*KLDIM)
      PARAMETER (KDXDIM=KDTDIM*KLDIM)
C
      COMMON /AFD/A(KDXDIM,MDIM,NDIM),FD(KDXDIM,LDXDIM),
     1            FKMN(KPXDIM,MDIM,NDIM)
      COMMON /DSK/MSKEF,MSKEZ,MSKDA1,MSKDA2,MSKDA3,MSKDA4,MSKDA5,MSKDA6,
     1            MSKDA7,MSKDA8,MSKDA9,MSKD11,MSKD12,MSKD13,MSKD14,
     2            MSKD15,MSKD16,MSKD17,MSKD18
      COMMON/XYT/IDAYOB(LDXDIM),UTCOB(LDXDIM),XSTM(NFXDIM),YSTM(NFXDIM),
     1           WSTM(NFXDIM),IDAYST(NFXDIM),UTCSTM(NFXDIM),ELORG,GLORG,
     2           XSTM0,YSTM0,JDAY0,UTC0,NFIX0,IDAYMN
      COMMON /PRES/ PLEV(KLDIM),RHANL,DATREC(KDTDIM+1),ICOOR,IDAT,IDATZ
      COMMON /AZI/ RADFCI,RAD0,NRDMN,NRDMX,THTAMX,DRAD,DTHETA,UVTORT
      COMMON /TMMNMX/ IYMN,IMMN,IDMN,IHMN,IYMX,IMMX,IDMX,IHMX,IY0,IM0,
     1                ID0,HR0
C
      SAVE
C
      COMMON/IBMBS/KPLVZ,WRDPTZ,WRDSTZ,WRDEVZ,NESTZ,IHOLEZ,DTAFTZ,
     1             UVSAVZ,NOFLGZ,PDOMNZ,PALLZ,SLECTZ,EXTVRZ,PRDTAZ,
     2             ANAVGZ,ZSRFZ,DVSRTZ,WRRESZ,MERCPZ,LLWLZ,TIMWNZ,UNIQZ,
     3             PRTAZZ,KDATZ,JPDZ,ITPMNZ,ITPMXZ,NEXZ,ITPEXZ,NSTIKZ,
     4             KLSTKZ,ISPTPZ,DXSPDZ,DYSPDZ,KXTOFZ,RADSHZ,THRSHZ,
     5             USTMZ,VSTMZ,MXZ,NXZ,DUTMNZ,DUTMXZ,ISRCDZ,KDCZ,XDCWLZ,
     6             YDCWLZ,XBCL1Z,XBCL2Z,YBCL1Z,YBCL2Z,KXBC1Z,KXBC2Z,
     7             KYBC1Z,KYBC2Z,XSBM0Z,XSBMXZ,YSBM0Z,YSBMXZ,IHCZ,
     8             NSWLNZ,MESHCZ,DPRXZ,STMIDZ,STMNMZ,PRTBGZ
C
      INTEGER ITPEXZ(NEXDIM),KLSTKZ(KLDIM)
C
      LOGICAL KPLVZ(KLDIM,KVDIM),WRDPTZ,WRDSTZ,WRDEVZ,NESTZ,IHOLEZ,
     1        DTAFTZ,UVSAVZ,NOFLGZ,PDOMNZ,PALLZ,SLECTZ,EXTVRZ,PRDTAZ,
     2        ANAVGZ,ZSRFZ,DVSRTZ,WRRESZ,MERCPZ,LLWLZ,TIMWNZ,UNIQZ,
     3        PRTAZZ,PRTBGZ
C
      CHARACTER*12  STMIDZ,STMNMZ
C
CIBM  NAMELIST/DATDEF/PART2,KPLV,KDAT,JPD,ITYPMN,ITYPMX,NEX,ITYPEX,
CIBM 1                WRSPLD,WRSPLV,WRDTPT,WRDSTT,WRDEV,WRNST,NEST,
CIBM 2                RHANL,SECDER,STICK,NSTICK,KLSTIK,SAMPLD,IHOLE,
CIBM 3                ISPTYP,DXSPD,DYSPD,DATAFT,UVSAVE,NOFLAG,PDOMAN,
CIBM 4                PALL,SELECT,EXTVAR,KXTOFF,PRDATA,AZCALC,
CIBM 5                RMWCLC,NRDMN,NRDMX,RAD0,THTAMX,DRAD,DTHETA,
CIBM 6                ANNAVG,UVTORT,RADSCH,CENTRF,PRSHT,QUERY,QFIND,
CIBM 7                ZSURF,DEVSRT,THRSH,USTM,VSTM,AZRESD,WRRES,CYBANL,
CIBM 8                MERCP,NSWLN,MESHC,SKWT,TIMWIN,CALMCO,UNIQUE,
CIBM 9                WRCHAR,BOGVOR,IMSKDA
CIBM  NAMELIST/DOMAIN/MX,NX,XML,XMR,YNB,YNT,ISRCD,JDAY0,UTC0,
CIBM 1                ELORG,GLORG,DUTCMN,DUTCMX,DPRX
CIBM  NAMELIST/DSKVAL/MSKEF,MSKEZ,MSKDA1,MSKDA2,MSKDA3,MSKDA4,MSKDA5,
CIBM 1                MSKDA6,MSKDA7,MSKDA8,MSKDA9,MSKD11,
CIBM 2                MSKD12,MSKD13,MSKD14,MSKD15,MSKD16,MSKD17,MSKD18
CIBM  NAMELIST/DCBC/KDC,XDCWL,YDCWL,KXBC1,KXBC2,KYBC1,KYBC2,XBCWL1,
CIBM 1              XBCWL2,YBCWL1,YBCWL2,LLWL
CIBM  NAMELIST/SUBM/XSBM0,XSBMX,YSBM0,YSBMX
C
C     ***** DEFAULT CONSTANTS FOR SLOVER *****     OTHERS MUST BE SET
C           DEFAULT BOUNDARY CONDITIONS ARE TYPE 21.
C           DEFAULT FILTER IS 6 DELTA X
C           DEFAULT NODAL SPACING IS 1 DEG. LONG. AND LAT.
C           DEFAULT COORDINATE SYSTEM IS EARTH COORDINATES, WITH
C                 LATITUDE AND LONGITUDE MEASURED IN DEGREES FROM
C                 SOUTHWEST CORNER.
C     UNITS FOR RAD0, DRAD ARE IN KM FOR MORE CONVENIENT USER INTERACTIO
C       THIS IS AN EXCEPTION TO THE STANDARD INTERNAL UNIT, WHICH IS
C       DEGREES LATITUDE.  RADFCI=1./111.1775 CONVERTS KM TO DEG. LAT.
C     DATA DEFINITION
C          PARAMETERS:
C                      PART2        - TRUE IF ONLY SPLINE INTERPOLATION
C                                     IS DONE WITHOUT REDEFINING
C                                     GEOMETRY BY ADDING NEW DATA POINTS
C                      KPLV(KL,KV)  - EACH ELEMENT IS TRUE IF THE LEVEL
C                                     KL AND THE VARIABLE KV IS TO BE
C                                     INTERPOLATED AND PRINTED
C                      KDAT         - MAXIMUM NUMBER OF VARIABLES ON
C                                     DATA CARDS
C                      JPD          - CHOICE OF GEOMETRY: MULTILEVEL (SE
C                                     POSSIBLE)
C                                        1...VAS AND RAWINSONDES (100-30
C                                        2...ODW, NOAA P3, RAWINSONDES (
C                                        3...ODW, NOAA P3, RAWINSONDES (
C                                        4...ODW, NOAA P3, RAWINSONDES (
C                                        5...ODW, NOAA P3, RAWINSONDES (
C                                        6...ODW AND RAWINSONDES (550-10
C                                        7...SURFACE DATA FROM ANY SOURC
C                                   - OR SINGLE LEVEL.  HERE, OPTION IS
C                                        BY SETTING OF PDOMAN AND PALL.
C                                        (SEE XDTSRT, "PRESSURE SELECTIO
C                      ITYPMX       - MAXIMUM DATA TYPE ALLOWED (SEE XDT
C                      ITYPMN       - MINIMUM DATA TYPE ALLOWED (SEE XDT
C                      ITYPEX       - A MULTIPLE DATA TYPES (UP TO NEXDI
C                                     MAY BE EXCLUDED (SEE XDTSRT)
C     DOMAIN PARAMETERS:
C                       MX   - NUMBER OF NODAL POINTS (LONGITUDE)
C                       NX   - NUMBER OF NODAL POINTS (LATITUDE)
C                       XML  - LEFTHAND BOUNDARY (DEG. LONGITUDE)
C                       XMR  - RIGHTHAND BOUNDARY (DEG. LONGITUDE)
C                       YNB  - BOTTOM BOUNDARY (DEG. LATITUDE)
C                       YNT  - TOP BOUNDARY (DEG. LATITUDE)
C     DISK ID'S:        MSKEF   - MATRIX COEFFICIENTS WRITTEN
C                       MSKEZ   - WORKING SPACE FOR MATRIX COEFFICIENTS
C                       MSKDA1  - RAW DATA READ
C                       MSKDA2  - STORM POSITION DATA READ
C                       MSKDA3  - COMPLETE DATA FILE, ALL MISSING DATA R
C                       MSKDA4  - FKMN ARRAYS WRITTEN
C                       MSKDA5  - (DATA-ANALYSIS) DEVIATIONS WRITTEN
C                       MSKDA6  - SPLINE-INTERPOLATED DATA READ FOR NEST
C                                 (ALL WITH RESPECT TO STORM AT TIME T=0
C                       MSKDA7  - SPLINE-INTERPOLATED DATA WRITTEN FOR N
C                                 (ALL WITH RESPECT TO STORM AT TIME T=0
C                       MSKDA8  - DATA POINTS FOR STICKD ARE READ
C                       MSKDA9  - SPLINE-INTERPOLATED DATA VALUES OR
C                                 (DATA-ANALYSIS) DIFFERENCES FROM STICK
C                                 OR DATA VALUES FROM SAMPLD ARE WRITTEN
C                       MSKD11 - INPUT DECK FOR CYBER (QVANAL)
C                       MSKD12 - DATA DECK FOR CYBER (QVANAL)
C                       MSKD13 - JCL FILE FOR SENDING DATA TO CYBER (QVA
C                       MSKD14 - JCL FILE FOR SENDING INPUT DECK TO CYBE
C                       MSKD15 - DATA WEIGHTING SCHEME AND RELATIVE
C                                 WEIGHTS
C                       MSKD16 - STATISTICS OF DATA-ANALYSIS DEVIATIONS
C                                 WRITTEN
C                       MSKD17 - OUTPUT FILE FOR SKEW T/LOG P.
C                       MSKD18 - INPUT FILE FOR DEFINING BOGUS DOMAIN
C
      DIMENSION DWF(KDXDIM),ITYPEX(NEXDIM),FDSK(MDIM,NDIM,2),
     1          AZAVG(KDXDIM),KLSTIK(KLDIM),FDSKS(MDIM,NDIM),SRC(2)
      LOGICAL PART2,KPLV(KLDIM,KVDIM),WRSPLD,WRSPLV,WRDTPT,WRDSTT,WRDEV,
     1        WRNST,NEST,RHANL,SECDER,STICK,SAMPLD,IHOLE,DATAFT,UVSAVE,
     2        NOFLAG,PDOMAN,PALL,SELECT,EXTVAR,PRDATA,AZCALC,RMWCLC,
     3        PRTAZI,ANNAVG,UVTORT,CENTRF,PRSHT,QUERY,QFIND,ZSURF,
     4        DEVSRT,AZRESD,WRRES,CYBANL,MERCP,LLWL,SKWT,TIMWIN,CALMCO,
     5        UNIQUE,WRCHAR,BOGVOR,IMSKDA,PRTBOG,KPLVS(KLDIM,KVDIM),
     6        FRSTBG
C
      CHARACTER*125 IDSPC,SRC*19,STMID*12,STMNAM*12
C
      DATA SRC/' EARTH COORDINATES ','STM-RELATIVE COORDS'/,
     2     STMID/'SSSSSSSSSSSS'/
C
C     DATA STATEMENTS FOR NAMELIST DATDEF
C
C     THE FOLLOWING INCLUDE IS FOR IBM USE ONLY.
C
C
      DATA PART2/.FALSE./,WRSPLD/.FALSE./,WRSPLV/.FALSE./,
     1     WRNST/.FALSE./,WRCHAR/.FALSE./,SECDER/.FALSE./,
     2     STICK/.FALSE./,SAMPLD/.FALSE./,AZCALC/.FALSE./,
     3     RMWCLC/.FALSE./,CENTRF/.FALSE./,PRSHT/.FALSE./,
     4     QUERY/.FALSE./,QFIND/.FALSE./,AZRESD/.FALSE./,
     5     CYBANL/.FALSE./,SKWT/.FALSE./,CALMCO/.TRUE./,BOGVOR/.FALSE./,
     6     IMSKDA/.FALSE./,PRTBOG/.FALSE./,FRSTBG/.TRUE./
C
CIBM  NOTE: 'CIBM' INDICATES THAT THE ORIGINAL VAX CODE HAS BEEN
CIBM               MOVED TO ANOTHER LOCATION USING INCLUDE STMTS AND
CIBM               BLOCK DATA SUBROUTINES.
CIBM  THE FOLLOWING DATA INITIALIZATIONS HAVE BEEN MOVED TO BLOCK
CIBM      DATA BELOW THE MAIN PROGRAM.  SOME ARE IN THE INCLUDE STMT
CIBM      'IBMPGM' ABOVE
CIBM  DATA PART2/.FALSE./,KPLV/KPXDIM*.FALSE./,WRSPLD/.FALSE./,
CIBM 1     WRSPLV/.FALSE./,WRDTPT/.FALSE./,WRDSTT/.FALSE./,
CIBM 2     WRDEV/.FALSE./,WRNST/.FALSE./,NEST/.FALSE./,
CIBM 3     RHANL/.TRUE./,SECDER/.FALSE./,STICK/.FALSE./,
CIBM 4     SAMPLD/.FALSE./,IHOLE/.FALSE./,DATAFT/.FALSE./,
CIBM 5     UVSAVE/.FALSE./,NOFLAG/.FALSE./,PDOMAN/.FALSE./,
CIBM 6     PALL/.FALSE./,SELECT/.FALSE./,EXTVAR/.FALSE./,
CIBM 7     PRDATA/.FALSE./,AZCALC/.FALSE./,RMWCLC/.FALSE./,
CIBM 8     ANNAVG/.TRUE./,UVTORT/.FALSE./,CENTRF/.FALSE./,
CIBM 9     PRSHT/.FALSE./,QUERY/.FALSE./,QFIND/.FALSE./,
CIBM O     ZSURF/.FALSE./,DEVSRT/.FALSE./,AZRESD/.FALSE./,
CIBM 1     WRRES/.FALSE./,CYBANL/.FALSE./,MERCP/.FALSE./,
CIBM 2     LLWL/.FALSE./,SKWT/.FALSE./,TIMWIN/.TRUE./,CALMCO/.TRUE./,
CIBM 3     UNIQUE/.TRUE./
CIBM  DATA KDAT/5/,JPD/2/,ITYPMN/0/,ITYPMX/4/,NEX/0/,ITYPEX/NEXDIM*0/,
CIBM 1     NSTICK/1/,KLSTIK/KLDIM*0/,ISPTYP/11/,DXSPD/0.5/,DYSPD/0.5/,
CIBM 2     KXTOFF/0/NRDMN/1/,NRDMX/1/,RAD0/0.0/,THTAMX/360./,
CIBM 3     DRAD/1.0/,DTHETA/5.0/,RADSCH/3.0/,THRSH/100./,USTM/0.0/,
CIBM 4     VSTM/0.0/
C
C     DATA STATMENT FOR COMMON DSK, NAMELIST DSKVAL
C
CIBM  DATA MSKEF/11/,MSKEZ/12/,MSKDA1/13/,MSKDA2/14/,MSKDA3/15/,
CIBM 1     MSKDA4/16/,MSKDA5/17/,MSKDA6/18/,MSKDA7/19/,MSKDA8/20/,
CIBM 2     MSKDA9/21/,MSKD11/23/,MSKD12/24/,MSKD13/25/,
CIBM 3     MSKD14/26/,MSKD15/27/,MSKD16/28/,MSKD17/29/,MSKD18/30/
C
C     DATA STATEMENT FOR NAMELIST DOMAIN
C
CIBM  DATA MX/20/,NX/20/,ISRCD/0/,JDAY0/-99/,UTC0/-99.0/,DUTCMN/10./,
CIBM 1     DUTCMX/50./,ELORG/-99.0/,GLORG/-99.0/
CIBM  INCLUDE 'DPRX/LIST'
C
C     DATA STATEMENT FOR NAMELIST DCBC
C
CIBM  DATA KDC/3/,XDCWL/6./,YDCWL/6./,KXBC1/21/,KXBC2/21/,KYBC1/21/,
CIBM 1     KYBC2/21/,XBCWL1/10./,XBCWL2/10./,YBCWL1/10./,YBCWL2/10./
C
C     DATA STATEMENT FOR COMMON PRES
C
CIBM  DATA ICOOR/1/,IDAT/4/,IDATZ/3/
C
C     DATA STATEMENT FOR NAMELIST SUBM
C
CIBM  DATA XSBM0/-1.1/,XSBMX/1.2/,YSBM0/-0.8/,YSBMX/1.4/
C
C     DATA STATEMENT FOR OTHER VARIABLES
C
CIBM  DATA XM1/0.0/,YN1/0.0/,XMXX/20./,YNXX/20./,PRTAZI/.TRUE./,
CIBM 1     RADFCI/.0089946/,IHC/0/,NSWLN/1/,MESHC/1/
C
      NAMELIST/DATDEF/PART2,KPLV,KDAT,JPD,ITYPMN,ITYPMX,NEX,ITYPEX,
     1                WRSPLD,WRSPLV,WRDTPT,WRDSTT,WRDEV,WRNST,NEST,
     2                RHANL,SECDER,STICK,NSTICK,KLSTIK,SAMPLD,IHOLE,
     3                ISPTYP,DXSPD,DYSPD,DATAFT,UVSAVE,NOFLAG,PDOMAN,
     4                PALL,SELECT,EXTVAR,KXTOFF,PRDATA,AZCALC,
     5                RMWCLC,NRDMN,NRDMX,RAD0,THTAMX,DRAD,DTHETA,
     6                ANNAVG,UVTORT,RADSCH,CENTRF,PRSHT,QUERY,QFIND,
     7                ZSURF,DEVSRT,THRSH,USTM,VSTM,AZRESD,WRRES,CYBANL,
     8                MERCP,NSWLN,MESHC,SKWT,TIMWIN,CALMCO,UNIQUE,
     9                WRCHAR,BOGVOR,IMSKDA,PRTBOG
      NAMELIST/DOMAIN/MX,NX,XML,XMR,YNB,YNT,ISRCD,JDAY0,UTC0,
     1                ELORG,GLORG,DUTCMN,DUTCMX,DPRX
      NAMELIST/DSKVAL/MSKEF,MSKEZ,MSKDA1,MSKDA2,MSKDA3,MSKDA4,MSKDA5,
     1                MSKDA6,MSKDA7,MSKDA8,MSKDA9,MSKD10,MSKD11,MSKD12,
     2                MSKD13,MSKD14,MSKD15,MSKD16,MSKD17,MSKD18
      NAMELIST/DCBC/KDC,XDCWL,YDCWL,KXBC1,KXBC2,KYBC1,KYBC2,XBCWL1,
     1              XBCWL2,YBCWL1,YBCWL2,LLWL
      NAMELIST/BOGPRM/STMNAM,IDAYZ,IUTCZ,XMLZ,XMRZ,YNBZ,YNTZ,MXZ,NXZ,
     1                DELSPD
      NAMELIST/SUBM/XSBM0,XSBMX,YSBM0,YSBMX
C
C     **************************************************************
C     **************************************************************
C     ***** THE FOLLOWING STATEMENTS ARE FOR INITIALIZATION OF *****
C     ***** LOCAL VARIABLES PASSED AS ARGUMENTS FROM THE BLOCK *****
C     ***** DATA ROUTINE BELOW THE MAIN PROGRAM.  THIS PRO-    *****
C     ***** CEDURE IS NECESSARY FOR IBM FORTRAN, NOT VAX       *****
C     ***** FORTRAN.                                           *****
C     **************************************************************
C     **************************************************************
C
c fixit??  The following do loop goes out of bounds for both parameters;
C          I have made the following change which I "think" is correct
cdak  DO KV=1,KPXDIM
cdak     KPLV(KV,1)=KPLVZ(KV,1)
cdak  ENDDO
      kplv=kplvz

      WRDTPT=WRDPTZ
      WRDSTT=WRDSTZ
      WRDEV=WRDEVZ
      NEST=NESTZ
      IHOLE=IHOLEZ
      DATAFT=DTAFTZ
      UVSAVE=UVSAVZ
      NOFLAG=NOFLGZ
      PDOMAN=PDOMNZ
      PALL=PALLZ
      SELECT=SLECTZ
      EXTVAR=EXTVRZ
      PRDATA=PRDTAZ
      ANNAVG=ANAVGZ
      ZSURF=ZSRFZ
      DEVSRT=DVSRTZ
      WRRES=WRRESZ
      MERCP=MERCPZ
      LLWL=LLWLZ
      TIMWIN=TIMWNZ
      UNIQUE=UNIQZ
      PRTAZI=PRTAZZ
      PRTBOG=PRTBGZ
      KDAT=KDATZ
      JPD=JPDZ
      ITYPMN=ITPMNZ
      ITYPMX=ITPMXZ
      NEX=NEXZ
      ITYPEX=ITPEXZ(NEXDIM)
      NSTICK=NSTIKZ
      KLSTIK=KLSTKZ
      ISPTYP=ISPTPZ
      DXSPD=DXSPDZ
      DYSPD=DYSPDZ
      KXTOFF=KXTOFZ
      RADSCH=RADSHZ
      THRSH=THRSHZ
      USTM=USTMZ
      VSTM=VSTMZ
      MX=MXZ
      NX=NXZ
      DUTCMN=DUTMNZ
      DUTCMX=DUTMXZ
      ISRCD=ISRCDZ
      KDC=KDCZ
      XDCWL=XDCWLZ
      YDCWL=YDCWLZ
      XBCWL1=XBCL1Z
      XBCWL2=XBCL2Z
      YBCWL1=YBCL1Z
      YBCWL2=YBCL2Z
      KXBC1=KXBC1Z
      KXBC2=KXBC2Z
      KYBC1=KYBC1Z
      KYBC2=KYBC2Z
      XSBM0=XSBM0Z
      YSBM0=YSBM0Z
      YSBMX=YSBMXZ
      IHC=IHCZ
      NSWLN=NSWLNZ
      MESHC=MESHCZ
      DPRX=DPRXZ
      STMID=STMIDZ
      STMNAM=STMNMZ
C
C
C     ***** READ AND PRINT A TITLE CARD *****
C
      CALL RDTITL(1)
      CALL PRTITL(1)
C
C     ***** CHANGE INPUT PARAMETERS IF DESIRED
C
c**sgiREAD(5,NML=DATDEF)
      READ(5,DATDEF)
      WRITE(6,DATDEF)
C
C     ***** CHANGE INPUT PARAMETERS IF DESIRED:  UPDATE DOMAIN CONDITION
C
c**sgiREAD(5,NML=DOMAIN)
      READ(5,DOMAIN)
      WRITE(6,DOMAIN)
C
C     ***** CHANGE INPUT PARAMETERS IF DESIRED:  UPDATE BOUNDARY CONDITI
C                                                AND DERIVATIVE CONSTRAI
c**sgiREAD(5,NML=DCBC)
      READ(5,DCBC)
      WRITE(6,DCBC)
C
C     ***** CHANGE DISK UNITS IF DESIRED
C
c**sgiIF(IMSKDA)  READ(5,NML=DSKVAL)
      IF(IMSKDA)  THEN
         READ(5,DSKVAL)
         WRITE(6,DSKVAL)
      END IF
      mskd10 = 22
C
C     CHECK MAXIMUM NUMBER OF DATA VARIABLES
C
      IF(KDAT .GT. KDTDIM)  GO TO 990
C

C-----------------------------------------------------------------------

C     ENTRY TO REPEAT ANALYSIS WITH THE SAME PARAMETERS AND VARIABLES
C       BUT DIFFERENT DATA
C
      ENTRY SPLD1
C
C     OPEN STORM POSITION DATA FILE
C
CVAX  OPEN(UNIT=MSKDA2,FILE='STMTRK',STATUS='OLD',READONLY,SHARED)
CIBM  OPEN(UNIT=MSKDA2,FILE='STMTRK',STATUS='OLD',ACTION='READ')
C
C     OPENS ARE NOT USED ON THE CRAY
C
C     OPEN(UNIT=MSKDA2,FILE='STMTRK',STATUS='UNKNOWN')
C
C     OPEN MATRIX COEFFICIENT FILE (MAY BE NEW FILE OR OLD) AND RAWDAT
C       FILE
C
C
C     OPEN STATEMENTS FOR MATRIX COEFFICIENT AND RAW DATA FILE
C       ARE NOT USED FOR THE CRAY
C
C
C     INITIALIZE RELATIVE COORDINATE ORIGINS
C
      ELORG=-99.0
      GLORG=-99.0
C
C     ***** CHANGE INPUT PARAMETERS IF DESIRED:  STORM NAME, DATE, TIME
C                                                DOMAIN BOUNDARIES FOR
C                                                BOGUS VORTEX
      IF(BOGVOR)  THEN
C     OPEN(UNIT=MSKD18,STATUS='OLD',ACTION='READ')
CIBM  OPEN(UNIT=MSKD18,FILE='BOGDMN',STATUS='OLD',ACTION='READ')
C
C     OPENS ARE NOT USED ON THE CRAY
C
C     OPEN(UNIT=MSKD18,FILE='BOGDOMN',STATUS='UNKNOWN')
C     OPEN(UNIT=MSKD18,STATUS='UNKNOWN')
C     PRTBOG=.FALSE.
      WRITE(6,9835) MSKD18
 9835 FORMAT(/'...READY TO READ BOGPRM NAMELIST ON MSKD18=',I3)
      READ(MSKD18,BOGPRM)
c**sgiREAD(MSKD18,NML=BOGPRM)
      JDAY0=IDAYZ
      UTC0=REAL(IUTCZ)
      XML=XMLZ
      XMR=XMRZ
      YNB=YNBZ
      YNT=YNTZ
      MX =MXZ
      NX =NXZ
      DXSPD=-DELSPD
      DYSPD=-DELSPD
      WRITE(6,BOGPRM)
C
C     FIRST, SAVE ORIGINAL KPLV CONFIGURATION FOR SUCCEEDING BOGUS STEPS
C       FOR ALL SUCCEEDING STEPS, COPY ORIGINAL CONFIGURATION
C
      IF(FRSTBG)  THEN
         FRSTBG=.FALSE.
         KPLVS=KPLV
      ELSE
         KPLV=KPLVS
      ENDIF
      CLOSE(UNIT=MSKD18,STATUS='KEEP')
      ENDIF
C
c**sgiIF(WRNST) READ(5,NML=SUBM)
      IF(WRNST) THEN
         READ(5,SUBM)
         WRITE(6,SUBM)
      END IF
C
      WRITE(6,5) XML,XMR,YNB,YNT,CYBANL,MESHC,MERCP,NSWLN,LLWL,TIMWIN,
     1           WRSPLD,WRSPLV,WRDTPT,WRDSTT,WRDEV,WRNST,
     2           NEST,DPRX,ZSURF
    5 FORMAT(/'....DOMAIN PARAMETERS:  XML=',F8.3,'  XMR=',F8.3,
     1       '  YNB=',F7.3,'  YNT=',F7.3,/,
     2       ' ....CYBER ANALYSIS (',L1,')  # OF MESHES=',I2,/,
     3       ' ....MERCATOR PROJECTION (',L1,')',
     4       ' SIGN OF WEST LONG.=',I2,', LAT/LON WAVELENGTH (',L1,')',
     5     /,' ....TIME WINDOW USED FOR ALL DATA (',L1,')',
     5     /,' ....FILES WRITTEN:','  WRSPLD=',L3,',  WRSPLV=',L3,
     6       ',  WRDTPT=',L3,',   WRDSTT=',L3,',   WRDEV=',L3,
     7       ',  WRNST=',L3,/,' ....NESTED GRID USED  (',
     8    L1,')',/,' ....VERTICAL DATA ACCEPTANCE WINDOW=',F7.2,/,
     9       ' ....VERTICAL COORDINATE IS NOT PRESSURE (',L1,')')
C
C
C     OPTION FOR HORIZONTAL COORDINATE:  DEFAULT INTERNAL COORDINATE
C                                        (UNITS) IS LATITUDE/LONGITUDE
C                                        (DEGREES)
C                                        OPTION 1 IS MERCATOR (METERS)
C
C     CYBER 205 ANALYSIS IS REQUIRED FOR MESHC>1.
C     MERCATOR IS REQUIRED FOR ANALYSIS ON CYBER 205
C
      IF(MESHC .GT. 1)  CYBANL=.TRUE.
      IF(CYBANL)  MERCP=.TRUE.
C
      IF(MERCP) IHC=1
C
C     SET UP STORAGE FOR VERTICAL COORDINATE: DEFAULT IS PRESSURE COORDI
C     THIS MUST BE MODIFIED IF MORE COORDINATE OPTIONS ARE NECESSARY
C
      IF(.NOT. ZSURF)  GO TO 10
      ICOOR=4
      IDAT=1
C
C     READ STORM DAY AND STORM IDENTIFICATION
C
   10 CALL FNDDAY(STMID,NFIXP,TIMWIN)
C
C     DEFINE HURRICANE FIX POSITIONS AND TIME T=0 LOCATION FOR
C     STORM-RELATIVE COORDINATES
C
      CALL HURPOS(IDAYMX,UTCMX,UTCMN,DUTCMN,DUTCMX)
C
C     PUT IDENTIFICATION TAG INTO IDSPC AND PUT VALUE INTO COMMON BLOCK
C
      WRITE(IDSPC,810) STMID,SRC(ISRCD+1),IDMN,IMMN,IYMN,
     1                 IHMN,IDMX,IMMX,IYMX,IHMX,
     2                 YSTM0,XSTM0,NINT(HR0),ID0,IM0
  810 FORMAT(A12,1X,A19,1X,'FROM ',2(I2.2,'/'),I4.4,',',I3.2,' UTC TO ',
     1       2(I2.2,'/'),I4.4,',',I3.2,' UTC STM POS',F6.1,' LAT,',F5.1,
     2       ' LON AT',I3.2,' UTC ON',I3.2,'/',I2.2)
C
      CALL STSPID(IDSPC)
C
C     PUT DOMAIN AND BOUNDARIES INTO COMMON
C
      CALL STDOMN(NSWLN,XML,XMR,YNB,YNT,JPD,ISRCD)
C
C     SET UP HORIZONTAL COORDINATE:  LAT/LON OR MERCATOR PROJECTION
C                                    ARE CURRENT OPTIONS.
C
      CALL CHORC(IHC)
      CALL STHORC(IHC,ELORG,GLORG,XSTM0,YSTM0,LLWL)
C
C     INITIALIZE POSSIBILITY OF EXTERNAL VARIABLES
C
      CALL STEXTV(EXTVAR,KXTOFF)
C
      IF(PART2)  THEN
C
C     ***** READ BACK MSKEF ***** BEGIN PART II *****
C
         CALL SLEFCD
         GO TO 100
      END IF
C
C     BEGIN PART I: DATA READING, COORDINATE TRANSFORMATIONS, AND
C                   MATRIX COEFFICIENT CALCULATIONS
C
C     SET NODES
C
      CALL STSPND(MX,NX)
C
C     PUT BOUNDARY CONDITIONS INTO COMMON
C
      CALL STSPBC(KXBC1,KXBC2,KYBC1,KYBC2,XBCWL1,XBCWL2,YBCWL1,YBCWL2)
C
C     PUT FILTER WAVELENGTHS INTO COMMON
C
      CALL STSPDC(KDC,XDCWL,YDCWL)
      CALL SLOVER
C
C     ***** DEFINE THE DATA POINTS *****
C
      CALL XDTSRT(KPLV,KDAT,DWF,ITYPMN,ITYPMX,NEX,ITYPEX,NEST,
     1             NOFLAG,PDOMAN,PALL,SELECT,PRDATA,DPRX,NSWLN,
     2             UNIQUE)
C
C     ***** WRITE MSKEF IF CALMCO SO ORDERS   (NOT EXECUTED FOR CYBER
C           ANALYSES)  *****
C
      IF(.NOT. CYBANL)  THEN
         IF(CALMCO)   CALL SLARGO
C
C     ***** READ BACK MSKEF ***** BEGIN PART II *****
C
         CALL SLEFCD
      ENDIF

  100 CONTINUE
C
C     ***** DEFINE THE DATA FIELDS TO BE INTERPOLATED AND PRINTED  *****
C
      CALL XDATR(KPLV,KDAT,FD,DWF,KDX,USTM,VSTM,CYBANL)
CIBM  WRITE(1,105) KDX
      WRITE(6,105) KDX
  105 FORMAT(/'...DATA HAVE BEEN READ BACK FROM DISK, KDX=',I5)
CIBM  IF(USTM .NE. 0.0 .OR. VSTM .NE. 0.0)  WRITE(1,106)  USTM,VSTM
      IF(USTM .NE. 0.0 .OR. VSTM .NE. 0.0)  WRITE(6,106)  USTM,VSTM
  106 FORMAT('...WINDS ARE WITH RESPECT TO USTM=',F8.3,', VSTM=',F8.3,
     1       /)
C
C     ROUTE TO CYBER INPUT PROGRAM, NEVER TO RETURN.
C
C*CRAYIF(CYBANL)  CALL VICSPL(MESHC,KDX,FD,LLWL,DPRX,ITYPMN,ITYPMX,
C*CRA1                        NEX,ITYPEX,NFIXP)
C
      IF(KDX .GT. KDXDIM)  GO TO 970
      CALL SLIMBO(FD,1,KDX,A)
      CALL SETKPX(KDX)
      CALL PRDSPK(0)
      IF(PRTBOG)  CALL PRFKMD(A,FKMN,1,KDX)
C     CALL PRFKMD(A,FKMN,1,KDX)
      KPX=KDX
C
      IF(MERCP)  GO TO 150
C
C     SET UP COORDINATE CENTERS FOR POSSIBLE AZIMUTHAL AVERAGE
C     CALCULATIONS. DEFAULT IS STORM FIX POSITION, OTHER POSSIBILITIES
C     ARE: 1) ARBITRARY POINT IN DOMAIN (QUERY=.TRUE.) OR 2) MAXIMUM OR
C     MINIMUM OF A PARTICULAR VARIABLE (QFIND=.TRUE.).
C
      XZ=XSTM0
      YZ=YSTM0
C
C     INTERACTIVE QUERIES FOR POINT VALUES AND LOCAL MINIMA OR MAXIMA
C
      IF(SKWT)  CALL SPSKWT(A,KDX,XZ,YZ,NSWLN)
      IF(QUERY)  CALL SPTLOC(A,KDX,XZ,YZ,NSWLN)
C      IF(QFIND)  CALL SPTFND(A,KDX,XZ,YZ,NSWLN)
C
C     CENTER-FINDING ALGORITHM
C
C*CRAYIF(CENTRF)  CALL CTRFND(A,1,KDX,XZ,YZ,RADSCH)
C
C     FIND RADIUS OF MAXIMUM WIND
C
C*CRAYIF(RMWCLC)   CALL RMXW(A,1,KDX,XZ,YZ,PRTAZI)
C
C     AZIMUTHAL AVERAGE CALCULATIONS
C
C*CRAYIF(AZCALC)   CALL AZIAVG(A,1,KDX,XZ,YZ,AZAVG,PRTAZI,ANNAVG)
C
C     RESIDUALS FROM THE AZIMUTHAL MEAN WIND
C
C*CRAYIF(AZRESD)  CALL AZIRSD(A,FKMN,1,KDX,XZ,YZ,AZAVG,KPX,WRRES)
C
C     GRIDDED OUTPUT TO DISK (UNFORMATTED HERE, CHARACTER FORM DONE
C       LATER FOR ALL VARIABLES AT ONCE)
C
      IF(.NOT. WRCHAR)  THEN
      IF(WRSPLD .AND. .NOT. WRRES)
     1           CALL DSKNMC(FKMN,1,KDX,FDSK,FDSKS,MX+1,NX+1)
      IF(WRRES)  CALL DSKNMC(FKMN,1,KPX,FDSK,FDSKS,MX+1,NX+1)
      ENDIF
C
C     (DATA-ANALYSIS) DIFFERENCES
C
  150 CONTINUE
      IF(MERCP)  GO TO 500
C
C     SECONDARY (NON DATA) VARIABLES
C
      KPZ0=KPX
      CALL OUTVAR(KPLV,A,FKMN,KPX)
      IF(QFIND)  CALL SPTFND(A,KPX,XZ,YZ,NSWLN)
      IF(SECDER)  CALL OUTSDR(KPLV,A,FKMN,KPX)
      IF(KPX .LE. KPZ0)  GO TO 200
      IF(KPX .GT. KPXDIM)  GO TO 980
      CALL SETKPX(KPX)
      CALL PRDSPK(0)
      IF(.NOT. PRSHT)  CALL PRFKMV(FKMN,KPZ0+1,KPX)
      IF(.NOT. WRCHAR)  THEN
      IF(WRSPLV)  CALL DSKNMC(FKMN,KPZ0+1,KPX,FDSK,FDSKS,MX+1,NX+1)
      ELSE
      IF(WRSPLV .OR. WRSPLD)  CALL DSKCHR(FKMN,1,KPX,MX+1,NX+1)
      ENDIF
C
C     WRITING SUBMESH
C
  200 CONTINUE
C
C     STICK DATA OPTION
C
      IF(.NOT. STICK)  GO TO 400
      IF(KLSTIK(1) .EQ. 1 .AND. .NOT. DATAFT) CALL OPNFIL(MSKDA9)
      IF(KLSTIK(1) .NE. 1 .AND. .NOT. DATAFT) CALL ENDFIL(MSKDA9)
      CALL STICKD(KPLV,A,KDAT,KDX,DPRX,NSTICK,KLSTIK,DATAFT,UVSAVE,
     1            WRDSTT,PRDATA)
C
C     SAMPLED DATA
C
  400 IF(SAMPLD)   CALL SPTDAT(1,KDX,KPLV,A,KDAT,IHOLE,ISPTYP,
     1                          DXSPD,DYSPD,NSWLN,PRTBOG,STMNAM)
  500 CALL PREND
CIBM  WRITE(1,501)
C 501 FORMAT(/'...HORIZONTAL ANALYSIS TERMINATED NORMALLY')
      RETURN
  970 WRITE(6,971)  KDX,KDXDIM
  971 FORMAT(/'***** TOO MANY DATA VARIABLES, KDX=',I6,' WHILE KDAT=',
     1       I6)
      CALL ABRT1('  SPLD1',971)
  980 WRITE(6,981)  KPX,KPXDIM
  981 FORMAT(/'***** TOO MANY PRINTED VARIABLES, KPX=',I6,' WHILE',
     1       ' AVAILABLE SPACE IS KPXDIM=',I6)
      CALL ABRT1('  SPLD1',981)
  990 WRITE(6,991)  KDAT,KDTDIM
  991 FORMAT(/'***** ERROR IN SPLINEX SETTING UP DATA READING...'
     1       ,'  KDAT=',I6,' WHILE AVAILABLE DATA IS',I6)
      CALL ABRT1('  SPLD1',991)
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      BLOCK DATA IBM1
      PARAMETER (LDXDIM=8000)
      PARAMETER (NFXDIM=20)
      PARAMETER (KLDIM= 8)
      PARAMETER(KVDIM=20,KDTDIM=5,NEXDIM=5)
C**SGI      PARAMETER(KVDIM= 7,KDTDIM=5,NEXDIM=5)
      PARAMETER (KPXDIM=KVDIM*KLDIM)
C
      COMMON /DSK/MSKEF,MSKEZ,MSKDA1,MSKDA2,MSKDA3,MSKDA4,MSKDA5,MSKDA6,
     1            MSKDA7,MSKDA8,MSKDA9,MSKD11,MSKD12,MSKD13,MSKD14,
     2            MSKD15,MSKD16,MSKD17,MSKD18
C
      COMMON/XYT/IDAYOB(LDXDIM),UTCOB(LDXDIM),XSTM(NFXDIM),YSTM(NFXDIM),
     1            WSTM(NFXDIM),IDAYST(NFXDIM),UTCSTM(NFXDIM),ELORG,
     2            GLORG,XSTM0,YSTM0,JDAY0,UTC0,NFIX0,IDAYMN
C
      COMMON /PRES/ PLEV(KLDIM),RHANL,DATREC(KDTDIM+1),ICOOR,IDAT,IDATZ
C
      COMMON /AZI/ RADFCI,RAD0,NRDMN,NRDMX,THTAMX,DRAD,DTHETA,UVTORT
C
      COMMON/IBMBS/KPLVZ,WRDPTZ,WRDSTZ,WRDEVZ,NESTZ,IHOLEZ,DTAFTZ,
     1             UVSAVZ,NOFLGZ,PDOMNZ,PALLZ,SLECTZ,EXTVRZ,PRDTAZ,
     2             ANAVGZ,ZSRFZ,DVSRTZ,WRRESZ,MERCPZ,LLWLZ,TIMWNZ,UNIQZ,
     3             PRTAZZ,KDATZ,JPDZ,ITPMNZ,ITPMXZ,NEXZ,ITPEXZ,NSTIKZ,
     4             KLSTKZ,ISPTPZ,DXSPDZ,DYSPDZ,KXTOFZ,RADSHZ,THRSHZ,
     5             USTMZ,VSTMZ,MXZ,NXZ,DUTMNZ,DUTMXZ,ISRCDZ,KDCZ,XDCWLZ,
     6             YDCWLZ,XBCL1Z,XBCL2Z,YBCL1Z,YBCL2Z,KXBC1Z,KXBC2Z,
     7             KYBC1Z,KYBC2Z,XSBM0Z,XSBMXZ,YSBM0Z,YSBMXZ,IHCZ,
     8             NSWLNZ,MESHCZ,DPRXZ,STMIDZ,STMNMZ,PRTBGZ
C
      INTEGER ITPEXZ(NEXDIM),KLSTKZ(KLDIM)
C
      LOGICAL KPLVZ(KLDIM,KVDIM),WRDPTZ,WRDSTZ,WRDEVZ,NESTZ,IHOLEZ,
     1        DTAFTZ,UVSAVZ,NOFLGZ,PDOMNZ,PALLZ,SLECTZ,EXTVRZ,PRDTAZ,
     2        ANAVGZ,ZSRFZ,DVSRTZ,WRRESZ,MERCPZ,LLWLZ,TIMWNZ,UNIQZ,
     3        PRTAZZ,PRTBGZ
C
      CHARACTER*12  STMIDZ,STMNMZ
C
      LOGICAL RHANL,UVTORT
C
      DATA STMIDZ/'SSSSSSSSSSSS'/,STMNMZ/'            '/
C
      DATA KPLVZ/KPXDIM*.FALSE./,WRDPTZ/.FALSE./,WRDSTZ/.FALSE./,
     1     WRDEVZ/.FALSE./,NESTZ/.FALSE./,RHANL/.TRUE./,IHOLEZ/.FALSE./,
     2     DTAFTZ/.FALSE./,UVSAVZ/.FALSE./,NOFLGZ/.FALSE./,
     3     PDOMNZ/.FALSE./,PALLZ/.FALSE./,SLECTZ/.FALSE./,
     4     EXTVRZ/.FALSE./,PRDTAZ/.FALSE./,ANAVGZ/.TRUE./,
     5     ZSRFZ/.FALSE./,DVSRTZ/.FALSE./,WRRESZ/.FALSE./,
     6     MERCPZ/.FALSE./,LLWLZ/.FALSE./,TIMWNZ/.TRUE./,UNIQZ/.TRUE./,
     7     PRTAZZ/.FALSE./,PRTBGZ/.FALSE./
C
      DATA KDATZ/5/,JPDZ/2/,ITPMNZ/0/,ITPMXZ/4/,NEXZ/0/,
     1     ITPEXZ/NEXDIM*0/,NSTIKZ/1/,KLSTKZ/KLDIM*0/,ISPTPZ/11/,
     2     DXSPDZ/0.5/,DYSPDZ/0.5/,THRSHZ/100./KXTOFZ/0/,USTMZ/0.0/,
     3     VSTMZ/0.0/
C
C     DATA STATMENT FOR COMMON DSK, NAMELIST DSKVAL
C
      DATA MSKEF/11/,MSKEZ/12/,MSKDA1/13/,MSKDA2/14/,MSKDA3/15/,
     1     MSKDA4/16/,MSKDA5/17/,MSKDA6/18/,MSKDA7/19/,MSKDA8/20/,
     2     MSKDA9/21/,MSKD11/23/,MSKD12/24/,MSKD13/25/,MSKD14/26/,
     3     MSKD15/27/,MSKD16/28/,MSKD17/29/,MSKD18/30/
C
C     DATA STATEMENT FOR NAMELIST DOMAIN
C
      DATA MXZ/20/,NXZ/20/,ISRCDZ/0/,DUTMNZ/10./,DUTMXZ/50./
CCCC 1     ELORG/-99.0/,GLORG/-99.0/
C
C     DATA STATEMENT FOR NAMELIST DCBC
C
      DATA KDCZ/3/,XDCWLZ/6./,YDCWLZ/6./,KXBC1Z/21/,KXBC2Z/21/,
     1     KYBC1Z/21/,KYBC2Z/21/,XBCL1Z/10./,XBCL2Z/10./,YBCL1Z/10./,
     2     YBCL2Z/10./
C
C     DATA STATEMENT FOR COMMON PRES
C
CIBM  INITIALIZATION FOR PLEV MOVED FROM SUBROUTINE XDTSRT
      DATA PLEV/200.,250.,300.,400.,500.,700.,850.,1000./
      DATA DPRXZ/25./
      DATA ICOOR/1/,IDAT/4/,IDATZ/3/
C
C     DATA STATEMENT FOR NAMELIST SUBM
C
      DATA XSBM0Z/-1.1/,XSBMXZ/1.2/,YSBM0Z/-0.8/,YSBMXZ/1.4/
C
C     DATA STATEMENT FOR COMMON AZI AND OTHER VARIABLES
C
C     UNITS FOR RAD0, DRAD ARE IN KM FOR MORE CONVENIENT USER INTERACTIO
C       THIS IS AN EXCEPTION TO THE STANDARD INTERNAL UNIT, WHICH IS
C       DEGREES LATITUDE.  RADFCI=1./111.1775 CONVERTS KM TO DEG. LAT.
      DATA RADFCI/.0089946/,
     1     NRDMN/1/,NRDMX/1/,RAD0/0.0/,THTAMX/360./,
     2     DRAD/1.0/,DTHETA/5.0/,RADSHZ/3.0/,UVTORT/.FALSE./
     3     IHCZ/0/,NSWLNZ/1/,MESHCZ/1/
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE XDTSUB(KPLV,KDAT,DWF,ITYPMN,ITYPMX,NEX,ITYPEX,NEST,
     1                  NOFLAG,PDOMAN,PALL,SELECT,PRDATA,DPR,NSWLN,
     2                  UNIQUE,NFIXPZ,TIMWNZ,IDAYMX,UTCMX,UTCMN,DUTCMN,
     3                  DUTCMX,STMID)
C       OUTPUT ARG. IDAYMX - SLORD DATE FORMAT FOR DATE (YYYYMMDD) (MAX)
C
      PARAMETER (MDIM=35,NDIM=35)
      PARAMETER (LDXDIM=8000)
      PARAMETER (NFXDIM=20,NTPDIM=30)
      PARAMETER (KLDIM= 8)
      PARAMETER(KVDIM=20,KDTDIM=5,NEXDIM=5)
C**SIG      PARAMETER(KVDIM= 7,KDTDIM=5,NEXDIM=5)
      PARAMETER (KDXDIM=KDTDIM*KLDIM)
      PARAMETER (KPXDIM=KVDIM*KLDIM)
C
CIBM  THE FOLLOWING COMMON MAY SAVE SOME EXECUTION SPACE ON THE
CIBM     PITIFULLY SMALL IBM.
CIBM  COMMON /IND/ INDX(LDXDIM,NTPDIM)
      COMMON /IND/ INDX(LDXDIM)
C
CIBM  COMMON /S2PRIC/ IDSPC,ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,
CIBM 1                 YNB,YNT,XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4)
      COMMON /AFD/A(KDXDIM,MDIM,NDIM),FD(KDXDIM,LDXDIM),
     1            FKMN(KPXDIM,MDIM,NDIM)
      COMMON /S2PRIC/ ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,YNB,YNT,
     1                 XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4),IDSPC
      COMMON/S2DTPT/IDSPD1,IDSPD2,LDX,XD(LDXDIM),YD(LDXDIM),WD(LDXDIM),
     1              ID(LDXDIM),LXSORT(LDXDIM)
      COMMON /DSK/MSKEF,MSKEZ,MSKDA1,MSKDA2,MSKDA3,MSKDA4,MSKDA5,MSKDA6,
     1            MSKDA7,MSKDA8,MSKDA9,MSKD11,MSKD12,MSKD13,MSKD14,
     2            MSKD15,MSKD16,MSKD17,MSKD18
      COMMON/XYT/IDAYOB(LDXDIM),UTCOB(LDXDIM),XSTM(NFXDIM),YSTM(NFXDIM),
     1           WSTM(NFXDIM),IDAYST(NFXDIM),UTCSTM(NFXDIM),ELORG,GLORG,
     2           XSTM0,YSTM0,JDAY0,UTC0,NFIX0,IDAYMN
      COMMON /PRES/ PLEV(KLDIM),RHANL,DATREC(KDTDIM+1),ICOOR,IDAT,IDATZ
      COMMON /TMMNMX/ IYMN,IMMN,IDMN,IHMN,IYMX,IMMX,IDMX,IHMX,IY0,IM0,
     1                ID0,HR0
      COMMON /DWATE/ WDR(NTPDIM),JSKEEM(NTPDIM),IDTYP(100),JDTYP(NTPDIM)
C
      CHARACTER*8 IDSPD1,IDSPD2*72,IDSPC*125,FLAG*1,STMID*12
      LOGICAL KPLV(KLDIM,KVDIM),NEST,RHANL,NOFLAG,PDOMAN,PALL,SELECT,
     1        PRDATA,NOGOOD,TIMWIN,TIMWNZ,UNIQUE
      DIMENSION JDAT(8),LDAT(8),RINC(5)
      REAL(8)  HEAD_8(5)
      SAVE
      DIMENSION DWF(KDAT*KLDIM),DATA(KDTDIM),FLAG(KDTDIM),
     1          ITYPEX(NEXDIM),PMN(7),PMX(7),LDSORT(LDXDIM),
     2          XDZ(LDXDIM),FDD(LDXDIM),LDXTYP(NTPDIM)
CIBM 3          INDX(LDXDIM,NTPDIM)
      EQUIVALENCE (PR,DATREC(1)),(DATA(1),DATREC(2))
C
      DATA  PMN/100.,350.,400.,450.,500.,550.,1001./,
     1      PMX/349.,399.,449.,499.,549.,1000.,1075./
C
C     ******* CHANGE PLEV AND DPR BELOW FOR A DIFFERENT VERTICAL
C             COORDINATE  *******
C
CIBM  THE FOLLOWING INITIALIZATION MOVED TO BLOCK DATA
CIBM  INCLUDE 'PLEV/LIST'
      DATA FMS/0.33/,PSRF/1013.0/,FLAG/KDTDIM*'0'/
C

C-----------------------------------------------------------------------

      ENTRY XDTSRT(KPLV,KDAT,DWF,ITYPMN,ITYPMX,NEX,ITYPEX,NEST,NOFLAG,
     1             PDOMAN,PALL,SELECT,PRDATA,DPR,NSWLN,UNIQUE)
C
C     THIS ENTRY READS EACH DATA RECORD, CHECKS PRESSURE LEVEL TO
C     SEE IF IT BELONGS TO THE CURRENT FIELD GEOMETRY, AND STORES DATA
C     IN ARRAY FD FOR CHECKING.  AFTER CHECKING AND FILLING IN MISSING
C     VALUES WITH BOGUS VALUES, THE COMPLETE DATA SET IS WRITTEN TO
C     DISK.  CURRENTLY, ANY FIELD WITH MORE THAN 33 PCNT (FMS) OF DATA
C     MISSING IS NOT BOGUSSED.
C     KDAT IS THE NUMBER OF VARIABLES PER CARD, KLDIM IS THE NUMBER OF L
C     KDXDIM IS THE NUMBER OF VARIABLES*NUMBER OF LEVELS, LDX COUNTS
C     OBSERVATIONS READ, LDXDIM IS THE MAXIMUM NUMBER OF OBSERVATIONS
C
      ICOUNT=0
      KDDIM=KDAT*KLDIM
C
      FD=-99.0
      WD=-99.0
      XD=-99.0
      YD=-99.0
C
      LDX=1
C
C     AUTOMATIC (POTENTIAL) ACCEPTANCE OF DATA AT ALL PRESSURE LEVELS
C     WHEN SELECT IS TRUE.  IN THIS CASE, KPLV DETERMINES WHICH
C     PRESSURE LEVELS DATA WILL BE STORED.
C     CHECK IF TOO MUCH IS EXCLUDED FROM THE ANALYSIS
C
      IF(SELECT)  PALL=.TRUE.
      IF(NEX .GT. NEXDIM) GO TO 995
C
C     DATA READING FOR ODW....WD IS READ IN AS DATA TYPE AND STORED LATE
C         INTO ID (DATA TYPE).  AFTER THAT POINT, WD IS DATA WEIGHT.
C         MAXIMUM ALLOWED DATA TYPES IS 30  (=NTPDIM).  ALSO, TWO SPOTS
C         ARE RESERVED FOR STORM TRACK AND T=0 POSITION (98&99)
C     DATA TYPES:
C          1...ODW
C          2...RAWINSONDE
C          3...NOAA P-3 AIRCRAFT
C          4...SURFACE SHIPS
C          5...COMMERCIAL AIRCRAFT
C          6...AIR FORCE RECONAISSANCE
C          7...AIR FORCE VORTEX DATA
C          8...AIRBORNE DOPPLER DATA
C          9...PIBAL AND/OR SIGNIFICANT LEVEL OBS.
C          10..VERTICALLY INTERPOLATED (1-D SPLINE)
C          11..VERTICALLY INTERPOLATED (2-D SPLINE)
C          12..NCEP (REGIONAL) ANALYSIS VALUE
C          13..NHC (ATOLL) ANALYSIS VALUE
C          20..VAS TEMPERATURE & MOISTURE SOUNDING
C          21..WISCONSIN CLOUD TRACK WIND
C          22..VAS-DERIVED GRADIENT WINDS
C          23..VAS-DERIVED WATER VAPOR WINDS
C          24..NCEP CLOUD DRIFT WINDS
C          25..NHC CLOUD DRIFT WINDS
C          26..TIROS POLAR ORBITING SATELLITE
C          50..BOGUS DATA (MANUALLY ENTERED)
C          51..BACKGROUND VALUE (REGIONAL ANALYSIS GRIDDED FIELD)
C          52..BACKGROUND VALUE (ATOLL ANALYSIS GRIDDED FIELD)
C          98..STORM TRACK
C          99..HURRICANE POSITION AT TIME T=0
C     READ DATA.  IF ALL DATA ARE READ, GOTO 25.  IF NOT, GOTO 40 TO RET
C
      igo = 20
   20 READ(MSKDA1,ERR=910,END=25) WX,IDAYX,UTCX,YX,XX,PR,
     1     (DATA(K),K=1,KDAT),(FLAG(KFL),KFL=1,KDAT-1)
      ICOUNT = ICOUNT + 1
C
C**   DEBUG PRINTOUT:
c && 7 comments
CC    IF(MOD(ICOUNT,100) .EQ. 1) THEN
CC      WRITE(6,21)  ICOUNT,WX,IDAYX,UTCX,YX,XX,PR,(DATA(K),K=1,KDAT),
CC   1                 (FLAG(KFL),KFL=1,KDAT-1)
CC 21   FORMAT('...FOR ICOUNT=',I8,' WX,IDAYX,UTCX,YX,XX,PR,DATA,FLAG=',
CC   1         /,3X,F3.0,1X,I9,1X,F5.0,1X,2(F7.3,1X),3(F6.1,1X),F7.1,
CC   2         2(F6.1,1X),4A1)
CC    ENDIF
C
      GO TO 40
   25 IF(.NOT. NEST)  GO TO 130
C
C     AUTOMATIC ACCEPTANCE OF ALL NESTED DATA
C
      FLAG(1:KDAT-1)='0'
C
      igo = 30
C
C     READ SPLINE INTERPOLATED DATA FOR NESTED SUBMESH
C
      OPEN(UNIT=MSKDA6,ACCESS='SEQUENTIAL',FORM='UNFORMATTED',
CVAX 1     FILE='RNSTDAT',STATUS='OLD',READONLY,SHARED)
CIBM 1     FILE='RNSTDAT',STATUS='OLD',ACTION='READ')
     1     FILE='RNSTDAT',STATUS='UNKNOWN')
   30 READ(MSKDA6,END=130) WX,IDAYX,UTCX,YX,XX,PR,DATA
C
C     DEBUG PRINTOUT
c && 7 comments
CC    IF(ICOUNT .LE. 15) THEN
CC      WRITE(6,31)  WX,IDAYX,UTCX,YX,XX,PR,(DATA(K),K=1,KDAT)
CC 31   FORMAT('...WX,IDAYX,UTCX,YX,XX,PR,DATA=',/,
CC   1         F3.0,1X,I9,1X,F4.0,1X,2(F7.3,1X),3(F6.1,1X),
CC   2         F7.1,2(F6.1,1X))
CC      ICOUNT = ICOUNT + 1
CC    ENDIF
C
   40 LDXX=LDX
      CALL XTIME(IDAYX,UTCX,IYX,IMX,IDX,HRX)
C
C     A WHOLE BUNCH OF SELECTIVE IF STATEMENTS FOR THE RIGHT KIND OF
C     DATA
C
C     MAKE SURE DATA POINT IS WITHIN THE BOUNDARIES (SET UP IS FOR
C       LAT/LONG COORDS.  IDEA IS TO PREVENT DATA FROM OTHER NESTED
C       GRIDS FROM BEING INCLUDED IN THE BOGUS STATISTICS BELOW.
C
      IF(NEST) THEN
      IF(NSWLN .GT. 0)  THEN
      IF(XX .GT. ABS(XML)+2. .OR. XX .LT. ABS(XMR)-2. .OR.
     1   YX .LT. YNB-2. .OR. YX .GT. YNT+2.)  go to 9999
      ELSE
      IF(XX .LT. XML-2. .OR. XX .GT. XMR+2. .OR.
     1   YX .LT. YNB-2. .OR. YX .GT. YNT+2.)  go to 9999
      ENDIF
      ENDIF
C
C     MAKE SURE DATA TYPE IS ALLOWABLE
C
      IF(IFIX(WX) .LT. ITYPMN .OR. (IFIX(WX) .GT. ITYPMX .AND. IFIX(WX)
     1            .NE. 50))  go to 9999
C
C     CHECK FOR EXCLUDED DATA TYPES
C
      DO NEXX=1,NEX
      IF(IFIX(WX) .EQ. ITYPEX(NEXX))  go to 9999
      ENDDO
C
C     CHECK IF DATA TIME IS CORRECT
C
      IF(TIMWIN)  THEN
      IF(IYX .LT. IYMN)  go to 9999
      IF(IMX .LT. IMMN .AND. (IYX .EQ. IYMN))  go to 9999
      IF(IDX .LT. IDMN .AND. (IMX .EQ. IMMN .AND. IYX .EQ. IYMN))
     1    go to 9999
      IF(HRX .LT. HRMN .AND. IDX .EQ. IDMN .AND. IMX .EQ. IMMN
     1   .AND. IYX .EQ. IYMN)  go to 9999
      IF(IYX .GT. IYMX)  go to 9999
      IF(IMX .GT. IMMX .AND. IYX .EQ. IYMX)  go to 9999
      IF(IDX .GT. IDMX .AND. (IMX .EQ. IMMX .AND. IYX .EQ. IYMX))
     1    go to 9999
      IF(HRX .GT. HRMX .AND. (IDX .EQ. IDMX .AND. IMX .EQ. IMMX
     1   .AND. IYX .EQ. IYMX))  go to 9999
      ENDIF
C
C     VERTICAL COORDINATE SELECTION:  THREE OPTIONS ARE AVAILABLE.
C     1) FOR A VERTICAL DOMAIN INSTEAD OF INDIVIDUAL LEVELS, PDOMAN=.TRU
C        AND THE FIRST IF STATEMENT BELOW IS ACTIVATED.
C     2) FOR INDIVIDUAL VERTICAL LEVELS, THE SECOND IF STATEMENT BELOW
C        IS ACTIVATED (PDOMAN=PALL=.FALSE.)
C     3) FOR ALL LEVELS, USING THE IDENTICAL GEOMETRY WITH HEIGHT, PALL=
C        AND BOTH IF STATEMENTS BELOW ARE INACTIVATED.
C     4) FOR MULTIPLE SELECTED LEVELS, SELECT=.TRUE.
C     DEFINE VERTICAL COORDINATE: PUT EITHER PRESSURE OR HEIGHT INTO DAT
C
      VCOORD=DATREC(ICOOR)
      DATAZ=DATREC(IDAT)
      DATA(IDATZ)=DATAZ
C
C     DOMAIN OPTION:  CHECK IF THE DATA ARE BETWEEN THE DESIRED LEVELS
C
      IF(PDOMAN .AND. (VCOORD .LT. PMN(JPD) .OR.
     1                  VCOORD .GT. PMX(JPD)))  go to 9999
C
C     INDIVIDUAL LEVEL OPTION:  CHECK IF THE DATA ARE WITHIN THE DESIRED
C     PRESSURE WINDOW
C
      IF((.NOT. PDOMAN .AND. .NOT. PALL) .AND.
     1     ABS(VCOORD-PLEV(JPD)) .GT. DPR)  go to 9999
C
C     MULTIPLE SELECTED LEVELS: PERFORM A PRELIMINARY PRESSURE CHECK
C                               TO MAKE SURE DATA LIES AT A REQUESTED
C                               ANALYSIS LEVEL.  GOTO 47 IF ALL LEVELS
C                               ARE ADMITTED.  FIRST, CHECK IF PARTICULA
C                               LEVEL AND VARIABLE ARE SELECTED, THEN TH
C                               DATA ARE WITHIN THE DESIRED PRESSURE LEV
C
      IF(.NOT. SELECT)  GO TO 47
C
      DO KPL=1,KLDIM
         DO KD=1,KDAT
            IF(.NOT. KPLV(KPL,KD))  GO TO 46
            IF(ABS(VCOORD-PLEV(KPL)) .LE. DPR)  GO TO 47
   46       CONTINUE
         ENDDO
      ENDDO
C
      go to 9999
C
C     ACCEPT DATA, BUT REJECT IF TIME AND LOCATION DATA ARE DUPLICATE
C
   47 LNEW=0
      LP=LDXX
C
      IF(UNIQUE)  THEN
      DO 50 L=1,LDXX-1
      LP=L
      IF(XX .EQ. XD(L) .AND. YX .EQ. YD(L) .AND. WX .EQ. WD(L) .AND.
     1   IDAYX .EQ. IDAYOB(L) .AND. UTCX .EQ. UTCOB(L))  GO TO 60
   50 CONTINUE
      LP=LDXX
      ENDIF
C
C     CHECK IF THERE ARE TOO MANY OBSERVATIONS
C
      IF(LDX .GT. LDXDIM) GO TO 930
C
C     STORE THE NEW DATA POINT......
C     WARNING: HURPOS MUST BE CALLED FIRST
C
      LNEW=1
      XD(LDX) =XX
      YD(LDX) =YX
      WD(LDX) =WX
      IF(PRDATA)  WRITE(6,51)  LDX,WD(LDX),XD(LDX),YD(LDX),UTCX,IDAYX,
     1            (FLAG(KFL),KFL=1,KDAT-1)
   51 FORMAT(' ***** DATA LOCATION PT.#',I6,'  TYPE=',F3.0,
     1       '  X=',F6.1,'  Y=',F6.1,' UTC=',F6.0,'  DAY=',I10,
     2       '  FLAG=',4A1)
      IDAYOB(LDX)=IDAYX
      UTCOB(LDX)=UTCX
      LDX=LDX+1
C
C     SET INDICES FOR DISTRIBUTION OF DATA VERTICALLY (IN A LAYER OF
C     THICKNESS DPR).  DO NOT DO IF DATA ARE NOT WITHIN THE PRESSURE WIN
C
   60 KPMN=KLDIM+1
      KPMX=0
C
      DO 70 KPL=1,KLDIM
      IF(ABS(VCOORD-PLEV(KPL)) .GT. DPR)  GO TO 70
      KPMN=MIN(KPMN,KPL)
      KPMX=MAX(KPMX,KPL)
   70 CONTINUE
C
C     CHECK IF DATA HAVE BEEN ACCEPTED
C
      IF(KPMX .EQ. 0 .OR. KPMN .EQ. KLDIM+1)  GO TO 990
C
C     FOR UNCONDITIONAL STORAGE OF DATA POINTS, CHANGE ABOVE "GO TO 80"
C     BRANCH TO "GO TO 89", AND COMMENT OUT ALL CODE FROM STATEMENT
C     NUMBERS 80-88(+) BELOW.
C
      NOGOOD=.FALSE.
C
      DO 100 KP=KPMN,KPMX
      IGOOD=0
      IPERT=0
C
C     ONLY A SINGLE FLAG IS GIVEN SO IT MUST BE COPIED INTO THE SECOND
C     WIND COMPONENT.  ASSUME WINDS ARE THE LAST TWO DATA SLOTS.
C
      FLAG(KDAT)=FLAG(KDAT-1)
      DO 85 KV=1,KDAT
C
C     MAKE SURE DATA ARE TO BE ACCEPTED
C
      IF(.NOT. KPLV(KP,KV))  GO TO 85
      IPERT=1
C
C     SELECTIVE IF STATEMENT FOR MISSING DATA OR DATA FLAGGED AS SUSPICI
C     ******  IMPORTANT NOTE:  AS OF 6/22/88, YOU MAY ENTER A
C                              BOGUS DATA POINT WITH MISSING DATA
C                              AND THE PROGRAM WILL FILL IN VALUES
C                              FROM NEIGHBORING DATA POINTS THAT DO
C                              NOT HAVE MISSING DATA.
C
      IF(IFIX(WX) .NE. 50)  THEN
      IF(DATA(KV) .EQ. -99.0 .OR. (FLAG(KV) .EQ. 'X' .AND.
     1                            (.NOT. NOFLAG .OR. WX .EQ. 1)))
     2                             GO TO 85
      ENDIF
      IGOOD=IGOOD+1
      IF(PRDATA .AND. IGOOD .EQ. 1)  WRITE(6,84) VCOORD,PLEV(KP),
     1                               (DATA(KDD),KDD=1,KDAT)
   84 FORMAT(40X,'  ...VCOORD,PRLEV,T,RH,Z,U,V=',
     1       2F7.1,2F6.1,F7.1,2F6.1)
   85 CONTINUE
      IF(IGOOD .GE. 1 .OR. IPERT .EQ. 0)  GO TO 87
      NOGOOD=.TRUE.
      IF(PRDATA)  WRITE(6,86) LDXZZ1,XD(LDXZZ1),YD(LDXZZ1),
     1            (DATA(KDD),KDD=1,KDAT)
   86 FORMAT('  -- NO PERT. DATA AT PT.#',I4,11X,' X=',F6.1,'  Y=',
     1       F6.1,/,29X,'   DATA=',5F10.3)
      GO TO 100
C
C     OPTIONAL CONVERSION OF RELATIVE HUMIDITY TO MIXING RATIO FOR SPLIN
C     ******  NOTE: RELATIVE HUMIDITY (DATA(2)) IS IN PERCENT  *****
C             TEMPERATURE IS DATA(1)
C             THEREFORE MULTIPLY BY 10. TO CONVERT TO G/KG
C     CHECK THAT RELATIVE HUMIDITY IS ACCEPTED OR EXISTS
C
   87 IF(.NOT. KPLV(KP,2) .OR. RHANL .OR. DATA(2) .EQ.-99.0)  GO TO 89
C
C     CHECK THAT TEMPERATURE DATA EXIST
C
      IF(DATA(1) .NE. -99.0)  GO TO 88
      LDXZZ1=LDX-1
      WRITE(6,871)  LDXZZ1,XD(LDXZZ1),YD(LDXZZ1)
  871 FORMAT('  ** NO TEMP FOR Q CALC PT#',I3,10X,'  X=',F6.1,'  Y=',
     1       F6.1)
      NOGOOD=.TRUE.
      GO TO 100
C
C        ******  NOTE:  SATURATION CALCULATION IS WITH RESPECT TO ICE IF
C                       PRESSURE LEVEL IS 300 MB OR LESS  (CORRESPONDING
C                       TO A TEMPERATURE OF ABOUT -30 DEG C). THIS BRANC
C                       IS WITH RESPECT TO PRESSURE RATHER THAN TEMPERAT
C                       TO PREVENT HORIZONTAL DISCONTINUITIES DURING THE
C                       SPLINE ANALYSIS.  ADDITIONAL SCALING FACTOR OF
C                       100 IS USED FOR MIXING RATIO AT UPPER LEVELS
C     IF AVAILABLE, USE SURFACE PRESSURE FROM SOUNDING FOR MIXING RATIO
C     CALCULATION.  IF NOT, USE PSRF=1013.0 MB.
C
   88 IF(KP .NE. KLDIM)THEN
        PRX=PR
      ELSEIF(DATA(3) .EQ. -99.0)THEN
        PRX=PSRF
      ELSE
      PRX=DATA(3)
      ENDIF
C
C     CALCULATE MIXING RATIO
C
      IF(NINT(PR*10.) .GT. 3000)  THEN
         QS=QSATW(DATA(1)+273.16,PRX)
      ELSE
         QS=QSATI(DATA(1)+273.16,PRX)
      END IF
      DATA(2)=DATA(2)*QS*10.
   89 DO 90 K=1,KDAT
C
C     CHECK IF DATA ARE MISSING
C
      IF(DATA(K) .EQ. -99.0)  GO TO 90
C
C     CHECK IF DATA WERE PREVIOUSLY ACCEPTED
C
      IF(FD((K-1)*KLDIM+KP,LP) .NE. -99.0 .AND. WX .GT. WD(LP))
     1    GO TO 90
C
C     PRINTOUT POINTS WITH DUPLICATE DATA (ALL WITHIN THE PRESSURE
C       WINDOW)
C
      IF(FD((K-1)*KLDIM+KP,LP) .NE. -99.0 .AND. KP .EQ. KPMN
     1   .AND. K .EQ. 1 .AND. LNEW .EQ. 0)  THEN
      WRITE(6,891) IFIX(WD(LP)),XD(LP),YD(LP),KP,PLEV(KP),
     1             (FD((KK-1)*KLDIM+KP,LP),DATA(KK),KK=1,KDAT)
  891 FORMAT(5X,'... FOR ID=',I3,', XD, YD=',2F8.3,
     1       ', AND KP, PLEV(KP)=',I3,F7.0,
     1       ', DUPLICATE DATA FOUND. OLD, NEW=',/,40X,10F7.1)
      ENDIF
C
C     PUT DATA INTO FD
C
      FD((K-1)*KLDIM+KP,LP)=DATA(K)
   90 CONTINUE
  100 CONTINUE
C
      IF(NOGOOD)  LDX=LDX-LNEW
C
C     READ NEXT DATA CARD
C
      go to 9999
  130 LDX=LDX-1
C
C     CHECK IF ANY DATA HAVE BEEN ACCEPTED
C
      IF(LDX .EQ. 0)  GO TO 920
C
C     CLOSE RAW DATA FILE
C
      CLOSE(UNIT=MSKDA1,STATUS='KEEP')
      WRITE(6,131)  LDX,ITYPMN,ITYPMX,(ITYPEX(NEXX),NEXX=1,NEX)
  131 FORMAT(/'....XDTSRT HAS READ DATA....',I5,' POINTS...',/,
     1       ' ....MINIMUM  DATA TYPE IS',I4,/,
     2       ' ....MAXIMUM  DATA TYPE IS',I4,/,
     3      (' ....EXCLUDED DATA TYPE IS',I4))
C
      WRITE(6,132)
  132 FORMAT('....TRANSFORM COORDINATES AND WEIGHT DATA.')
C
C     TRANSFORM X,Y,TIME COORDINATES:
C               0000 UTC ON DAY OF FIRST OBSERVATION OR FIX IS T=0.
C                   TIME IS MEASURED IN FRACTIONAL HOURS FROM T=0.
C                   A SPECIFIC TIME, T=T0, IS DEFINED AS A CENTRAL
C                   TIME FOR THE OBSERVATIONS.
C               FOR FIXED EARTH COORDINATES, X,Y ARE MEASURED RELATIVE
C                   TO SOUTHWEST CORNER OF DOMAIN.  HURRICANE TRACK AND
C                   POSITION AT TIME T=T0 ARE PRINTED.
C               FOR STORM-RELATIVE COORDINATES, ONLY A SINGLE HURRICANE
C                   POSITION IS PRINTED.  POSITIONS OF ALL OBSERVATIONS
C                   ARE MEASURED WITH RESPECT TO THIS POSITION.
C
      IF(NSWLN .GT. 0)  CALL CSGNLN(NFIXP)
      CALL CTRANS(NFIXP)
C
C     DATA WEIGHTING.  THERE ARE THREE OPTIONS WHICH MAY BE ASSIGNED
C       INDIVIDUALLY FOR EACH DATA TYPE.  SEE SUBROUTINE WTDAT
C       FOR DETAILS.
C
      CALL RWT
C
      LDXTYP=0
C
CIBM  WE CREATE AN OUTER LOOP TO SELECT A SINGLE DATA TYPE AT A TIME
CIBM    IN ORDER TO SAVE SPACE
C
      WRITE(6,141) (NTP,NTP=1,NTPDIM),(JDTYP(NTP),NTP=1,NTPDIM),
     1             (JSKEEM(NTP),NTP=1,NTPDIM)
  141 FORMAT(//35X,'=== DATA WEIGHTING SCHEMES ===',/,
     1       13X,'NTP=',30I3,/,7X,'DATA TYPE=',30I3,/,10X,
     2       'SCHEME=',30I3)
C
      WRITE(6,142)
  142 FORMAT(/39X,'DATA WEIGHT TABLE',/,18X,'TYPE',4X,'SCHEME',
     1       6X,'REL. WT.',5X,'# PTS',6X,'# CELLS',4X,'ABS. WT.')
C
      DO 160 NTP=1,NTPDIM
C
        DO 150 LD=1,LDX
        CALL DOMCHK(XD(LD),YD(LD),IN)
        IF(NTP .EQ. 1)  ID(LD)=IFIX(WD(LD))
c fixit?? - out of bounds error is possible on 'IDTYP', I made this
c           change to avoid the problem
cdak    IDZZ=IDTYP(ID(LD))
        if(ID(LD).gt.0)  then
           IDZZ=IDTYP(ID(LD))
        else
           idzz=0
        endif


        IF(IDZZ .EQ. NTP)  THEN
          IF(IN .EQ. 0)  THEN
C     OUTSIDE ANALYSIS REGION
            WD(LD)=-99.0
            ID(LD)=-ID(LD)
            ELSE
C     INSIDE ANALYSIS REGION: SET RELATIVE WEIGHT AND PREPARE
C       FOR ABSOLUTE WEIGHT CALCULATION
C
            WD(LD)=WDR(IDZZ)
            LDXTYP(IDZZ)=LDXTYP(IDZZ)+1
CIBM        INDX(LDXTYP(IDZZ),IDZZ)=LD
            INDX(LDXTYP(IDZZ))=LD
          ENDIF
        ENDIF
  150   CONTINUE
C
CIBM  DO 160 NTP=1,NTPDIM
      IF(LDXTYP(NTP) .EQ. 0)  GO TO 160
CIBM  CALL WTDAT(JSKEEM(NTP),LDXTYP(NTP),JCELLX,WFAC,INDX(1,NTP))
      CALL WTDAT(JSKEEM(NTP),LDXTYP(NTP),JCELLX,WFAC,INDX)
      WRITE(6,159) JDTYP(NTP),JSKEEM(NTP),WDR(NTP),LDXTYP(NTP),JCELLX,
     1             WFAC
  159 FORMAT(17X,I3,7X,I2,9X,F6.3,4X,I7,8X,I4,6X,F6.3)
  160 CONTINUE
C
C     PRINT DATA LOCATIONS AND POINT DATA VALUES
C
      CALL PRDLOC(NFIXP)
C
C     SORT DATA POINTS BY INCREASING XD, THEN CHECK FOR MISSING DATA
C     PUTTING DATA INTO FDD
C
      XDZ(1:LDX)=XD(1:LDX)
C
      CALL SORTRL(XDZ,LDSORT,LDX)
C
      LXSORT(1:LDX)=LDSORT(1:LDX)
C
      WRITE(6,199) FMS
  199 FORMAT('....CHECK FOR MISSING DATA (CUTOFF IS',2PF5.1,'PERCENT).')
C
      DO 280 KF=1,KDDIM
      NMS=LDX
      DO 240 L=1,LDX
      FDD(L)=-99.0
      IF(FD(KF,L) .EQ. -99.0)  GO TO 240
      NMS=NMS-1
      FDD(L)=FD(KF,L)
  240 CONTINUE
      FRMS=REAL(NMS)/REAL(LDX)
      KV=(KF-1)/KLDIM+1
      KL=MOD(KF,KLDIM)
      IF(KL .EQ. 0)  KL=KLDIM
C
c && 3 comments
CC    WRITE(6,2226) KF,KV,PLEV(KL),FRMS
C2226 FORMAT('....KF=',I4,'...KV=',I4,'  (',F5.0,' MB) CHECKED...',
CC   1       2PF5.1,' PERCENT MISSING')
C     CHECK IF MUCH OF THE DATA ARE MISSING
C
      IF(FRMS .GT. FMS)  GO TO 270
      NBOGUS=0
C
C     CHECK IF INDIVIDUAL DATA TYPES ARE MISSING
C
      DO 260 L=1,LDX
      IF(FDD(L) .NE. -99.0)  GO TO 260
      LP=L
C
C     FIND THE SORT INDEX
C
      DO 250 LL=1,LDX
      LD=LL
      IF(LXSORT(LL) .EQ. LP)  GO TO 255
  250 CONTINUE
      WRITE(6,2116)
 2116 FORMAT(/'****** CANNOT FIND LDSORT INDEX IN XDTSRT')
      CALL ABRT1(' XDTSRT',2116)
  255 CONTINUE
C
c && 3 comments
CC    WRITE(6,1111) XD(LP),YD(LP),KF,LP,LD
C1111 FORMAT('..... BOGUS CALLED AT X=',F5.1,', Y=',F5.1,' FIELD #',
CC   1 I4,', POINT #',I5,', AND SORTED #',I5)
C     LINEARLY INTERPOLATE MISSING VALUE (BOGUS POINT) AND PUT BACK INTO
C
      NBOGUS=NBOGUS+1
C** DEBUG
      IPRT=0
      IF(KV .EQ. 4 .OR. KV .EQ. 5)  IPRT=1
      CALL BOGUS(LD,LP,FDD,DV,IPRT)
      FD(KF,LP)=DV
C
c && 2 comments
CC    WRITE(6,2101) FD(KF,LP)
C2101 FORMAT('.... BOGUS VALUE IS',F10.2)
C
  260 CONTINUE
      WRITE(6,261)  KL,KV,NBOGUS,LDX,FRMS
  261 FORMAT('....KL=',I3,', KV=',I4,': # BOGUS PTS.=',I4,
     1       ', TOTAL PTS.=',I5,', FRMS=',2PF5.1,'PERCENT')
      GO TO 280
  270 IF(KPLV(KL,KV))  WRITE(6,276) KL,KV,FRMS
  276 FORMAT('****KL=',I3,', KV=',I4,': FRMS=',2PF5.1,
     1       ' PERCENT (EXCEEDS CUTOFF)')
      KPLV(KL,KV)=.FALSE.
      IF(KV .LE. 3)  GO TO 280
      IF(KV .EQ. 4)  KPLV(KL,5)=.FALSE.
      IF(KV .EQ. 5)  KPLV(KL,4)=.FALSE.
      KPLV(KL,6)=.FALSE.
  280 CONTINUE
C
C     PRINT UPDATED DATA FIELDS
C     WRITE COMPLETE DATA FILE TO MSKDA3
C
C
C     OPENING ALLDAT HANDLED BY CRAY JCL
C
C     OPEN(UNIT=MSKDA3,ACCESS='SEQUENTIAL',FORM='UNFORMATTED',
C    1     FILE='ALLDAT',STATUS='UNKNOWN')
C
      DO 290 L=1,LDX
      DWF(1:KDDIM)=FD(1:KDDIM,L)
      HEAD_8(1)=WD(L)
      HEAD_8(2)=REAL(IDAYOB(L))
      HEAD_8(3)=UTCOB(L)
      HEAD_8(4)=XD(L)
      HEAD_8(5)=YD(L)
      WRITE (MSKDA3) HEAD_8,DWF
  290 CONTINUE
C
C     CLOSE(UNIT=MSKDA3,STATUS='KEEP')
      REWIND MSKDA3
CIBM  WRITE(1,291) LDX
C 291 FORMAT(/'...INPUT DATA HAVE BEEN READ, LDX=',I8)
      RETURN
 9999 continue
      if(igo.eq.20)  then
         go to 20
      else  if(igo.eq.30)  then
         go to 30
      else
         call ABRT1(' XDTSRT',9999)
      endif

C-----------------------------------------------------------------------

      ENTRY FNDDAY(STMID,NFIXPZ,TIMWNZ)
C
C     THIS ENTRY READS STMID, WSTM, NFIXB, NFIXE AND NFIXP FROM THE
C       STMDAT FILE AND JDAY0 AND UTC0 FROM THE SAME FILE IF IT IS
C       MISSING.  NFIXB IS INDEX OF THE FIX BEGINNING THE TIME WINDOW
C       FOR DATA, NFIXE ENDS THE TIME WINDOW, AND NFIXP IS THE TOTAL
C       NUMBER OF FIXES READ, AND MAY INCLUDE FORECAST POSITIONS
C       TO BE PLOTTED.  (THE LATTER OPTION IS CURRENTLY NOT AVAILABLE FO
C       VAX ANALYSES).
C     ****** IMPORTANT:  IF JDAY0 AND/OR UTC0 ARE MISSING, ASSUME THAT
C       THE SECOND FIX RECORD CONTAINS JDAY0 ******
C
      TIMWIN=TIMWNZ
      XSTM0=-99.0
      YSTM0=-99.0
      ITFND=0
C
      READ(MSKDA2,306)STMID
  306 FORMAT(A12)
      READ(MSKDA2,*) WSTMX,NFIXB,NFIXE,NFIXP
C
      IF(NFIXP .EQ. NFIXE)  THEN
      IF(TIMWIN)  WRITE(6,311)
  311 FORMAT('....TIME WINDOW FOR ANALYSIS IS FIRST TO LAST FIX',
     1       ' POSITION READ.')
      ELSE IF(NFIXP .LT. NFIXE)  THEN
      NFIXP=NFIXE
C
      ELSE
      IF(TIMWIN)  WRITE(6,312)
  312 FORMAT('....TIME WINDOW FOR ANALYSIS DOES NOT EXTEND TO',
     1       ' LAST FIX POSITION READ.')
      ENDIF
C
      NFIXPZ=NFIXP
      WRITE(6,313)
  313 FORMAT(/'....HURRICANE LOCATIONS',4X,'LAT.',6X,'LONG.   UTC',
     1       6X,'DAY')
C
C     READ IN STORM FIXES AND DEFINE DATE OF ANALYSIS AS SECOND FIX
C     IMPORTANT:  FIX POSITIONS MUST BE ENTERED IN CHRONOLOGICAL ORDER.
C     FIND THE STORM FIX FOR THE DESIRED TIME
C     IF DOES NOT EXIST, XSTM0 AND YSTM0 REMAIN -99., ITFND REMAINS 0
C
C     CHECK IF THERE ARE TOO MANY STORM FIXES
C
      IF(NFIXP .GT. NFXDIM)  GO TO 940
C
      DO 408 N=1,NFIXP
        READ(MSKDA2,*) XSTM(N),YSTM(N),IDAYST(N),UTCSTM(N)
        WRITE(6,405) YSTM(N),XSTM(N),UTCSTM(N),IDAYST(N)
  405 FORMAT(25X,F7.3,3X,F7.3,F7.0,I11)
      IF(N .EQ. 2 .AND. (JDAY0 .EQ. -99 .OR. UTC0 .EQ. -99.0))  THEN
        JDAY0=IDAYST(N)
        UTC0=UTCSTM(N)
        XSTM0=XSTM(N)
        YSTM0=YSTM(N)
        NFIX0=N
        WSTM(N)=WSTMX+1
      ENDIF
      WSTM(N)=WSTMX
      IF(IDAYST(N) .NE. JDAY0 .OR. UTCSTM(N) .NE. UTC0)  GO TO 408
      ITFND=1
      XSTM0=XSTM(N)
      YSTM0=YSTM(N)
      NFIX0=N
      WSTM(N)=WSTMX+1
  408 CONTINUE
C
      CLOSE(UNIT=MSKDA2,STATUS='KEEP')
C
C     CHECK IF FIX WAS FOUND
C
      IF(XSTM0 .EQ. -99.0 .OR. YSTM0 .EQ. -99.0)  GO TO 960
C
      RETURN
C

C-----------------------------------------------------------------------

      ENTRY HURPOS(IDAYMX,UTCMX,UTCMN,DUTCMN,DUTCMX)
C       OUTPUT ARG. IDAYMX - SLORD DATE FORMAT FOR DATE (YYYYMMDD) (MAX)
C
C     ADD WINDOWS TO THE TIMES OF THE FIRST AND LAST FIX AND MAKE SURE D
C     AND TIME ARE IN THE CORRECT FORM
C
      iymn=idayst(nfixb)/10000
      immn=mod((idayst(nfixb)/100),100)
      idmn=mod(idayst(nfixb),100)
      ihmn=nint(utcstm(nfixb))/100
      iminmn=mod(nint(utcstm(nfixb)),100)
      rinc = 0.
      rinc(3) = dutcmn
      ldat = 0
      ldat(1) = iymn
      ldat(2) = immn
      ldat(3) = idmn
      ldat(5) = ihmn
      ldat(6) = iminmn
      call w3movdat(rinc,ldat,jdat)
      idaymn=(jdat(1)*10000) + (jdat(2)*100) + jdat(3)
      utcmn=(jdat(5)*100) + jdat(6)
      iymx=idayst(nfixe)/10000
      immx=mod((idayst(nfixe)/100),100)
      idmx=mod(idayst(nfixe),100)
      ihmx=nint(utcstm(nfixe))/100
      iminmx=mod(nint(utcstm(nfixe)),100)
      rinc = 0.
      rinc(3) = -dutcmx
      ldat = 0
      ldat(1) = iymx
      ldat(2) = immx
      ldat(3) = idmx
      ldat(5) = ihmx
      ldat(6) = iminmx
      call w3movdat(rinc,ldat,jdat)
      idaymx=(jdat(1)*10000) + (jdat(2)*100) + jdat(3)
      utcmx=(jdat(5)*100) + jdat(6)
C
C     CHECK IF STORM-RELATIVE COORDINATES ARE TO BE USED BUT NO FIX IS F
C
  415 IF(ITFND .EQ. 0 .AND. ISRCD .EQ. 1)  GO TO 950
      IF(TIMWIN)  THEN
      WRITE(6,1412) IFIX(UTCMN),IDAYMN,IFIX(UTCMX),IDAYMX
 1412 FORMAT(/'....DATA ACCEPTED BETWEEN',I5,' UTC,',I9,' AND',I5,
     1       ' UTC,',I9)
      ELSE
      WRITE(6,1413)
 1413 FORMAT(/'....THERE IS NO TIME WINDOW FOR DATA.',/,
     1       '     WARNING:  ERRORS MAY OCCUR IF STORM-RELATIVE',
     2       ' COORDINATES ARE USED.')
      ENDIF
C
C     GET YEAR, MONTH, DAY, AND HOUR FOR FIRST AND LAST FIX AND CURRENT
C
      CALL XTIME(IDAYMN,UTCMN,IYMN,IMMN,IDMN,HRMN)
      IHMN=NINT(HRMN)
      CALL XTIME(IDAYMX,UTCMX,IYMX,IMMX,IDMX,HRMX)

      IHMX=NINT(HRMX)
      CALL XTIME(JDAY0,UTC0,IY0,IM0,ID0,HR0)
      RETURN
C
C     ERRORS AND WARNINGS
C
  910 WRITE(6,911)  LDX
  911 FORMAT(/10X,'....READ ERROR IN XDTSRT...LDX=',I5)
      CALL ABRT1(' XDTSRT',911)
  920 WRITE(6,921) ICOUNT,VCOORD,PLEV(JPD),ITYPMN,ITYPMX,IFIX(WX),
     1             IDAYX,UTCX,JDAY0,UTC0
  921 FORMAT(/'****** LDX=0, THERE ARE NO ACCEPTED DATA POINTS^',/,
     1       ' ...ICOUNT,VCOORD,PLEV(JPD),ITYPMN,ITYPMX,IFIX(WX),',
     2       'IDAYX,UTCX,JDAY0,UTC0=',/,4X,I8,2F8.2,3I5,2(I11,F9.1))
      CALL ABRT1(' XDTSRT',921)
  930 WRITE(6,931)  LDX,LDXX,LP
  931 FORMAT(/'****** LDX EXCEEDS LDXDIM IN XDTSRT',3I10)
      CALL ABRT1(' XDTSRT',931)
  940 WRITE(6,941) NFIXP,NFXDIM
  941 FORMAT(/'****** # OF FIX POSITIONS,',I4,' EXCEEDS NFXDIM=',I4)
      CALL ABRT1(' XDTSRT',941)
  950 WRITE(6,951) (IDAYST(N),UTCSTM(N),N=1,NFIXE)
  951 FORMAT(/'****** ZERO TIME NOT FOUND FOR STORM-RELATIVE COORDINATES
     1       ',/,(5X,I13,F13.2/))
      CALL ABRT1(' XDTSRT',951)
C
  960 WRITE(6,961) JDAY0,UTC0,(IDAYST(N),UTCSTM(N),N=1,NFIXP)
  961 FORMAT(/'****** FIX TIMES DO NOT MATCH T=0 ANALYSIS TIME',/,
     1       (I10,F6.1))
      CALL ABRT1(' XDTSRT',961)
C
  990 WRITE(6,991) L,XX,YX,VCOORD,DATA
  991 FORMAT(/'****** PRESSURE NOT FOUND IN XDTSRT',I5,2F10.2,/,
     1       7F14.1)
      CALL ABRT1(' XDTSRT',991)
  995 WRITE(6,996) NEX,NEXDIM
  996 FORMAT(/'****** NEX=',I4,' AND EXCEEDS NEXDIM=',I5)
      CALL ABRT1(' XDTSRT',996)
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE YDTSUB(KPLV,KDAT,KK,KLAB,FD,A,FKMN,DRF,KDXZ,USTM,VSTM,
     1                  CYBANL,EXVARZ,KEXTFZ,KFOZ,SECVAR,XZ,YZ,KPZ1,
     2                  KPZ2,SPVAL,SCLF)
C
      PARAMETER (MDIM=35,NDIM=35)
      PARAMETER (LDXDIM=8000)
      PARAMETER (NFXDIM=20)
      PARAMETER (KLDIM= 8)
      PARAMETER(KVDIM=20,KDTDIM=5)
C**SGI      PARAMETER(KVDIM= 7,KDTDIM=5)
      PARAMETER (KPXDIM=KVDIM*KLDIM)
      PARAMETER (KDXDIM=KDTDIM*KLDIM)
C
      COMMON/S2DTPT/IDSPD1,IDSPD2,LDX,XD(LDXDIM),YD(LDXDIM),WD(LDXDIM),
     1              ID(LDXDIM),LXSORT(LDXDIM)
      COMMON /S2NODE/ MXX,NXX,DXM,DYN,XM(MDIM),YN(NDIM),XMC(MDIM),
     1                YNC(NDIM),COSYN(NDIM)
      COMMON /DSK/MSKEF,MSKEZ,MSKDA1,MSKDA2,MSKDA3,MSKDA4,MSKDA5,MSKDA6,
     1            MSKDA7,MSKDA8,MSKDA9,MSKD11,MSKD12,MSKD13,MSKD14,
     2            MSKD15,MSKD16,MSKD17,MSKD18
      COMMON /S2KOMP/ IDSPK(KPXDIM),IDVAR(KPXDIM),IDLEV(KPXDIM),KPX,
     1                DMEAN(KDTDIM*KLDIM)
      COMMON/XYT/IDAYOB(LDXDIM),UTCOB(LDXDIM),XSTM(NFXDIM),YSTM(NFXDIM),
     1           WSTM(NFXDIM),IDAYST(NFXDIM),UTCSTM(NFXDIM),ELORG,GLORG,
     2           XSTM0,YSTM0,JDAY0,UTC0,NFIX0,IDAYMN
      COMMON /PRES/ PLEV(KLDIM),RHANL,DATREC(KDTDIM+1),ICOOR,IDAT,IDATZ
      COMMON /RAVGW/RESAVG(KDXDIM)
C
      CHARACTER*8 IDSPD1,IDSPD2*72
      CHARACTER*2 SCLF
      CHARACTER IDXLEV*8,IDXVAR*32,IDXXVR*32,IDSFPR*32,IDXL*8,IDV*32,
     1          IDSPK*40,IDDER*5,IDDVAR*7,IDUNT1*5,IDUNT2*15
C
      EXTERNAL XBF,YBF,DXBF,DYBF,DDXBF,DDYBF
C
      DIMENSION FD(KDXDIM,LDXDIM),DRF(KDAT*KLDIM)
      DIMENSION A(KDXDIM,MDIM,NDIM),FKMN(KPXDIM,MDIM,NDIM),FP(MDIM,NDIM)
     1          ,IDSVX(KVDIM-(KDTDIM+1)),IDSVK(KVDIM-(KDTDIM+1),2),
     2           IDEXTV(KVDIM),IDSVKE(KDTDIM),SPVAL(KPXDIM),UVSTM(2)
C
      DIMENSION IDXLEV(KLDIM),IDXVAR(KVDIM),IDXXVR(KVDIM),IDDER(3),
     1          IDDVAR(KDTDIM),IDUNT1(KDTDIM),ISVTBL(KVDIM-(KDTDIM+1))
C
      DIMENSION KPLV(KLDIM,KVDIM)
      LOGICAL KPLV,KEEP,RHANL,EXTVAR,EXVARZ,UVFLG,SECVAR,CYBANL

      REAL(8)  HEAD_8(5),COSDEG_8

      SAVE
C
      DATA KPXO/0/,EXTVAR/.FALSE./
C
C     ******* CHANGE VALUES OF IDXLEV FOR A DIFFERENT VERTICAL
C             COORDINATE  *******
C
      DATA IDXLEV/' 200 MB ',' 250 MB ',' 300 MB ',' 400 MB ',
     1            ' 500 MB ',' 700 MB ',' 850 MB ','1000 MB '/
CIBM  THE FOLLOWING INITIALIZATION FOR ANALYSIS VARIABLES HAS BEEN
CIBM    MOVED TO AN INCLUDE STATEMENT.
      DATA IDXVAR/'TEMPERATURE  (DEG C)            ',
     D            'MIXING RATIO (G/KG)             ',
     D            'GEOPOTENTIAL HEIGHT  (M)        ',
     D            'U COMPONENT OF WIND  (M SEC**-1)',
     D            'V COMPONENT OF WIND  (M SEC**-1)',
     D            'WIND DIR/SPD (WD*0.1/M SEC**-1) ',
     1            'TEMP. X-GRADIENT  (DEG/(100 KM))',
     2            'TEMP. Y-GRADIENT  (DEG/(100 KM))',
     3            'QMIX X-GRADIENT  (G/KG/(100 KM))',
     4            'QMIX Y-GRADIENT  (G/KG/(100 KM))',
     5            'GEOPOT. X-GRADIENT  (M/(100 KM))',
     6            'GEOPOT. Y-GRADIENT  (M/(100 KM))',
     7            'U WIND X-GRADIENT (M/S/(100 KM))',
     8            'V WIND X-GRADIENT (M/S/(100 KM))',
     9            'U WIND Y-GRADIENT (M/S/(100 KM))',
     D            'V WIND Y-GRADIENT (M/S/(100 KM))',
     1            'DIVERGENCE    (10**-5 SEC**-1)  ',
     2            'VORTICITY     (10**-5 SEC**-1)  ',
     3            'RELATIVE HUMIDITY (PERCENT)     ',
     4            'HOR ADV REL VORT (10**-10/S**2) '/
CIBM  DATA IDXVAR/'TEMPERATURE  (DEG C)            ',
CIBM D            'MIXING RATIO (G/KG)             ',
CIBM D            'GEOPOTENTIAL HEIGHT  (M)        ',
CIBM D            'U COMPONENT OF WIND  (M SEC**-1)',
CIBM D            'V COMPONENT OF WIND  (M SEC**-1)',
CIBM D            'WIND DIR/SPD (WD*0.1/M SEC**-1) ',
CIBM 1            'TEMP. X-GRADIENT  (DEG/(100 KM))',
CIBM 2            'TEMP. Y-GRADIENT  (DEG/(100 KM))',
CIBM 3            'QMIX X-GRADIENT  (G/KG/(100 KM))',
CIBM 4            'QMIX Y-GRADIENT  (G/KG/(100 KM))',
CIBM 5            'GEOPOT. X-GRADIENT  (M/(100 KM))',
CIBM 6            'GEOPOT. Y-GRADIENT  (M/(100 KM))',
CIBM 7            'U WIND X-GRADIENT (M/S/(100 KM))',
CIBM 8            'V WIND X-GRADIENT (M/S/(100 KM))',
CIBM 9            'U WIND Y-GRADIENT (M/S/(100 KM))',
CIBM D            'V WIND Y-GRADIENT (M/S/(100 KM))',
CIBM 1            'DIVERGENCE    (10**-5 SEC**-1)  ',
CIBM 2            'VORTICITY     (10**-5 SEC**-1)  ',
CIBM 3            'RELATIVE HUMIDITY (PERCENT)     ',
CIBM 4            'HOR ADV REL VORT (10**-10/S**2) '/
      DATA IDXXVR/'OMEGA      (MB/HR)              ',
     1             'VORTICITY TEND (10**-10 SEC**-2)',
     2             'H DIV REL VORT (10**-10 SEC**-2)',
     3             'OMEGA X-GRADNT  (MB/HR/(100 KM))',
     4             'OMEGA Y-GRADNT  (MB/HR/(100 KM))',
     5             'VORT. TEND. X-GRADNT            ',
     6             'VORT. TEND. Y-GRADNT            ',
     7             'H DIV REL VORT  X-GRADNT        ',
     8             'H DIV REL VORT  Y-GRADNT        ',
     9             11*' '/
      DATA IDDVAR/'(TEMP) ','(QMIX) ','(GEOP) ','(UWND) ','(VWND) '/,
     D     IDDER /'DDXY ','DDXX ','DDYY '/,
     D     IDUNT1/' (DEG','(G/KG','   (M',' (M/S',
     D            ' (M/S'/,
     D     IDUNT2/'/(10**10 M**2))'/
      DATA IDSFPR/'PRESSURE  (MB)                  '/,
C**SGI     D     IDSVX/2/
C**SGI     D     IDSVK/4,
C**SGI     D           5/
     D     ISVTBL/1,2,3,4,5,6,7,8,9,10,11,12,13,14/
     D     IDSVX/1,1,1,1,1,1,1,1,1,1,2,2,2,2/,
     D     IDSVK/1,1,2,2,3,3,4,5,4,5,5,4,1,4,
     D           1,1,2,2,3,3,4,5,4,5,4,5,2,5/
      DATA IDEXTV/70,100,101,71,72,151,152,161,162,11*0/,
C**SGI      DATA IDEXTV/70,100,101,71,72,151,152/,
     D     IDSVKE/70,100,101,2*0/
C
C     RADF=1.X10**5/(REARTH*2PI/360 DEG)  OMEG=2*OMEGA*1.X10**5
C     DEGF=2PI/360 DEG
C
      DATA RADF/.8994628/,DEGF/1.745329E-2/
      DATA OMEG/14.584/,GRAV/9.81/
C
C     THIS SUBROUTINE READS THE COMPLETED DATA SET AND SELECTS WHICH
C     FIELDS ARE TO BE ANALYZED.
C                 KDAT :  NUMBER OF BASIC DATA VARIABLES (5) AVAILABLE
C                         AT ANY DATA POINT
C                 KPLV :  CONTROLS PRINTING BY LEVEL AND VARIABLE
C                 KLDIM:  NUMBER OF ALLOWED VERTICAL LEVELS
C                         (100,150,200, ....950,SFC)
C                 KVDIM:  NUMBER OF BASIC VARIABLES (T, RH, Z, U, V) PLU
C                         ANY VARIABLES DERIVED FROM COMBINATIONS OF
C                         THESE BASIC VARIABLES, E.G. VORTICITY.
C                 FD   :  STORAGE ARRAY FOR ALL DATA
C

C-----------------------------------------------------------------------

      ENTRY XDATR(KPLV,KDAT,FD,DRF,KDXZ,USTM,VSTM,CYBANL)
C
C
C     OPENING ALLDAT HANDLED BY CRAY JCL
C
C     OPEN(UNIT=MSKDA3,ACCESS='SEQUENTIAL',FORM='UNFORMATTED',
C    1     FILE='ALLDAT',STATUS='UNKNOWN')
CVAX 1     FILE='ALLDAT',STATUS='OLD',READONLY,SHARED)
CIBM 1     FILE='ALLDAT',STATUS='OLD',ACTION='READ')
C    1     STATUS='OLD')
C
C     CHECK ON WIND PRINTOUT
C
      DO KV=4,5
         DO KL=1,KLDIM
            IF(.NOT. KPLV(KL,KV) .AND. KPLV(KL,6))  KPLV(KL,KV)=.TRUE.
         ENDDO
      ENDDO
      UVSTM(1)=USTM
      UVSTM(2)=VSTM
C
C     PICK UP DATA POINT BY POINT
C
      DO 30 L=1,LDX
      READ (MSKDA3,ERR=990,END=970)  HEAD_8,DRF
      KF=0
C
C     IF DATA ARE WANTED, PUT IT INTO FD
C
      DO 20 KL=1,KLDIM
      DO 10 KD=1,KDAT
      IF(.NOT. KPLV(KL,KD))  GO TO 10
      KF=KF+1
      FD(KF,L)=DRF(KLDIM*(KD-1)+KL)
   10 CONTINUE
   20 CONTINUE
   30 CONTINUE
      CLOSE(UNIT=MSKDA3,STATUS='KEEP')
C
C     TEST FOR MISSING DATA: IF SO IGNORE ENTIRE ARRAY
C
      KFM=KF
      KF=0
C
      DO KL=1,KLDIM
         DO KV=1,KDAT
            IF(.NOT. KPLV(KL,KV))  GO TO 50
            KF=KF+1
c && 2 comments
CC          WRITE(6,4111) KL,KV,KF
C4111 FORMAT('...CHECKING STORAGE IN XDATR, KL,KV,KF=',3I5)
            KEEP=.TRUE.
            DO 40 LD=1,LDX
               IF(FD(KF,LD) .NE. -99.0)  GO TO 40
               KEEP=.FALSE.
c && 2 comments
CC             WRITE(6,4112) LD,KL,KV,KF
C4112 FORMAT('*** FOUND MISSING DATA IN FD, LD,KL,KV,KF=',4I5)
   40       CONTINUE
            IF(KEEP)  GO TO 50
            KPLV(KL,KV)=.FALSE.
            IF(KV .EQ. 4 .OR. KV .EQ. 5)  KPLV(KL,6)=.FALSE.
            IF(KF .EQ. KFM)  GO TO 49
            DO KD=KF,KFM-1
               DO LD=1,LDX
                  FD(KD,LD)=FD(KD+1,LD)
               ENDDO
            ENDDO
   49       KF=KF-1
   50       CONTINUE
         ENDDO
      ENDDO
C
      KF=0
C
C     SUBTRACT OUT STORM MOTION (DEFAULT USTM=VSTM=0)
C
      DO KL=1,KLDIM
         DO KD=1,KDAT
            IF(.NOT. KPLV(KL,KD))  GO TO 70
            KF=KF+1
            IF(KD .NE. 4 .AND. KD .NE. 5)  GO TO 70
            DO 60 LD=1,LDX
               IF(FD(KF,LD) .NE. -99.0)  FD(KF,LD)=FD(KF,LD)-UVSTM(KD-3)
   60       CONTINUE
   70       CONTINUE
         ENDDO
      ENDDO
C
      KF=0
C
      DO 100 KL=1,KLDIM
      DO 90 KV=1,KDAT
      IF(.NOT. KPLV(KL,KV))  GO TO 90
      KF=KF+1
C
C     STORE VARIABLE IDENTITY AND LEVEL.
C     ******  FOR VAX ONLY ... SUBTRACT OUT MEAN FIELD ...  ******
C
      IF(.NOT. CYBANL)  CALL MEANV(KF,FD)
      KVZ=KV
      IF(KV .EQ. 2 .AND. RHANL)  KVZ=KVDIM-1
      IF(.NOT. EXTVAR) IDSPK(KF)=IDXLEV(KL)//IDXVAR(KVZ)
      IF(      EXTVAR) IDSPK(KF)=IDXLEV(KL)//
     1                           IDXXVR(KVZ+KXTOFF-1)
      IF(KVZ .EQ. 3 .AND. IDXLEV(KL) .EQ. 'SURFACE ')
     1     IDSPK(KF)=IDXLEV(KL)//IDSFPR
      IDVAR(KF)=KVZ
      IF(EXTVAR) IDVAR(KF)=IDEXTV(KVZ+KXTOFF-1)
      IDLEV(KF)=KL
   90 CONTINUE
  100 CONTINUE
C
      KDATZ=KDAT
      KDXZ=KF
      KDXO=KF
      IF(KDXZ .EQ. 0)  GO TO 960
      RETURN
C

C-----------------------------------------------------------------------

      ENTRY DVLAB(KK,KLAB,SCLF)
C
C     DECIDE THE DATA TYPE AND PRESSURE LEVEL
C
      KV=(KK-1)/KLDIM+1
      IF(KV .EQ. 2 .AND. RHANL)  KV=KVDIM-1
      KL=MOD(KK,KLDIM)
      IF(KL .EQ. 0)  KL=KLDIM
C
C     DATA TYPES AND PRESSURE LEVELS
C
      IDXL=IDXLEV(KL)
      IDV=IDXVAR(KV)
      IF(KV .EQ. 3 .AND. KL .EQ. KLDIM)  IDV=IDSFPR
      IF(EXTVAR)  IDV=IDXXVR(KV+KXTOFF-1)
C
      GO TO (200,300,400,500,600), KLAB
  200 WRITE(6,201)  IDXL,IDV
  201 FORMAT(//43X,'PRELIMINARY DATA VALUES',/,41X,A8,A32,/)
      RETURN
  300 WRITE(6,301) IDXL,IDV
  301 FORMAT(//46X,'FINAL DATA VALUES',/,41X,A8,A32,/)
      RETURN
  400 WRITE(6,401)  IDXL,IDV
  401 FORMAT(//30X,'DEVIATION  (DATA - SPLINE)     RMS/MEAN',
     1       ' (NUMBER OF POINTS) TABLE',/,41X,A8,A32)
      RETURN
  500 WRITE(6,501)  SCLF
  501 FORMAT(25X,'SPLINE INTERPOLATED DATA.  ADDITIONAL SCALE',
     1       ' FACTOR IS 10**',A2)
      RETURN
  600 WRITE(6,601)  IDXL,IDV
  601 FORMAT(//36X,'HORIZONTALLY INTERPOLATED DATA VALUES',/,
     1       41X,A8,A32,/)
      RETURN
C

C-----------------------------------------------------------------------

      ENTRY STEXTV(EXVARZ,KEXTFZ)
      EXTVAR=EXVARZ
      KXTOFF=KEXTFZ
      RETURN

C-----------------------------------------------------------------------

C
      ENTRY OUTVAR(KPLV,A,FKMN,KFOZ)
      KVS=KDTDIM+2
      KVSX=KVDIM
      KFO=KFOZ
C
      DO KL=1,KLDIM
      DO KV=KVS,KVSX
      IF(.NOT. KPLV(KL,KV))  GO TO 2000
      KSVZ=KV-(KDTDIM+1)
      KSVT=ISVTBL(KV-(KDTDIM+1))
      KSVX=IDSVX(KSVZ)
      IF(EXTVAR)  GO TO 1000
      IDSV1=IDSVK(KSVZ,1)
      IDSV2=IDSVK(KSVZ,2)
      GO TO 1005
 1000 IF(KSVZ .GT. 2)  GO TO 980
      IDSV1=IDSVKE(KXTOFF)
 1005 GO TO (1010,1020,1010,1020,1010,1020,1010,1010,1020,1020,
     1       1030,1040,1050,1080),KSVT
C
C     THE FOLLOWING ROUTING STATEMENT TO BE USED FOR GEOSTROPHIC WIND
C        CALCULATIONS
C 1005 GO TO (1010,1020,1010,1020,1060,1070,1010,1010,1020,1020,
C     1       1030,1040,1050,1080),KSVT
C
      WRITE(6,1099)  KSVT,KSVX,KV,KL
 1099 FORMAT(/'***** KSVT OUT OF RANGE IN OUTVAR, KSVT,KSVX,KV,KL=',4I5)
      CALL ABRT1(' OUTVAR',1099)
C
C     X-GRADIENT (PER 100 KM)
C
 1010 CALL SLINTD(DXBF,YBF)
      CALL VFIND(KFOZ,IDSV1,KL,KPA1)
      IF(KPA1 .LT. 1)  GO TO 1990
      KFO=KFO+1
      CALL SLINTO(A,KPA1,FKMN,KPXDIM,MDIM,NDIM,KFO)
      DO N=1,NXX
      PERHKM=RADF/COSYN(N)
      DO M=1,MXX
      FKMN(KFO,M,N)=FKMN(KFO,M,N)*PERHKM
      ENDDO
      ENDDO
      GO TO 1970
C
C     Y-GRADIENT (PER 100 KM)
C
 1020 CALL SLINTD(XBF,DYBF)
      CALL VFIND(KFOZ,IDSV1,KL,KPA1)
      IF(KPA1 .LT. 1)  GO TO 1990
      KFO=KFO+1
      CALL SLINTO(A,KPA1,FKMN,KPXDIM,MDIM,NDIM,KFO)
      DO N=1,NXX
      DO M=1,MXX
      FKMN(KFO,M,N)=FKMN(KFO,M,N)*RADF
      ENDDO
      ENDDO
      GO TO 1970
C
C     DIVERGENCE:  ?COS(LAT)**-1(-2PI/360*SIN(LAT)*V+DX(U))+DY(V)?*RADF*
C
 1030 CALL SLINTD(XBF,YBF)
      CALL VFIND(KFOZ,IDSV1,KL,KPA1)
      IF(KPA1 .LT. 1)  GO TO 1990
      KFO=KFO+1
      CALL SLINTO(A,KPA1,FKMN,KPXDIM,MDIM,NDIM,KFO)
      DO N=1,NXX
      SINYN=-SQRT(1.-COSYN(N)**2)*DEGF
      DO M=1,MXX
      FKMN(KFO,M,N)=SINYN*FKMN(KFO,M,N)
      ENDDO
      ENDDO
      CALL SLINTD(DXBF,YBF)
      CALL SLINTS(1,1)
      CALL VFIND(KFOZ,IDSV2,KL,KPA2)
      IF(KPA2 .LT. 1)  GO TO 1990
      CALL SLINTO(A,KPA2,FKMN,KPXDIM,MDIM,NDIM,KFO)
      DO N=1,NXX
      DO M=1,MXX
      FKMN(KFO,M,N)=FKMN(KFO,M,N)/COSYN(N)
      ENDDO
      ENDDO
      CALL SLINTD(XBF,DYBF)
      CALL SLINTS(1,1)
      CALL SLINTO(A,KPA1,FKMN,KPXDIM,MDIM,NDIM,KFO)
      DO N=1,NXX
      DO M=1,MXX
      FKMN(KFO,M,N)=FKMN(KFO,M,N)*RADF
      ENDDO
      ENDDO
      GO TO 1970
C
C     VORTICITY:  ?COS(LAT)**-1(2PI/360*SIN(LAT)*U+DX(V))-DY(U)?*RADF**-
C
 1040 CALL SLINTD(XBF,YBF)
      CALL VFIND(KFOZ,IDSV1,KL,KPA1)
      IF(KPA1 .LT. 1)  GO TO 1990
      KFO=KFO+1
      CALL SLINTO(A,KPA1,FKMN,KPXDIM,MDIM,NDIM,KFO)
      DO N=1,NXX
      SINYN=SQRT(1.-COSYN(N)**2)*DEGF
      DO M=1,MXX
      FKMN(KFO,M,N)=SINYN*FKMN(KFO,M,N)
      ENDDO
      ENDDO
      CALL SLINTD(DXBF,YBF)
      CALL SLINTS(1,1)
      CALL VFIND(KFOZ,IDSV2,KL,KPA2)
      IF(KPA2 .LT. 1)  GO TO 1990
      CALL SLINTO(A,KPA2,FKMN,KPXDIM,MDIM,NDIM,KFO)
      DO N=1,NXX
      DO M=1,MXX
      FKMN(KFO,M,N)=FKMN(KFO,M,N)/COSYN(N)
      ENDDO
      ENDDO
      CALL SLINTD(XBF,DYBF)
      CALL SLINTS(1,-1)
      CALL SLINTO(A,KPA1,FKMN,KPXDIM,MDIM,NDIM,KFO)
      DO N=1,NXX
      DO M=1,MXX
      FKMN(KFO,M,N)=FKMN(KFO,M,N)*RADF
      ENDDO
      ENDDO
      GO TO 1970
C
C     RELATIVE HUMIDITY
C
 1050 CALL VFIND(KFOZ,IDSV1,KL,KPF1)
      CALL VFIND(KFOZ,IDSV2,KL,KPF2)
      IF(KPF1 .LT. 1 .OR. KPF2 .LT. 1)  GO TO 1990
      KFO=KFO+1
      DO N=1,NXX
      DO M=1,MXX
         IF(NINT(PLEV(KL)*10.) .GT. 3000)  THEN
            QS=QSATW(FKMN(KPF1,M,N)+273.16,PLEV(KL))
         ELSE
            QS=QSATI(FKMN(KPF1,M,N)+273.16,PLEV(KL))
         END IF
      FKMN(KFO,M,N)=FKMN(KPF2,M,N)/(10.*QS)
      ENDDO
      ENDDO
C
C     WIND DIRECTION
C
C 1010 DO 1015 KSV=1,KSVX
C      CALL VFIND(KFOZ,IDSVK(KSVZ,KSV),KL,KPF)
C      IF(KPF .LT. 1)  GO TO 1990
C
C      DO 1011 M=1,MXX
C      DO 1011 N=1,NXX
C 1011 FP(M,N)=FKMN(KPF,M,N)
C 1015 CALL DPREP(FP,IDSVK(KSVZ,KSV),MDIM,NDIM)
C      CALL DPREP(FP,KV,MDIM,NDIM)
C      KFO=KFO+1
C      DO 1017 M=1,MXX
C      DO 1017 N=1,NXX
C 1017 FKMN(KFO,M,N)=IFIX(FP(M,N))
C      GO TO 1970
C
C     WIND SPEED
C
C 1020 DO 1025 KSV=1,KSVX
C      CALL VFIND(KFOZ,IDSVK(KSVZ,KSV),KL,KPF)
C      IF(KPF .LT. 1)  GO TO 1990
C
C      DO 1021 M=1,MXX
C      DO 1021 N=1,NXX
C 1021 FP(M,N)=FKMN(KPF,M,N)
C 1025 CALL DPREP(FP,IDSVK(KSVZ,KSV),MDIM,NDIM)
C      CALL DPREP(FP,KV,MDIM,NDIM)
C      KFO=KFO+1
C      DO 1027 M=1,MXX
C      DO 1027 N=1,NXX
C 1027 FKMN(KFO,M,N)=NINT((FP(M,N)-REAL(IFIX(FP(M,N))))*100.)
C      GO TO 1970
C
C     X-COMPONENT OF GEOSTROPHIC WIND (NORTHERN HEMISPHERE ONLY)
C
C 1060 CALL SLINTD(XBF,DYBF)
C      CALL VFIND(KFOZ,IDSV1,KL,KPA1)
C      IF(KPA1 .LT. 1)  GO TO 1990
C      KFO=KFO+1
C      CALL SLINTO(A,KPA1,FKMN,KPXDIM,MDIM,NDIM,KFO)
C      DO 1061 N=1,NXX
C      GEOSU=GRAV*RADF/(MAX(1.E-6,SQRT(1.-COSYN(N)**2))*OMEG)
C      DO 1061 M=1,MXX
C 1061 FKMN(KFO,M,N)=-FKMN(KFO,M,N)*GEOSU
C      GO TO 1970
C
C     Y-COMPONENT OF GEOSTROPHIC WIND (NORTHERN HEMISPHERE ONLY)
C
C 1070 CALL SLINTD(DXBF,YBF)
C      CALL VFIND(KFOZ,IDSV1,KL,KPA1)
C      IF(KPA1 .LT. 1)  GO TO 1990
C      KFO=KFO+1
C      CALL SLINTO(A,KPA1,FKMN,KPXDIM,MDIM,NDIM,KFO)
C      DO 1071 N=1,NXX
C      GEOSV=GRAV*RADF/(MAX(1.E-6,SQRT(1.-COSYN(N)**2))*OMEG*COSYN(N))
C      DO 1071 M=1,MXX
C 1071 FKMN(KFO,M,N)=FKMN(KFO,M,N)*GEOSV
C      GO TO 1970
C
C     HORIZONTAL ADVECTION OF RELATIVE VORTICITY. TERM 1 IS CONTRIBUTION
C       FROM U D(ZETA)/DX.  TERM2 IS CONTRIBUTION FROM V D(ZETA)/DY.
C
 1080 CALL VFIND(KFOZ,IDSV1,KL,KPU)
      CALL VFIND(KFOZ,IDSV2,KL,KPV)
      IF(KPU .LT. 1 .OR. KPV .LT. 1)  GO TO 1990
      KFO=KFO+1
      KFOS1=KFO+4
      KFOS2=KFOS1+1
      IF(KFOS2 .GT. KPXDIM)  GO TO 930
C
C     TERM 1:SIN(PHI) DU/DX; TERM2: U/SIN(PHI)
C
      CALL SLINTD(DXBF,YBF)
      CALL SLINTO(A,KPU,FKMN,KPXDIM,MDIM,NDIM,KFOS1)
      CALL SLINTD(XBF,YBF)
      CALL SLINTO(A,KPU,FKMN,KPXDIM,MDIM,NDIM,KFOS2)
      DO N=1,NXX
      SINYN=SQRT(1.-COSYN(N)**2)
      IF(SINYN .EQ. 0)  GO TO 920
      DO M=1,MXX
      FKMN(KFOS1,M,N)= FKMN(KFOS1,M,N)*SINYN*DEGF
      FKMN(KFOS2,M,N)=(FKMN(KFOS2,M,N)+DMEAN(KPU))/SINYN*DEGF
      ENDDO
      ENDDO
C
C     ADD DDX(V) TO TERM1; DIVIDE BY COS(PHI) LATER
C
      CALL SLINTD(DDXBF,YBF)
      CALL SLINTS(1,1)
      CALL SLINTO(A,KPV,FKMN,KPXDIM,MDIM,NDIM,KFOS1)
C
C     TERM2: ADD DX(V) AND DIVIDE BY COS(PHI)
C
      CALL SLINTD(DXBF,YBF)
      CALL SLINTS(1,1)
      CALL SLINTO(A,KPV,FKMN,KPXDIM,MDIM,NDIM,KFOS2)
      DO N=1,NXX
      DO M=1,MXX
      FKMN(KFOS1,M,N)=FKMN(KFOS1,M,N)/COSYN(N)
      FKMN(KFOS2,M,N)=FKMN(KFOS2,M,N)/COSYN(N)
      ENDDO
      ENDDO
C
C     TERM2: ADD DY(U) AND MULTIPLY BY SIN(PHI)
C
      CALL SLINTD(XBF,DYBF)
      CALL SLINTS(1,1)
      CALL SLINTO(A,KPU,FKMN,KPXDIM,MDIM,NDIM,KFOS2)
      DO N=1,NXX
      SINYN=SQRT(1.-COSYN(N)**2)*DEGF
      DO M=1,MXX
      FKMN(KFOS2,M,N)=FKMN(KFOS2,M,N)*SINYN
      ENDDO
      ENDDO
C
C     TERM2: ADD DDXY(V) AND DIVIDE BY COS(PHI)
C
      CALL SLINTD(DXBF,DYBF)
      CALL SLINTS(1,1)
      CALL SLINTO(A,KPV,FKMN,KPXDIM,MDIM,NDIM,KFOS2)
      DO N=1,NXX
      DO M=1,MXX
      FKMN(KFOS2,M,N)=FKMN(KFOS2,M,N)/COSYN(N)
      ENDDO
      ENDDO
C
C     TERM 1: SUBTRACT DDXY(U); DIVIDE BY COS(PHI) LATER.
C     TERM 2: SUBTRACT DDY(U)
C
      CALL SLINTS(1,-1)
      CALL SLINTO(A,KPU,FKMN,KPXDIM,MDIM,NDIM,KFOS1)
      CALL SLINTD(XBF,DDYBF)
      CALL SLINTS(1,-1)
      CALL SLINTO(A,KPU,FKMN,KPXDIM,MDIM,NDIM,KFOS2)
C
C     COMBINE TERMS 1 & 2.  MULTIPLY BY U AND V; DIVIDE TERM1 BY COS(PHI
C
      RADFSQ=RADF**2
      DO N=1,NXX
      DO M=1,MXX
C
C      TEM1=FKMN(KFOS1,M,N)/COSYN(N)
C      TEM2=FKMN(KFOS2,M,N)
C      FKMN(KFO,M,N)=-(FKMN(KPU,M,N)*TEM1+
C     1                FKMN(KPV,M,N)*TEM2)
C
      FKMN(KFO,M,N)=-(FKMN(KPU,M,N)*FKMN(KFOS1,M,N)/COSYN(N)+
     1                FKMN(KPV,M,N)*FKMN(KFOS2,M,N))*RADFSQ
C
C      IF(TEM1**2+TEM2**2 .NE. 0.0) FKMN(KFO,M,N)=
C     1         FKMN(KFO,M,N)/SQRT(TEM1**2+TEM2**2)
C
      ENDDO
      ENDDO
C
C     DECOMPOSE TOTAL WIND INTO AZIMUTHAL AVERAGE, MEAN RESIDUAL
C     (TOTAL WIND-AZIMUTHAL AVERAGE), AND EDDY RESIDUAL FOR
C     VORTICITY ADVECTION.  CONTRIBUTIONS BY AZIMUTHAL AVERAGE
C     AND EDDY RESIDUAL ARE DONE NEXT, AND CONTRIBUTION BY MEAN
C     RESIDUAL ARE DONE LAST.
C     ALSO, STORE LABELS AND ADDRESSES OF PREVIOUS VARIABLES.
C     NOTE:  CALCULATIONS ARE SKIPPED IF MEAN AND RESIDUAL VARIABLES
C            ARE NOT FOUND
C
      IDSV1=211
      DO 1100 KEX=1,2
      IDSPK(KFO)=IDXLEV(KL)//IDXVAR(KV)
      IDVAR(KFO)=KV
      IDLEV(KFO)=KL
      CALL VFIND(KFOZ,IDSV1  ,KL,KPUZ)
      CALL VFIND(KFOZ,IDSV1+1,KL,KPVZ)
      IF(KPUZ .LT. 1 .OR. KPVZ .LT. 1)  GO TO 2000
      KFO=KFO+1
      DO N=1,NXX
      DO M=1,MXX
      FKMN(KFO,M,N)=-(FKMN(KPUZ,M,N)*FKMN(KFOS1,M,N)/COSYN(N)+
     1                FKMN(KPVZ,M,N)*FKMN(KFOS2,M,N))*RADFSQ
      ENDDO
      ENDDO
      IDSV1=IDSV1+2
 1100 CONTINUE
C
C     CONTRIBUTION BY MEAN RESIDUAL
C
      IDSPK(KFO)=IDXLEV(KL)//IDXVAR(KV)
      IDVAR(KFO)=KV
      IDLEV(KFO)=KL
      KFO=KFO+1
      DO N=1,NXX
      DO M=1,MXX
      FKMN(KFO,M,N)=-(RESAVG(KPU)*FKMN(KFOS1,M,N)/COSYN(N)+
     1                RESAVG(KPV)*FKMN(KFOS2,M,N))*RADFSQ
      ENDDO
      ENDDO
C
C     STORE LABELS AND ADDRESSES
C
 1970 IF(EXTVAR)  GO TO 1975
      IDSPK(KFO)=IDXLEV(KL)//IDXVAR(KV)
      IDVAR(KFO)=KV
      IDLEV(KFO)=KL
      GO TO 1980
 1975 IDSPK(KFO)=IDXLEV(KL)//IDXXVR(3+KSVZ+2*(KXTOFF-1))
      IDVAR(KFO)=IDEXTV(3+KSVZ+2*(KXTOFF-1))
      IDLEV(KFO)=KL
 1980 CONTINUE
      GO TO 2000
 1990 WRITE(6,1999)  KFOZ,IDSV1,IDSV2,KL,KV,KSVZ
 1999 FORMAT(/'....SECONDARY VARIABLE NOT FOUND, CALCULATION ABANDONED',
     1       /,5X,'KFOZ,IDSV1,IDSV2,KL,KV,KSVZ=',6I6)
 2000 CONTINUE
      ENDDO
      ENDDO
C
      KFOZ=KFO
      RETURN

C-----------------------------------------------------------------------

C
      ENTRY OUTSDR(KPLV,A,FKMN,KFOZ)
C
C     THIS ENTRY PRODUCES A COMPLETE SET OF SECOND DERIVATIVES
C            (DDXY,DDXX,DDYY) FOR EACH VARIABLE.
C
      KFO=KFOZ
C
      DO KL=1,KLDIM
      DO KD=1,KDATZ
      IF(.NOT. KPLV(KL,KD))  GO TO 3000
C
C     DDXY: SECOND CROSS DERIVATIVE  (10**-10 M**-2)
C
      CALL SLINTD(DXBF,DYBF)
      CALL VFIND(KFOZ,KD,KL,KPA1)
      IF(KPA1 .LT. 1)  GO TO 2990
      KFO=KFO+1
      CALL SLINTO(A,KPA1,FKMN,KPXDIM,MDIM,NDIM,KFO)
      DO N=1,NXX
      PRT7KM=RADF**2/COSYN(N)
      DO M=1,MXX
      FKMN(KFO,M,N)=FKMN(KFO,M,N)*PRT7KM
      ENDDO
      ENDDO
      IDSPK(KFO)=IDXLEV(KL)//IDDER(1)//IDDVAR(KD)//IDUNT1(KD)//IDUNT2
      IDVAR(KFO)=10*(KD+1)+1
      IDLEV(KFO)=KL
C
C     DDXX: X-SECOND DERIVATIVE (10**-10 M**-2)
C
      CALL SLINTD(DDXBF,YBF)
      CALL VFIND(KFOZ,KD,KL,KPA1)
      IF(KPA1 .LT. 1)  GO TO 2990
      KFO=KFO+1
      CALL SLINTO(A,KPA1,FKMN,KPXDIM,MDIM,NDIM,KFO)
      DO N=1,NXX
      PRT7KM=(RADF/COSYN(N))**2
      DO M=1,MXX
      FKMN(KFO,M,N)=FKMN(KFO,M,N)*PRT7KM
      ENDDO
      ENDDO
      IDSPK(KFO)=IDXLEV(KL)//IDDER(2)//IDDVAR(KD)//IDUNT1(KD)//IDUNT2
      IDVAR(KFO)=10*(KD+1)+2
      IDLEV(KFO)=KL
C
C     Y-SECOND DERIVATIVE (10**-10 M**-2)
C
      CALL SLINTD(XBF,DDYBF)
      CALL VFIND(KFOZ,KD,KL,KPA1)
      IF(KPA1 .LT. 1)  GO TO 2990
      KFO=KFO+1
      CALL SLINTO(A,KPA1,FKMN,KPXDIM,MDIM,NDIM,KFO)
      DO N=1,NXX
      DO M=1,MXX
      FKMN(KFO,M,N)=FKMN(KFO,M,N)*RADF**2
      ENDDO
      ENDDO
      IDSPK(KFO)=IDXLEV(KL)//IDDER(3)//IDDVAR(KD)//IDUNT1(KD)//IDUNT2
      IDVAR(KFO)=10*(KD+1)+3
      IDLEV(KFO)=KL
      GO TO 3000
C
 2990 WRITE(6,2999)  KL,KD
 2999 FORMAT(/'....DATA VARIABLE NOT FOUND FOR SECOND DERIVATIVE,',
     1       ' CALCULATION ABANDONED',2I6)
C
 3000 CONTINUE
      ENDDO
      ENDDO
C
      KFOZ=KFO
      RETURN

C-----------------------------------------------------------------------

C
      ENTRY SPTVAR(SECVAR,XZ,YZ,A,KPZ1,KPZ2,SPVAL)
C
C     THIS ENTRY GIVES SPOT VALUES FOR ALL VARIABLES.
C
      UVFLG=.FALSE.
      igo = 3040
      IF(SECVAR)  THEN
        KVZ=KPZ1
        KLZ=KPZ2
        KVZZ=KVZ
        KPZZ=MAX(KDXO,KPXO)+1
        KPZ1=KPZZ
        KPZ2=KPZZ
        IDSPK(KPZZ)=IDXLEV(KLZ)//IDXVAR(KVZ)
      ENDIF
      DO 4000 KPZ=KPZ1,KPZ2
        IF(.NOT.SECVAR)  THEN
          KVZ=IDVAR(KPZ)
          KLZ=IDLEV(KPZ)
          KVZZ=KVZ
          IF(EXTVAR)  KVZZ=KXTOFF
        ENDIF
       IF(KVZZ .EQ. KVDIM-1)  GO TO 3030
        IF(KVZZ .GT. KDTDIM+1)  THEN
           if(igo.eq.3040)  then
              go to 3040
           else if(igo.eq.3045)  then
              go to 3045
           else
              call ABRT1(' SPTVAR',4000)
           end if
        ENDIF
        IF(KVZZ .LE. 3)  GO TO 3030
        IF(KVZZ .EQ. KDTDIM+1)  GO TO 950
C
C       U WILL GIVE WIND SPEED, V WILL GIVE WIND DIRECTION
C
        CALL VFIND(KDXO,4,KLZ,KDZ1)
        CALL VFIND(KDXO,5,KLZ,KDZ2)
        IF(KDZ1 .LT. 1 .OR. KDZ2 .LT. 1)  GO TO 3990
        CALL SPTINO(XZ,YZ,A,KDZ1,KDZ1,SPZU)
        CALL SPTINO(XZ,YZ,A,KDZ2,KDZ2,SPZV)
        SPZU=SPZU+DMEAN(KDZ1)
        SPZV=SPZV+DMEAN(KDZ2)
        CALL WDWS(SPZU,SPZV)
C
C       PUT THE CORRECT WIND DATA TYPE INTO SPVAL
C
        IF(UVFLG)THEN
          SPVAL(KPZ)=SPZU
          UVFLG=.FALSE.
        ELSE
          SPVAL(KPZ)=SPZV
          UVFLG=.TRUE.
        ENDIF
        GO TO 4000
C
C       T, Q, Z, OR EXTERNAL VARIABLE
C
 3030   CALL VFIND(KDXO,KVZ,KLZ,KDZ1)
        CALL SPTINO(XZ,YZ,A,KDZ1,KDZ1,SPZ)
        SPVAL(KPZ)=SPZ+DMEAN(KDZ1)
        GO TO 4000
C
C       GRADIENTS, DIVERGENCE, VORTICITY, AND RELATIVE HUMIDITY
C
 3040   COSY=COSDEG_8(GLORG+YZ)
        igo = 3045
C
 3045   IF(EXTVAR)  GO TO 940
        KSVZ=KVZ-(KDTDIM+1)
        IDSV1=IDSVK(KSVZ,1)
        IDSV2=IDSVK(KSVZ,2)
        CALL VFIND(KDXO,IDSV1,KLZ,KDZ1)
        CALL VFIND(KDXO,IDSV2,KLZ,KDZ2)
        IF(KDZ1 .LT. 1 .OR. KDZ2 .LT. 1)  GO TO 3990
C
        GO TO (3050,3060,3050,3060,3050,3060,3050,3050,3060,3060,
     1         3070,3080,3090,3100), KSVZ
C
C       X-GRADIENT
C
 3050   CALL SPOTDX(XZ,YZ,A,KDZ1,KDZ1,SPZ)
        SPVAL(KPZ)=SPZ*RADF/COSY
        GO TO 4000
C
C       Y-GRADIENT
C
 3060   CALL SPOTDY(XZ,YZ,A,KDZ1,KDZ1,SPZ)
        SPVAL(KPZ)=SPZ*RADF
        GO TO 4000
C
C       DIVERGENCE
C
 3070   CALL SPTINO(XZ,YZ,A,KDZ1,KDZ1,SPZV)
        CALL SPOTDX(XZ,YZ,A,KDZ2,KDZ2,SPZDXU)
        CALL SPOTDY(XZ,YZ,A,KDZ1,KDZ1,SPZDYV)
        SPZV=SPZV+DMEAN(KDZ1)
        SPVAL(KPZ)=((-SQRT(1.-COSY**2)*DEGF*SPZV+SPZDXU)/COSY+SPZDYV)*
     1                RADF
        GO TO 4000
C
C       VORTICITY
C
 3080   CALL SPTINO(XZ,YZ,A,KDZ1,KDZ1,SPZU)
        CALL SPOTDX(XZ,YZ,A,KDZ2,KDZ2,SPZDXV)
        CALL SPOTDY(XZ,YZ,A,KDZ1,KDZ1,SPZDYU)
        SPZU=SPZU+DMEAN(KDZ1)
        SPVAL(KPZ)=((SQRT(1.-COSY**2)*DEGF*SPZU+SPZDXV)/COSY-SPZDYU)*
     1               RADF
        GO TO 4000
C
C       RELATIVE HUMIDITY
C
 3090   CALL SPTINO(XZ,YZ,A,KDZ1,KDZ1,SPZT)
        CALL SPTINO(XZ,YZ,A,KDZ2,KDZ2,SPZQ)
        SPZT=SPZT+DMEAN(KDZ1)+273.16
        SPZQ=SPZQ+DMEAN(KDZ2)
        IF(NINT(PLEV(KLZ)*10.) .GT. 3000)  THEN
           QS=QSATW(SPZT,PLEV(KLZ))
        ELSE
           QS=QSATI(SPZT,PLEV(KLZ))
        END IF
        SPVAL(KPZ)=SPZQ/(10.*QS)
        GO TO 4000
C
C       HORIZONTAL ADVECTION OF RELATIVE VORTICITY
C
 3100   SINY=SQRT(1.-COSY**2)
        CALL SPTINO(XZ,YZ,A,KDZ1,KDZ1,SPU)
        CALL SPTINO(XZ,YZ,A,KDZ2,KDZ2,SPV)

C fixit?? # of args. in SPOTDX call is 7 here, 6 elsewhere (set last
C arg. to ZERO)
CDAK    CALL SPOTDX (XZ,YZ,A,KDZ1,KDZ2,SPDXU,SPDXV)
        spdxv = 0.
        call spotdx (xz,yz,a,kdz1,kdz2,spdxu)
        CALL SPOTDY (XZ,YZ,A,KDZ1,KDZ1,SPDYU)
        CALL SPDDXX(XZ,YZ,A,KDZ2,KDZ2,SDDXXV)
        CALL SPDDYY(XZ,YZ,A,KDZ1,KDZ1,SDDYYU)
C fixit?? # of args. in SPDDXY call is 7 here, 6 elsewhere (set last
C arg. to ZERO)
CDAK    CALL SPDDXY(XZ,YZ,A,KDZ1,KDZ2,SDDXYU,SDDXYV)
        sddxyv = 0.
        call spddxy(xz,yz,a,kdz1,kdz2,sddxyu)
C
        SPU=SPU+DMEAN(KDZ1)
        SPV=SPV+DMEAN(KDZ2)
C
        SPVAL(KPZ)=-(SPU*((SDDXXV+DEGF*SINY*SPDXU)/COSY-SDDXYU)/COSY+
     1             SPV*((SDDXYV+DEGF*(SINY*SPDYU+(DEGF*SPU+SINY*SPDXV)/
     2             COSY))/COSY-SDDYYU))*RADF**2
        GO TO 4000
C
 3990   WRITE(6,3991) KLZ,IDSV1,IDSV2,KDZ1,KDZ2
 3991   FORMAT(/'**** SECONDARY VARIABLE NOT FOUND. KLZ,IDSV1,IDSV2,',
     1         'KDZ1,KDZ2=',5I10)
C
 4000 CONTINUE
C
      RETURN
C
  920 WRITE(6,921)  N
  921 FORMAT(/'***** SINYN=0, N=',I3,' CALCULATION OF HOR. VORT. ADV.',
     1       ' WILL BLOW UP.')
      CALL ABRT1(' SPTVAR',920)
C
  930 WRITE(6,931) KFOS2,KPXDIM
  931 FORMAT(/'***** KFOS2=',I5,' AND IS GREATER THAN KPXDIM=',I5)
      CALL ABRT1(' SPTVAR',931)
C
  940 WRITE(6,941)
  941 FORMAT(/'***** SECONDARY VARIABLES ARE NOT ALLOWED FOR EXTERNAL',
     1       ' DATA')
      CALL ABRT1(' SPTVAR',941)
C
  950 WRITE(6,951) KVZ
  951 FORMAT(/'***** WRONG VARIABLE IN SPTVAR, KVZ=',I4)
      CALL ABRT1(' SPTVAR',951)
C
  960 WRITE(6,961) KF,KDXZ,LDX
  961 FORMAT(/'***** DATA FILLING ERROR IN XDATR...KF=',I10,
     1       ' KDXZ=',I10,' LDX=',I10)
      CALL ABRT1(' SPTVAR',961)
C
  970 WRITE(6,971)  MSKDA3,L,HEAD_8,DRF
  971 FORMAT(/'***** END OF RECORD IN XDATR',2I7,F3.0,/,(10F5.1))
      CALL ABRT1(' SPTVAR',971)
C
  980 WRITE(6,981)
  981 FORMAT(/'***** KSVZ GREATER THAN 2 FOR EXTERNAL VARIABLE')
      CALL ABRT1(' SPTVAR',981)
C
  990 WRITE(6,991) MSKDA3,L,HEAD_8,DRF
  991 FORMAT(/10X,'***** READ ERROR IN XDATR',2I10,5F10.1,/,
     1      (5F10.1,/))
      CALL ABRT1(' SPTVAR',991)
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE DIFSUB(KPLV,A,KDAT,WRDSTT,KDXZ,DPRX,NSTICK,KLSTIK,
     1                  DATAFT,UVSAVE,PRDATA,KP1,KP2,IHOLE,KDXX,XZ,YZ,
     2                  ISPTYP,DXSPD,DYSPD,NSWLN,PRTBOG,STMNAM)
C
      PARAMETER (MDIM=35,NDIM=35)
      PARAMETER (LDXDIM=8000)
      PARAMETER (NFXDIM=20,NTPDIM=30)
      PARAMETER (KLDIM= 8)
      PARAMETER(KVDIM=20,KDTDIM=5)
C**SGI      PARAMETER(KVDIM= 7,KDTDIM=5)
      PARAMETER (KPXDIM=KVDIM*KLDIM)
      PARAMETER (KDXDIM=KDTDIM*KLDIM)
      PARAMETER (MXDDIM=70,NYDDIM=70)
      PARAMETER (LDWDIM=1)
      PARAMETER (NHLDIM=2)
C
CIBM  COMMON /S2PRIC/ IDSPC,ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,
CIBM 1                 YNB,YNT,XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4)
      COMMON /S2PRIC/ ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,YNB,YNT,
     1                 XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4),IDSPC
      COMMON/S2DTPT/IDSPD1,IDSPD2,LDX,XD(LDXDIM),YD(LDXDIM),WD(LDXDIM),
     1               ID(LDXDIM),LXSORT(LDXDIM)
      COMMON /DSK/MSKEF,MSKEZ,MSKDA1,MSKDA2,MSKDA3,MSKDA4,MSKDA5,MSKDA6,
     1            MSKDA7,MSKDA8,MSKDA9,MSKD11,MSKD12,MSKD13,
     2            MSKD14,MSKD15,MSKD16,MSKD17,MSKD18
      COMMON /S2KOMP/ IDSPK(KPXDIM),IDVAR(KPXDIM),IDLEV(KPXDIM),KPX,
     1                 DMEAN(KDTDIM*KLDIM)
      COMMON/XYT/IDAYOB(LDXDIM),UTCOB(LDXDIM),XSTM(NFXDIM),YSTM(NFXDIM),
     1            WSTM(NFXDIM),IDAYST(NFXDIM),UTCSTM(NFXDIM),
     2            ELORG,GLORG,XSTM0,YSTM0,JDAY0,UTC0,NFIX0,IDAYMN
      COMMON /DWATE/ WDR(NTPDIM),JSKEEM(NTPDIM),IDTYP(100),JDTYP(NTPDIM)
      COMMON /PRES/ PLEV(KLDIM),RHANL,DATREC(KDTDIM+1),ICOOR,IDAT,IDATZ
C
C     NOTE: SPACE FOR THE 1000 MB DATA MUST BE CREATED BY DIMENSIONING
C           FEXTD(KLDIM+1....)
C
      DOUBLE PRECISION FEXTD(KLDIM+1,KDTDIM,LDWDIM)
      LOGICAL KPLV(KLDIM,KVDIM),RHANL,IHOLE,PRTBOG,DATAFT,UVSAVE,WRDSTT,
     1        MAXFND,PRDATA,SECVAR
      LOGICAL INTQF
C
      CHARACTER IDSPC*125,IDSPD1*8,IDSPD2*72,IDSPK*40,IDSPKZ*40,FLAGZ*1,
     1          STMNAM*12
      CHARACTER*1 IMAXMN,IMORE
CIBM  CHARACTER ZTIME*8,ZDATE*9
C
      SAVE
C
      DIMENSION A(KDXDIM,MDIM,NDIM),FDD(LDXDIM),
     1          FDDX(LDXDIM),FDDZ(KDTDIM,LDWDIM),LDW(LDXDIM),
     2          XDSPD(MXDDIM),YDSPD(NYDDIM),DATA(KDTDIM),DATAX(KDTDIM),
     3          NDR(LDWDIM),XHOLMN(NHLDIM),XHOLMX(NHLDIM),
     4          YHOLMN(NHLDIM),YHOLMX(NHLDIM),RMS(NTPDIM),
     5          NRMS(NTPDIM),DSPOT(KPXDIM),KLSTIK(KLDIM),
     6          XDZ(LDWDIM),YDZ(LDWDIM),LDWZ(LDWDIM),SAVUVA(LDXDIM,2),
     7          RMEAN(NTPDIM),SKWVAL(5,19),FLAGZ(KDTDIM)
C
      NAMELIST/HOLE/XHOLMN,XHOLMX,YHOLMN,YHOLMX,NHOLE
C
      DATA FLAGZ/KDTDIM*'0'/,MDUM/0/
      DATA IUNTQF/18/,IUNTQL/19/,INTQF/.FALSE./,RMISS/-99.0/
C
C-----------------------------------------------------------------------

      ENTRY STICKD(KPLV,A,KDAT,KDXZ,DPRX,NSTICK,KLSTIK,DATAFT,UVSAVE,
     1             WRDSTT,PRDATA)
C
C     ENTRY STICKD SERVES TWO PURPOSES: THE BRANCH IS CONTROLLED BY
C         DATAFT
C         DATAFT=.FALSE.:   STICKD FINDS VALUE OF SPLINE-INTERPOLATED FI
C                           AT A GIVEN X-Y LOCATION IN THE DOMAIN AND ST
C                           THAT VALUE ON DISK.
C         DATAFT=.TRUE.:   STICKD COMPUTES DIFFERENCE BETWEEN EXTERNALLY
C                          DEFINED DATA (READ FROM MSKDA8) AND THE SPLIN
C                          FIELD.
C
C     NSTICK IS THE NUMBER OF LEVELS AT WHICH THE SPLINE-FIELD VALUES
C       ARE TO BE FOUND.
C     KLSTIK CONTAINS THE ANALYSIS LEVELS (NSTICK VALUES).
C
      OPEN(UNIT=MSKDA8,FILE='STKDATI',ACCESS='SEQUENTIAL',
CVAX 1     FORM='UNFORMATTED',READONLY,SHARED)
CIBM 1     FORM='UNFORMATTED',ACTION='READ')
     1     STATUS='UNKNOWN',FORM='UNFORMATTED')
C
C     CHECK HEAD RECORDS TO MAKE SURE GEOMETRY MATCHES
C
      CALL HEDCHK(MSKDA8)
C
      LDXZ=1
C
      FEXTD=RMISS
C
  310 READ(MSKDA8,END=320) LDWZ(LDXZ),NDR(LDXZ),IDAYX,UTCX,YDZ(LDXZ),
     1                     XDZ(LDXZ),YX,XX,KDS,KDF
      IF(PRDATA)  WRITE(6,311)LDWZ(LDXZ),NDR(LDXZ),IDAYX,UTCX,YDZ(LDXZ),
     1                         XDZ(LDXZ),YX,XX
  311 FORMAT('***** WPROC DATA LOCATION PT.#',I5,4X,I4,1X,I9,
     1        1X,F5.0,4F6.1)
C
      DO ND=1,NDR(LDXZ)
      READ(MSKDA8)  (FEXTD(ND,KD,LDXZ),KD=KDS,KDF)
      ENDDO
C
      LDXZ=LDXZ+1
      IF(LDXZ .GT. LDWDIM)  GO TO 993
      GO TO 310
C
  320 LDXZ=LDXZ-1
C
C     LEVEL BY LEVEL, REMOVE ALL DATA POINTS NOT IN THE DOMAIN AND,
C     FOR THE DATAFT OPTION, REMOVE ALL DATA NOT AT THE LEVEL IN
C     QUESTION.
C
      DO 400 KLSTK=1,NSTICK
      KLZ=KLSTIK(KLSTK)
      LDXX=0
      DO 360 LD=1,LDXZ
      CALL DOMCHK(XDZ(LD),YDZ(LD),IN)
      IF(IN .EQ. 0)  GO TO 360
C
      IF(.NOT. DATAFT)   GO TO 350
C
C     DATAFT .EQ. .TRUE. OPTION
C       SIFT THROUGH AVAILABLE DATA FOR EACH POINT TO PICK UP DATA AT TH
C       RIGHT LEVEL
C     IMPORTANT NOTE:  THERE IS A LIMITATION TO THE SIFTING TECHNIQUE AS
C                      CODED HERE:  ONLY A SINGLE OBSERVATION AT A GIVEN
C                      LOCATION WILL BE FOUND.  IF THERE ARE MULTIPLE
C                      OBSERVATIONS WITHIN THE PRESSURE WINDOW (DPRX), O
C                      SEVERAL DIFFERENT DATA TYPES, THE CODE WILL CHOSE
C                      ONLY THE FIRST AND IGNORE THE REST.  THESE CASES
C               OCCUR VERY INFREQUENTLY.    *******
C
      DO 330 ND=1,NDR(LD)
      NDZ=ND
      CALL UPKPRW(FEXTD(ND,KDS,LD),UVX,PRX,WX)
      IF(ABS(PRX-PLEV(KLZ)) .LE. DPRX)  GO TO 340
  330 CONTINUE
      GO TO 360
C
  340 FDDZ(KDS,LDXX+1)=UVX
      IF(KDS+1 .GT. KDF)  GO TO 350
      DO KD=KDS+1,KDF
      CALL UPKPRW(FEXTD(NDZ,KD,LD),UVX,PRX,WX)
      FDDZ(KD,LDXX+1)=UVX
      ENDDO
C
  350 LDXX=LDXX+1
      if(LDXX .GT. LDXDIM)  THEN
         print *, 'LDXDIM limit (',LDXDIM,') exceeded - ',
     $    'LDXX=',LDXX,', return'
         return
      endif
      XD(LDXX)=XDZ(LD)
      YD(LDXX)=YDZ(LD)
      ID(LDXX)=WX
      LDW(LDXX)=LDWZ(LD)
C
c && 3 comments
CC    WRITE(6,359)  LDXX,XD(LDXX),YD(LDXX),LDW(LDXX)
CC359 FORMAT(5X,'DATA POINT #',I5,' AT XD=',F6.1,', YD=',F6.1,
CC   1' IN REGION...WPROC #',I5)
  360 CONTINUE
      LDX=LDXX
C
CIBM  WRITE(1,366) LDX,KLZ
C 366 FORMAT(/'...DATA DIFFERENCE POINTS FOUND, LDX=',I6,' AT LEVEL',
C    1       I3)
C
      CALL PRDLOC(0)
C
C     WRITE HEAD RECORD FOR STICK DATA FILE OR DATAFT FILE
C
      IF(DATAFT)   THEN
      CALL OUTDV1(MSKDA9,'STKDATO')
      IF(WRDSTT)   CALL OUTST1
      ELSE
      WRITE(MSKDA9) LDX,LDW
      ENDIF
C
      DO 390 KD=1,KDAT+1
      NV=KD
      IF(.NOT. KPLV(KLZ,KD))  GO TO 390
      KUV=1
      IF(KD .EQ. KDAT)  KUV=2
      IF(KD .LE. KDAT)  THEN
C
      CALL VFIND(KDXZ,NV,KLZ,KF)
      IF(KF .LT. 0)  GO TO 980
C
C     ZERO RMS STORAGE
C
      RMS=0.0
      NRMS=0
      RMEAN=0.0
C
      DO 380 LD=1,LDX
C
      CALL SPTINO(XD(LD),YD(LD),A,KF,KF,SPLD)
C
C     DON'T FORGET TO ADD IN THE MEAN VALUE TO ALL SPOT CALCULATIONS
C
      FDDX(LD)=SPLD+DMEAN(KF)
      FDD(LD)=SPLD+DMEAN(KF)
C
      IF(.NOT. DATAFT)   GO TO 380
      FDD(LD)=FDDZ(KD,LD)-(SPLD+DMEAN(KF))
      SAVUVA(LD,KUV)=FDDX(LD)
      ITYP=IDTYP(ID(LD))
      IF(ITYP .EQ. 0 .OR. ITYP .GT. NTPDIM)  GO TO 998
      RMS(ITYP)=RMS(ITYP)+FDD(LD)**2
      NRMS(ITYP)=NRMS(ITYP)+1
      RMEAN(ITYP)=RMEAN(ITYP)+FDD(LD)
C
  380 CONTINUE
C
C     CURRENTLY ONLY SUMMARY PRINTOUT OF DEVIATIONS IS MADE
C
      DO 385 NTP=1,NTPDIM
      IF(NRMS(NTP) .EQ. 0)  GO TO 385
      RMS(NTP)=SQRT(RMS(NTP)/REAL(NRMS(NTP)))
      RMEAN(NTP)=RMEAN(NTP)/REAL(NRMS(NTP))
      WRITE(6,384)  NV,KLZ,JDTYP(NTP),RMEAN(NTP),RMS(NTP),NRMS(NTP)
  384 FORMAT('...NV=',I2,', LEVEL=',I2,', DATA TYPE=',I3,
     1       '...MEAN ERROR=',F7.2,'...RMS ERROR=',F7.2,', # PTS.=',I4)
  385 CONTINUE
C
      ENDIF
C
      CALL DPREP(FDD,NV,LDX,1)
C
C
C     CALCULATE THE RMS AND MEAN DEVIATIONS IN TERMS OF WIND SPEED & DIR
C
      IF(NV .EQ. KDAT+1 .AND. DATAFT)   THEN
C
      DO 387 KKVAR=1,2
C
C         ZERO RMS AND MEAN STORAGE FOR EACH VARIABLE
C
      RMEAN=0.
      RMS=0.
      NRMS=0
C
      DO 3380 LD=1,LDX
      IF(FDD(LD) .NE. -900.)  THEN
      ITYP=IDTYP(ID(LD))
      IF(ITYP .EQ. 0 .OR. ITYP .GT. NTPDIM)  GO TO 998
      SPD100=REAL(IFIX(FDD(LD)))
      SDDIRZ=SPD100*0.01
C
      IF(KKVAR .EQ. 1)  THEN
      DIRDEV=(FDD(LD)-SPD100)*1000.-180.
      DIRUV=ATAN2DEG(SAVUVA(LD,1),SAVUVA(LD,2))
      SDDIRZ=DIRDEV-DIRUV
C fixit?? "DIR" is never initialized (give it value ZERO)
      dir = 0.
      IF(ABS(SDDIRZ) .GT. 180.) SDDIRZ=360.-SIGN(SDDIRZ,DIR)
      ENDIF
C
      RMEAN(ITYP)=RMEAN(ITYP)+SDDIRZ
      RMS(ITYP)=RMS(ITYP)+SDDIRZ**2
      NRMS(ITYP)=NRMS(ITYP)+1
      ENDIF
 3380 CONTINUE
C
C           CALCULATE RMS AND MEAN
C
              DO 3385 NTP=1,NTPDIM
                IF(NRMS(NTP).NE.0)THEN
                  RMS(NTP)=SQRT(RMS(NTP)/REAL(NRMS(NTP)))
                  RMEAN(NTP)=RMEAN(NTP)/REAL(NRMS(NTP))
      WRITE(6,3384)  NV,KKVAR,KLZ,JDTYP(NTP),RMEAN(NTP),RMS(NTP),
     1               NRMS(NTP)
 3384 FORMAT('...NV=',I2,' DIR/SPD=',I2,', LEVEL=',I2,
     1       ', DATA TYPE=',I3,'...MEAN ERROR=',F7.2,'...RMS ERROR=',
     2       F7.2,', # PTS.=',I4)
                ENDIF
 3385         CONTINUE
      IF(KKVAR .EQ. 1 .AND. WRDSTT)
     1                           CALL OUTST2(NV,KLZ,NRMS,RMS,RMEAN)
  387 CONTINUE
      ENDIF
C
C     WRITE SPLINE-INTERPOLATED VALUES: STICK DATA OR DATAFT OPTIONS
C
      NVZ=NV
C
      IF(      DATAFT)   THEN
      CALL OUTDV2(NVZ,KLZ,FDD)
      IF(WRDSTT) CALL OUTST2(NVZ,KLZ,NRMS,RMS,RMEAN)
      IF(UVSAVE) CALL OUTDV2(NVZ,KLZ,FDDX)
      ELSE
      CALL OUTSTK(KD,LDX,FDD,KLZ,LDW(LD))
      ENDIF
C
      print *, ' '
      print *, ' '
  390 CONTINUE
      IF(KLSTK .EQ. NSTICK)  GO TO 400
      CLOSE(UNIT=MSKDA9,STATUS='KEEP')
      CALL OPNFIL(MSKDA9)
  400 CONTINUE
C
      CLOSE(UNIT=MSKDA9,STATUS='KEEP')
      CLOSE(UNIT=MSKDA8,STATUS='KEEP')
      RETURN
C

C-----------------------------------------------------------------------

      ENTRY SPTDAT(KP1,KP2,KPLV,A,KDAT,IHOLE,ISPTYP,DXSPD,DYSPD,NSWLN,
     1             PRTBOG,STMNAM)
C
C     THIS ENTRY PICKS UP SAMPLE DATA AT ARBITRARY LAT./LONG. SPACING FR
C     WITHIN THE ENTIRE HORIZONTAL DOMAIN.
C        *****  NOTE:  THESE HOLE PARAMETERS ARE UPDATED IN IHOLE=.TRUE.
C                      AND ARE DESIGNED SO THAT THE HOLE-CATCHER BELOW I
C                      DEACTIVATED WHEN IHOLE=.FALSE.  *****
C
      IF(NHOLE .GT. NHLDIM)   GO TO 995
C
      XHOLMN=XML
      XHOLMX=XMR
      YHOLMN=YNT
      YHOLMX=YNB
C
CIBM  IF(JPD .EQ. 1 .OR. (IDLEV(KP1) .EQ. KLDIM .AND. IDVAR(KP1)
CIBM 1   .EQ. 3))  CALL OPNFIL(MSKDA9)
CIBM  IF(JPD .NE. 1)  CALL ENDFIL(MSKDA9)
C
C     ***** IMPORTANT *****
C           THE PRESENT CONFIGURATION IS TO WRITE THE SAMPLED DATA
C           AS FORMATTED RECORDS
C
C
      REWIND MSKDA9
C
      WRITE(6,501) DXSPD,DYSPD
  501 FORMAT('....SPOT DATA SAMPLER:  DXSPD=',F5.2,',  DYSPD=',F5.2)
C
      IF(DXSPD .GT. 0)  THEN
      NNX=INT((XMR-XML)/DXSPD)
      XOFF=0.5*(XMR-XML-REAL(NNX)*DXSPD)
      ELSE
      NNX=0
      XOFF=0.0
      ENDIF
C
      IF(DYSPD .GT. 0)  THEN
      YOFF=0.5*(YNT-YNB-REAL(NNY)*DYSPD)
      NNY=INT((YNT-YNB)/DYSPD)
      ELSE
      NNY=0
      YOFF=0.0
      ENDIF
C
      XDSPD(1)=XML+XOFF
      YDSPD(1)=YNB+YOFF
      XSPD=XDSPD(1)
      YSPD=YDSPD(1)
      NSPD=1
C
      WRITE(6,502) XSPD,YSPD,XOFF,YOFF,XML,YNB,NNX,NNY
  502 FORMAT('....ANCHOR POINT IS:',F9.2,' LONG.,',F7.2,' LAT.',/,
     1       5X,'XOFF,YOFF,XML,YNB,NNX,NNY=',4F10.3,2I5)
C
      IF(.NOT. IHOLE)  GO TO 510
C
c**sgiREAD(5,NML=HOLE)
      READ(5,HOLE)
      WRITE(6,HOLE)
      WRITE(6,505) (NH,XHOLMN(NH),XHOLMX(NH),YHOLMN(NH),
     1              YHOLMX(NH),NH=1,NHOLE)
  505 FORMAT('....HOLE PARAMETERS: HOLE#',I2,'  XHOLMN=',F6.1,
     1       '  XHOLMX=',F6.1,/,29X,'  YHOLMN=',F6.1,
     2       '  YHOLMX=',F6.1)
      DO 507 NH=1,NHOLE
      XHOLMN(NH)=XHOLMN(NH)*REAL(-NSWLN)
      XHOLMX(NH)=XHOLMX(NH)*REAL(-NSWLN)
  507 CONTINUE
C
  510 XSPD=XSPD+ABS(DXSPD)
      IF(XSPD .GT. XMR)  GO TO 520
      NSPD=NSPD+1
      XDSPD(NSPD)=XSPD
      GO TO 510
C
  520 IF(NXSPD .GT. MXDDIM)  THEN
      WRITE(6,521) NXSPD,MXDDIM
  521 FORMAT('######INSUFFICIENT SPACE FOR SPOT SAMPLED POINTS,',
     1       'NXSPD=',I4,' WHILE MXDDIM=',I4,/,7X,'NUMBER OF POINTS ',
     2       'REDUCED.')
      NSPD=MXDDIM
      ENDIF
      NXSPD=NSPD
      NSPD=1
  530 YSPD=YSPD+ABS(DYSPD)
      IF(YSPD .GT. YNT)  GO TO 540
      NSPD=NSPD+1
      YDSPD(NSPD)=YSPD
      GO TO 530
C
  540 IF(NYSPD .GT. NYDDIM)  THEN
      WRITE(6,541) NYSPD,NYDDIM
  541 FORMAT('######INSUFFICIENT SPACE FOR SPOT SAMPLED POINTS,',
     1       'NYSPD=',I4,' WHILE NYDDIM=',I4,/,7X,'NUMBER OF POINTS ',
     2       'REDUCED.')
      NSPD=NYDDIM
      ENDIF
      NYSPD=NSPD
C
      WRITE(6,565)  ABS(DXSPD),ABS(DYSPD),NXSPD,NYSPD,IHOLE,
     1              (NH,XHOLMN(NH),XHOLMX(NH),YHOLMN(NH),YHOLMX(NH),
     2              NH=1,NHOLE)
  565 FORMAT(/5X,'SAMPLE DATA WRITTEN:  DXSPD=',F5.2,'  DYSPD=',
     1        F5.2,'  NXSPD=',I4,'  NYSPD=',I4,'  HOLE (',L1,')',/,
     2        (30X,'HOLE#',I2,3X,'XHOLMN=',F6.1,'  XHOLMX=',F6.1,
     3        '  YHOLMN=',F6.1,'  YHOLMX=',F6.1))
      WRITE(6,566) MSKDA9
  566 FORMAT(/'...WRITING SAMPLED DATA TO MSKDA9=',I3)
C
      WRITE(MSKDA9,567) XDSPD(1),XDSPD(NXSPD),YDSPD(1),YDSPD(NYSPD),
     1                  ABS(DXSPD),ABS(DYSPD),STMNAM
  567 FORMAT(6F10.3,1X,'''',A12,'''')
C
      KL=IDLEV(KP1)
      KPA=KP1
C
      DO 700 KP=KP1,KP2
      KPP=KP
      IF(IDLEV(KP) .EQ. KL)  GO TO 660
C
  600 KPB=KPP-1
C
      DO NYD=1,NYSPD
      DO NXD=1,NXSPD
C
C     HOLE CATCHER
C
      DO 605 NH=1,NHOLE
      IF(XDSPD(NXD) .GE. XHOLMN(NH) .AND. XDSPD(NXD) .LE. XHOLMX(NH)
     1                               .AND.
     2   YDSPD(NYD) .GE. YHOLMN(NH) .AND. YDSPD(NYD) .LE. YHOLMX(NH))
     2   GO TO 650
  605 CONTINUE
C
      CALL SPTIKA(XDSPD(NXD)-ELORG,YDSPD(NYD)-GLORG,A,KPA,KPB,DATAX)
C
      DATA(1:KDAT)=RMISS

      DO KF=1,KPB-KPA+1
      KV=IDVAR(KF)
      IF(KV .EQ. KVDIM)  KV=2
      DATA(KV)=DATAX(KF)+DMEAN(KPA+KF-1)
      ENDDO
      PR=PLEV(KL)
      CALL OUTREC(PR,DATA)
C
      NNSWLN=-NSWLN
      XDSPDZ=REAL(NNSWLN)*XDSPD(NXD)
      IF(PRTBOG)  WRITE(6,611) ISPTYP,JDAY0,IFIX(UTC0),YDSPD(NYD),
     1             XDSPDZ,PR,(DATA(KD),KD=1,KDAT)
      WRITE(MSKDA9,612) ISPTYP,JDAY0,IFIX(UTC0),YDSPD(NYD),XDSPDZ,
     1                  PR,(DATA(KD),KD=1,KDAT)
  611 FORMAT(1X,I2,1X,I9,1X,I4,1X,2(F7.3,1X),3(F6.1,1X),F7.1,
     1       2(F6.1,1X))
  612 FORMAT(I2,1X,I9,1X,I4,1X,2(F7.3,1X),3(F6.1,1X),F7.1,
     1       2(F6.1,1X))
C
C     WRITE(MSKDA9)  REAL(ISPTYP),JDAY0,UTC0,YDSPD(NYD),XDSPDZ,
C    1               PR,DATA,(FLAGZ(KFL),KFL=1,KDTDIM-1)
  650 CONTINUE
      ENDDO
      ENDDO
      KPA=KP
      KL=IDLEV(KP)
      GO TO 700
  660 IF(KP .NE. KP2)  GO TO 700
      KPP=KP2+1
      GO TO 600
  700 CONTINUE
C
      CLOSE(UNIT=MSKDA9,STATUS='KEEP')
      RETURN
C

C-----------------------------------------------------------------------

      ENTRY SPTLOC(A,KDXX,XZ,YZ,NSWLN)
C
C     THIS IS AN INTERACTIVE ENTRY TO PICK UP SPOT VALUES AT SPECIFIED
C     LOCATIONS FOR ANY ANALYZED DATA VARIABLE WITHIN THE DOMAIN.
C     DEFAULT INITIAL LOCATION IS THE STORM FIX POSITION.
C
C     WRITE HEADER INTO SKWT FILE AND CLEAR THE VALUES IN SKWVAL
C     OR TYPE OUT AVAILABLE DATA GROUPS AND CHOOSE DESIRED VARIABLES
C
      WRITE(6,800)
  800 FORMAT(//5X,'INTERACTIVE QUERY FOR POINT VALUES.')
      WRITE(2,*)' ...INTERACTIVE QUERY FOR POINT VALUES.  AVAILABLE',
     1          ' DATA ARE:'
      WRITE(2,801)
  805 DO 810 KD=1,KDXX
        WRITE(2,811) KD,IDLEV(KD),IDSPK(KD)
  810 CONTINUE
      WRITE(2,*)' ...PLEASE ENTER VARIABLE NUMBER AND NUMBER OF',
     1          ' VARIABLES, (KDZ,KDZX)'
      WRITE(2,*)'    (ENTER NUMBER GREATER THAN LAST VARIABLE TO',
     1          '  CALCULATE A SECONDARY VARIABLE)'
      READ(3,*) KDZ,KDZX
      IF(KDZ.LE.KDXX)THEN
        SECVAR=.FALSE.
        KDZ1=KDZ
        KDZ2=KDZ+KDZX-1
        KDZZ1=KDZ1
        KDZZ2=KDZ2
        KVZ1=KDZ1
        KLZ1=KDZ2
      ELSE
        SECVAR=.TRUE.
        KDZZ1=KDXX+1
        KDZZ2=KDXX+1
        WRITE(2,*)' ...ENTER VARIABLE AND LEVEL (KVZ,KLZ)'
        READ(3,*) KDZ1,KDZ2
        KVZ1=KDZ1
        KLZ1=KDZ2
      ENDIF
C
C     ENTER LOCATION OF THE DESIRED POINT AND MAKE SURE XSPOT IS IN THE
C     CORRECT HEMISPHERE
C
  813 WRITE(2,*)' ...ENTER X-Y COORDINATE (LAT.,LONG.) OR'
      WRITE(2,*)'    (-99.0,-99.0) FOR DEFAULT (STORM FIX LOCATION).'
      WRITE(2,*)'    LONGITUDE IS POSITIVE IN THE WESTERN HEMISPHERE.'
      READ(3,*)  YSPOT,XSPOT
C
C     CALCULATE DISTANCE OF SPOT FROM (ELORG,GLORG) IF SPOT IS NOT
C       STORMFIX, MAKE SURE THE DESIRED POINT IS WITHIN THE DOMAIN
C
      IF(YSPOT .NE. RMISS) THEN
        XSPOT=XSPOT*(-NSWLN)
        IF(YSPOT.LT.YNB.OR.YSPOT.GT.YNT.OR.XSPOT.LT.XML.OR.XSPOT.GT.
     1     XMR)THEN
          WRITE(2,*)' THE CHOSEN LOCATION IS NOT WITHIN THE DOMAIN.'
          GOTO 813
        ENDIF
        XZ=XSPOT-ELORG
        YZ=YSPOT-GLORG
      ENDIF
C
C     CALCULATE AND PRINT THE SPOT VALUE
C
      CALL SPTVAR(SECVAR,XZ,YZ,A,KDZ1,KDZ2,DSPOT)
      WRITE(2,814)  GLORG+YZ,ELORG+XZ
      WRITE(6,814)  GLORG+YZ,ELORG+XZ
      DO 8818 KZZ=KDZ1,KDZ2
      IDSPKZ=IDSPK(KZZ)
      IF(IDVAR(KZZ) .EQ. 4) IDSPKZ(9:40)='WIND SPEED'
      IF(IDVAR(KZZ) .EQ. 5) IDSPKZ(9:40)='WIND DIRECTION'
      WRITE(2,815)  IDSPKZ,DSPOT(KZZ)
      WRITE(6,815)  IDSPKZ,DSPOT(KZZ)
 8818 CONTINUE
C
C     ASK FOR OTHER VARIABLES OTHER LOCATIONS OR QUIT
C     WRITE VALUES FOR CURRENT LOCATION TO MSKD17 IF NEW LOCATION IS REQ
C
 816  WRITE(2,*)' ...NEW VARIABLE (V), NEW LOCATION (L), OR QUIT (Q)?'
      READ(3,'(A1)') IMORE
      IF(IMORE.EQ.'Q' .OR. IMORE .EQ. 'Q')THEN
        RETURN
      ENDIF
      IF(IMORE .EQ. 'V' .OR. IMORE .EQ. 'V')  THEN
        GOTO 805
      ENDIF
      KDZ1=KVZ1
      KDZ2=KLZ1
      IF(IMORE .EQ. 'L' .OR. IMORE .EQ. 'L')  THEN
        GOTO 813
      ELSE
        GOTO 816
      ENDIF
C
  801 FORMAT('    KD',3X,'LEVEL',8X,'VARIABLE')
  811 FORMAT(I6,3X,I3,2X,A40)
  814 FORMAT('...AT LATITUDE',F8.3,' AND LONGITUDE',F8.3,'...')
  815 FORMAT(10X,A40,'=',F9.2)
C

C-----------------------------------------------------------------------

      ENTRY SPSKWT(A,KDXX,XZ,YZ,NSWLN)
C
C     THIS IS AN INTERACTIVE ENTRY TO PICK UP SPOT VALUES AT SPECIFIED
C     LOCATIONS FOR ANY ANALYZED DATA VARIABLE WITHIN THE DOMAIN.
C     DEFAULT INITIAL LOCATION IS THE STORM FIX POSITION.
C
C     WRITE HEADER INTO SKWT FILE AND CLEAR THE VALUES IN SKWVAL
C     OR TYPE OUT AVAILABLE DATA GROUPS AND CHOOSE DESIRED VARIABLES
C
      CALL OUTDV1(MSKD17,'SKWT')
      DO 2803 II=2,5
        DO 2804 III=1,19
          SKWVAL(II,III)=-99.
          IF(II.EQ.2)THEN
            SKWVAL(1,III)=1050-III*50
          ENDIF
 2804   CONTINUE
 2803 CONTINUE
      SECVAR=.FALSE.
      KDZ=1
      KDZX=KDXX
      KDZ1=KDZ
      KDZ2=KDZ+KDZX-1
      KDZZ1=KDZ1
      KDZZ2=KDZ2
      KVZ1=KDZ1
      KLZ1=KDZ2
C
C     ENTER LOCATION OF THE DESIRED POINT AND MAKE SURE XSPOT IS IN THE
C     CORRECT HEMISPHERE
C
 2813 WRITE(2,*)' ...ENTER X-Y COORDINATE (LAT.,LONG.) OR'
      WRITE(2,*)'    (-99.0,-99.0) FOR DEFAULT (STORM FIX LOCATION).'
      WRITE(2,*)'    LONGITUDE IS POSITIVE IN THE WESTERN HEMISPHERE.'
      READ(3,*)  YSPOT,XSPOT
C
C     CALCULATE DISTANCE OF SPOT FROM ELORG,GLORG IF SPOT IS NOT STORMFI
C       MAKE SURE THE DESIRED POINT IS WITHIN THE DOMAIN
C
      IF(YSPOT .NE. RMISS) THEN
        XSPOT=XSPOT*(-NSWLN)
        IF(YSPOT.LT.YNB.OR.YSPOT.GT.YNT.OR.XSPOT.LT.XML.OR.XSPOT.GT.
     1     XMR)THEN
          WRITE(2,*)' THE CHOSEN LOCATION IS NOT WITHIN THE DOMAIN.'
          GOTO 2813
        ENDIF
        XZ=XSPOT-ELORG
        YZ=YSPOT-GLORG
      ENDIF
C
C     CALCULATE AND PRINT THE SPOT VALUE
C
      CALL SPTVAR(SECVAR,XZ,YZ,A,KDZ1,KDZ2,DSPOT)
      WRITE(2,2814)  GLORG+YZ,ELORG+XZ
      DO 1817 KD=KDZZ1,KDZZ2
        IDSPKZ=IDSPK(KD)
        WRITE(2,*)' IDSPK=',IDSPKZ
        IF(IDSPKZ(2:4).EQ.'URF')THEN
          NPSAVE=1
        ELSE
          READ(IDSPKZ(2:4),'(I3)')IDPRES
          DO 2817 IKD=1,18
            IF(IDPRES*10 .EQ. NINT(PLEV(IKD)*10.))  THEN
              NPSAVE=20-IKD
            ENDIF
 2817     CONTINUE
        ENDIF
        IF(IDSPKZ(9:19).EQ.'U COMPONENT')THEN
          SKWVAL(5,NPSAVE)=DSPOT(KD)
          WRITE(IDSPKZ(9:40),'(A)')'WIND SPEED  (M SEC**-1)         '
        ELSEIF(IDSPKZ(9:19).EQ.'V COMPONENT')THEN
          SKWVAL(4,NPSAVE)=DSPOT(KD)
          WRITE(IDSPKZ(9:40),'(A)')'WIND DIRECTION (DEGREES)        '
        ELSEIF(IDSPKZ(9:19).EQ.'TEMPERATURE')THEN
          SKWVAL(2,NPSAVE)=DSPOT(KD)
        ELSEIF(IDSPKZ(9:19).EQ.'RELATIVE HU')THEN
          SKWVAL(3,NPSAVE)=DSPOT(KD)
        ELSEIF(IDSPKZ(9:13).EQ.'PRESS')THEN
          SKWVAL(1,NPSAVE)=DSPOT(KD)
        ELSEIF(IDSPKZ(9:13).EQ.'GEOPO'.AND.NPSAVE.EQ.1)THEN
          SKWVAL(1,NPSAVE)=DSPOT(KD)
        ENDIF
        WRITE(2,2815) IDSPKZ,DSPOT(KD)
 1817 CONTINUE
C
C     ASK FOR OTHER VARIABLES OTHER LOCATIONS OR QUIT
C     WRITE VALUES FOR CURRENT LOCATION TO MSKD17 IF NEW LOCATION IS REQ
C
 2816 WRITE(2,*)' ...NEW LOCATION (L) OR QUIT (Q)?'
      READ(3,'(A1)') IMORE
      NLEVEL=0
      DO 2799 III=1,19
        IF(SKWVAL(2,III).NE.-99.)THEN
          NLEVEL=NLEVEL+1
        ENDIF
 2799 CONTINUE
      WRITE(2,*)' NLEVEL=',NLEVEL
      CALL OUTDV3(ELORG+XZ,GLORG+YZ,NLEVEL,SKWVAL)
      IF(IMORE.EQ.'Q')THEN
        RETURN
      ENDIF

      SKWVAL(2:5,:)=-99.

      KDZ1=KVZ1
      KDZ2=KLZ1
      IF(IMORE .EQ. 'L' .OR. IMORE .EQ. 'L')THEN
        GOTO 2813
      ELSE
        GOTO 2816
      ENDIF
C
C     FORMAT STATEMENTS
C
 2814 FORMAT('...AT LATITUDE',F8.3,' AND LONGITUDE',F8.3,'...')
 2815 FORMAT(A40,'=',F9.2)
C

C-----------------------------------------------------------------------

      ENTRY SPTFND(A,KDXX,XZ,YZ,NSWLN)
C
C     THIS IS AN INTERACTIVE ENTRY TO FIND MAXIMUM OR MINIMUM VALUES
C     WITHIN A SPECIFIED SEARCH RADIUS OF ANY VARIABLE WITHIN THE
C     DOMAIN
C
      IOPT=1
      XZZ=XZ
      YZZ=YZ
      REWIND IUNTQL

      WRITE(6,1823)  INTQF,KDXX,XZ,YZ
 1823 FORMAT(/'...ENTERING SPTFND WITH INTQF,KDXX,XZ,YZ=',L3,I4,2F10.3)

      KFLAG = 0
 8350 CONTINUE
      IF(INTQF.OR.KFLAG.EQ.1)  THEN
         IF(KFLAG.EQ.1)  GO TO 835
         WRITE(6,830)
  830    FORMAT(//5X,'INTERACTIVE SEARCH FOR MINIMUM/MAXIMUM VALUES.')
         WRITE(6,831)
  831    FORMAT(/'...INTERACTIVE SEARCH FOR MINIMUM/MAXIMUM VALUES.',
     1          ' AVAILABLE DATA ARE:',/,'     KD',3X,'LEVEL',3X,
     2          'VARIABLE')
  835    CONTINUE
         DO KD=1,KDXX
            WRITE(6,811) KD,IDLEV(KD),IDSPK(KD)
         ENDDO

         SECVAR=.FALSE.
C**SGI   WRITE(0,841)
C 841    FORMAT('...PLEASE ENTER VARIABLE NUMBER (KDZ) ',/,'   (ENTER',
C    1          ' NUMBER GREATER THAN LAST VARIABLE TO CALCULATE A',
C    2          ' SECONDARY VARIABLE)')
         READ(7,*) KDZ
         WRITE(6,*) KDZ
         KDZ1=KDZ
         KDZ2=KDZ
         KVZ1=KDZ1
         KLZ1=KDZ2
         IF(KDZ .LE. KDXX)  GO TO 845
         SECVAR=.TRUE.
C**SGI   WRITE(0,*)' ...ENTER VARIABLE AND LEVEL (KVZ,KLZ)'
         READ(7,*) KDZ1,KDZ2
         KVZ1=KDZ1
         KLZ1=KDZ2
  845    CONTINUE
         MAXFND=.TRUE.
         WRITE(6,846)
  846    FORMAT('...DO YOU WANT TO FIND MAXIMUM (M) OR MINIMUM (N)?')
         READ(7,847) IMAXMN
  847    FORMAT(A1)
         IF(IMAXMN .EQ. 'N' .OR. IMAXMN .EQ. 'N')  MAXFND=.FALSE.

C     ENTER THE CENTER OF THE SEARCH AREA AND MAKE SURE IT IS IN THE
C     CORRECT HEMISPHERE

         WRITE(6,*)' ...ENTER COORDINATES FOR CENTER OF SEARCH AREA',
     1          ' AND RADIUS (LAT.,LONG.,RADIUS)'
         WRITE(6,*)'    OR (-99.0,-99.0,RADIUS) FOR DEFAULT (STORM FIX',
     1          ' LOCATION)'
        WRITE(6,*)'    LONGITUDE IS POSITIVE IN THE WESTERN HEMISPHERE.'
         WRITE(6,*)'    RADIUS IS IN DEG. LAT.'
         READ(7,*)  YSPOT,XSPOT,RAD
      ELSE
         CALL GETSVF(IUNTQF,KDXX,KDZ,MAXFND,YSPOT,XSPOT,RAD)
      ENDIF

  844 CONTINUE
      SECVAR=.FALSE.
      XZ=XZZ
      YZ=YZZ

      IF(.NOT. INTQF)  THEN
      IF(KDZ .LT. 0)  GO TO 890
C**SGI      WRITE(0,1848)  KDZ,YSPOT,XSPOT,RAD,MAXFND
      WRITE(6,1848)  KDZ,YSPOT,XSPOT,RAD,MAXFND
 1848 FORMAT(/'...NON INTERACTIVE MAX/MIN FINDER WITH KDZ,YSPOT,',
     1       'XSPOT,RAD,MAXFND=',I4,3F10.2,L3)
      KDZ1=KDZ
      KDZ2=KDZ
      KVZ1=KDZ1
      KLZ1=KDZ2
      ENDIF
C
C     DO COORDINATE TRANSFORMATION
C
      IF(YSPOT .NE. RMISS)  THEN
         XSPOT=XSPOT*(-NSWLN)
         XZ=XSPOT-ELORG
         YZ=YSPOT-GLORG
      ENDIF
      WRITE(6,8849) XZ,XSPOT,YZ,YSPOT
 8849 FORMAT(/'...INITIAL CALL OF SIMCON WITH',
     1       ' RELATIVE X=',F8.3,', =',F9.2,' LONGITUDE,',/,31X,
     1       ' RELATIVE Y=',F8.3,', =',F9.2,' LATITUDE.')
      CALL DOMCHK(XZ,YZ,IN)
      IF(IN .EQ. 0)  THEN
         WRITE(6,8846) XZ,YZ,ELORG,GLORG,XZ+ELORG,YX+GLORG
 8846    FORMAT('...INITIAL VALUES NOT IN DOMAIN,XZ,YZ,ELORG,GLORG,',
     1          'XZ+ELORG,YX+GLORG=',/,5X,6F10.3)

C     ENTER THE CENTER OF THE SEARCH AREA AND MAKE SURE IT IS IN THE
C     CORRECT HEMISPHERE

         WRITE(6,*)' ...ENTER COORDINATES FOR CENTER OF SEARCH AREA',
     1          ' AND RADIUS (LAT.,LONG.,RADIUS)'
         WRITE(6,*)'    OR (-99.0,-99.0,RADIUS) FOR DEFAULT (STORM FIX',
     1          ' LOCATION)'
        WRITE(6,*)'    LONGITUDE IS POSITIVE IN THE WESTERN HEMISPHERE.'
         WRITE(6,*)'    RADIUS IS IN DEG. LAT.'
         READ(7,*)  YSPOT,XSPOT,RAD
         GO TO 844
      ENDIF
C
C     HUGH WILLOUGHBY'S SIMPLEX ALGORITHM SEARCHES FOR MINIMUM OR
C     MAXIMUM VALUE
C
      CALL SIMCON(SECVAR,MAXFND,XZ,YZ,RAD,A,KDZ1,KDZ2,SPOTMN,IOPT,MDUM)
      CALL DOMCHK(XZ,YZ,IN)
      IF(IN .EQ. 0)  THEN
      YLAT=RMISS
      XLON=RMISS
      IF(MAXFND)  THEN
      IMNMX=1
      WRITE(6,850) GLORG+YZ,ELORG+XZ
  850 FORMAT(' MAX. VALUE NOT IN DOMAIN AT LAT.',F8.3,
     1       ' LONG.',F9.3)
      ELSE
      IMNMX=-1
      WRITE(6,8551) GLORG+YZ,ELORG+XZ
 8551 FORMAT(' MIN. VALUE NOT IN DOMAIN AT LAT.',F8.3,
     1       ' LONG.',F9.3)
      ENDIF
C
      ELSE IF(IN .EQ. 1)  THEN
      YLAT=GLORG+YZ
      XLON=ELORG+XZ
      IF(MAXFND)  THEN
C**SGI      WRITE(0,851)  IDLEV(KLZ1),IDVAR(KVZ1),SPOTMN,GLORG+YZ,ELORG+
  851 FORMAT(' AT LEVEL',I3,' AND VARIABLE',I3,', MAX. VALUE =',
     1       F9.2,' IS AT LAT.',F8.3,', LONG.',F9.3)
      WRITE(6,851)  IDLEV(KLZ1),IDVAR(KVZ1),SPOTMN,GLORG+YZ,ELORG+XZ
      IMNMX=1
      ELSE
C**SGI      WRITE(0,852)  IDLEV(KLZ1),IDVAR(KVZ1),SPOTMN,GLORG+YZ,ELORG+
  852 FORMAT(' AT LEVEL',I3,' AND VARIABLE',I3,', MIN. VALUE =',
     1       F9.2,' IS AT LAT.',F8.3,', LONG.',F9.3)
      WRITE(6,852)  IDLEV(KLZ1),IDVAR(KVZ1),SPOTMN,GLORG+YZ,ELORG+XZ
      IMNMX=-1
      ENDIF

      ENDIF
  890 CONTINUE
C
      IF(.NOT. INTQF)  THEN
      IF(KDZ .EQ. -99)  THEN
      RETURN
      ELSE
      CALL OUTSV(IUNTQL,ISIGN(IDVAR(KVZ1),IMNMX),IDLEV(KLZ1),YLAT,XLON,
     1           SPOTMN)
      CALL GETSVM(IUNTQF,KDXX,KDZ,MAXFND,YSPOT,XSPOT,RAD)
      GO TO 844
      ENDIF
      ENDIF

      WRITE(6,*)' ...ANY MORE VARIABLES OR LOCATIONS? (Y/N)'
      READ(7,'(A1)') IMORE
      WRITE(6,'(A1)') IMORE
      IF(IMORE .NE. 'Y')  RETURN
      WRITE(6,*)' ...NEW VARIABLE (V) OR LOCATION (L)'
      READ(7,'(A1)') IMORE
      WRITE(6,'(A1)') IMORE
      IF(IMORE .EQ. 'V' .OR. IMORE .EQ. 'V')  THEN
         KFLAG = 1
         GO TO 8350
      END IF
      KDZ1=KVZ1
      KDZ2=KLZ1
      MAXFND=.TRUE.
      WRITE(6,846)
      READ(7,847) IMAXMN
      IF(IMAXMN .EQ. 'N' .OR. IMAXMN .EQ. 'N')  MAXFND=.FALSE.

C     ENTER THE CENTER OF THE SEARCH AREA AND MAKE SURE IT IS IN THE
C     CORRECT HEMISPHERE

      WRITE(6,*)' ...ENTER COORDINATES FOR CENTER OF SEARCH AREA',
     1          ' AND RADIUS (LAT.,LONG.,RADIUS)'
      WRITE(6,*)'    OR (-99.0,-99.0,RADIUS) FOR DEFAULT (STORM FIX',
     1          ' LOCATION)'
      WRITE(6,*)'    LONGITUDE IS POSITIVE IN THE WESTERN HEMISPHERE.'
      WRITE(6,*)'    RADIUS IS IN DEG. LAT.'
      READ(7,*)  YSPOT,XSPOT,RAD
      GO TO 844
C
  980 WRITE(6,981)  KDXZ,NV,KLZ,KF
  981 FORMAT('****** VARIABLE COULD NOT BE FOUND IN STICKD, KDXZ,',
     1       'NV,KLZ,KF=',4I6)
      CALL ABRT1(' SPTFND',981)
  993 WRITE(6,994)  LDWDIM
  994 FORMAT('****** LDWDIM=',I4,' LIMIT IS EXCEEDED IN STICKD.',/,
     1    5X,' HOWEVER, PROCESSING IS CONTINUING WITHOUT READING',
     2       ' ALL RECORDS')
      GO TO 320
  995 WRITE(2,996)  NHOLE,NHLDIM
  996 FORMAT(/'  ****** NUMBER OF HOLES=',I5,', WHILE SPACE ALLOCATED',
     1       'FOR ONLY',I3)
      CALL ABRT1(' SPTFND',996)
  998 WRITE(6,999)  LD,ID(LD)
  999 FORMAT(/'***** INCORRECT ID BRANCH IN SPTDIF',2I5)
      CALL ABRT1(' SPTFND',999)
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE PRDLOC(NFIX)
C
      PARAMETER (MDIM=35,NDIM=35)
      PARAMETER (LDXDIM=8000)
      PARAMETER (NFXDIM=20,NTPDIM=30)
CIBM  PARAMETER (MXCOL=MIN(5*MDIM,120))
C
CIBM  COMMON /S2PRIC/ IDSPC,ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,
CIBM 1                 YNB,YNT,XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4)
      COMMON /S2PRIC/ ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,YNB,YNT,
     1                 XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4),IDSPC
      COMMON /S2NODE/ MXX,NXX,DXM,DYN,XM(MDIM),YN(NDIM),XMC(MDIM),
     1                 YNC(NDIM),COSYN(NDIM)
      COMMON/S2DTPT/IDSPD1,IDSPD2,LDX,XD(LDXDIM),YD(LDXDIM),WD(LDXDIM),
     1               ID(LDXDIM),LXSORT(LDXDIM)
      COMMON/XYT/IDAYOB(LDXDIM),UTCOB(LDXDIM),XSTM(NFXDIM),YSTM(NFXDIM),
     1            WSTM(NFXDIM),IDAYST(NFXDIM),UTCSTM(NFXDIM),
     2            ELORG,GLORG,XSTM0,YSTM0,JDAY0,UTC0,NFIX0,IDAYMN
      COMMON /DWATE/ WDR(NTPDIM),JSKEEM(NTPDIM),IDTYP(100),JDTYP(NTPDIM)
C
      SAVE
C
      DIMENSION DTYP(NTPDIM+2)
C
      CHARACTER*8 IDSPD1,IDSPD2*72,IDSPC*125,IFMTA4*16
      CHARACTER   IFM1*1,IFM2*3,IFM3*4,IFM4*1,IFM5*5,DVX*6
      CHARACTER*1 DTYP,LINE*120
C
      DIMENSION YDZ(LDXDIM+NFXDIM),XDZ(LDXDIM+NFXDIM),IDZ(LDXDIM+NFXDIM)
     1         ,LDSORT(LDXDIM+NFXDIM),DV(LDXDIM+NFXDIM),NSFT(6)
C
CIBM  THE FOLLOWING INITIALIZATION OF IDTYP AND JDTYP HAVE BEEN MOVED
CIBM     TO A BLOCK DATA ROUTINE FOLLOWING THIS SUBROUTINE.
CIBM  DATA NSFT/2*4,5,2*4,3/,MPAGE/24/,NLPAGE/43/,
CIBM 1     IDTYP/1,2,3,4,5,6,7,8,9,10,11,12,13,6*0,14,15,16,17,18,19,
CIBM 2           20,23*0,21,22,23,45*0,24,25,0/,
CIBM
CIBM  JDTYP IS THE INVERSE TABLE TO IDTYP
CIBM
CIBM 3     JDTYP/1,2,3,4,5,6,7,8,9,10,11,12,13,20,21,22,23,24,25,26,
CIBM 4           50,51,52,7*0/
      DATA NSFT/2*4,5,2*4,3/,MPAGE/24/,NLPAGE/51/
      DATA IFM1/'('/,IFM2/'   '/,IFM3/'F5.1'/,
     1     IFM4/')'/,IFM5/'     '/
      DATA DTYP/'0','R','N','P','C','A','F','D','B',
     1          'X','Y','M','K','L','T','G','V','U',
     2          'W','I','*','#','$','S','H',7*' '/
C

C     CONSTANTS RELATED TO THE NUMBER OF NODAL INTERVALS
C
      MXCOL=MIN(5*MDIM,120)
      IFMTA4=IFM1//IFM2//IFM3//IFM4//IFM5
      MXMAX=5*MIN(MX,MPAGE-1)
      LYMAX=MIN(2*NX+1,NLPAGE)
C
C     CONSTANTS RELATED TO THE DISTANCE OF THE STORM CENTER TO THE BOUND
C
      DYNX=YNXX-YN1
      DXMX=XMXX-XM1
C
C     CONSTANTS RELATED TO BOTH
C
      YL=REAL(2*NX)/DYNX
      XL=REAL(5*MX)/DXMX
C
C     MORE CONSTANTS RELATED TO THE NUMBER OF NODAL INTERVALS
C
      MPGX=MX/MPAGE+1
      NPGX=(2*NX)/NLPAGE+1
C
C     SAVE VALUES OF LONGITUDE, LATITUDE, AND DATA TYPE
C
      XDZ(1:LDX)=XD(1:LDX)
      YDZ(1:LDX)=YD(1:LDX)
      IDZ(1:LDX)=ID(1:LDX)
C
C     SPECIAL LOCATION FOR HURRICANE POSITIONS
C     ******** WARNING:  FORTRAN77 GIVES NO EXECUTION OF THE
C                        FOLLOWING DO-LOOP IF NFIX=0   ********
C
      IF(NFIX .EQ. 1)  THEN
         XDZ(LDX+1)=XSTM(NFIX0)
         YDZ(LDX+1)=YSTM(NFIX0)
         IDZ(LDX+1)=IFIX(WSTM(NFIX0))
      ELSE
         DO N=1,NFIX
            XDZ(LDX+N)=XSTM(N)
            YDZ(LDX+N)=YSTM(N)
            IDZ(LDX+N)=IFIX(WSTM(N))
         ENDDO
      ENDIF
C
      LDX1=LDX+NFIX
C
C     SORT YDZ
C
      CALL SORTRL(YDZ,LDSORT,LDX1)
C
C     CONTINUE FOR EARTH-RELATIVE COORDINATES
C
      IF(NFIX .EQ. 0)  RETURN
      WRITE(6,710)
      WRITE(6,711)
  710 FORMAT(//42X,'DATA POINT LOCATIONS',/,1X,
     1       'O...ODW (1)                      ',
     2       'F...AIR FORCE VORTEX DATA (7)    ',
     3       'K...NHC ATOLL/200 ANALYSIS (13)  ',
     4       'W...NHC CLD TRK (25)             ',/,1X,
     5       'R...RAWINSONDES (2)              ',
     6       'D...DOPPLER (8)                  ',
     7       'L...VAS TEMPERATURE & MOIS. (20) ',
     8       'I...TIROS SATELLITE (26)         ',/1X,
     9       'N...NOAA P-3 AIRCRAFT (3)        ',
     D       'B...PIBAL/SIGNIFICANT LEVEL (9)  ',
     1       'T...WISCONSIN CLD TRK (21)       ',
     2       '*...BOGUS POINT (50)             ',/,1X,
     3       'P...SURFACE SHIP (4)             ',
     4       'X...VERT. INT. (1-D SPL) (10)    ',
     5       'G...VAS-GRADIENT (22)            ',
     6       '#...BACKGROUND VALUE (RGL) (51)  ')
  711 FORMAT(
     7       'C...COMMERCIAL AIRCRAFT (5)      ',
     8       'Y...VERT. INT. (2-D SPL) (11)    ',
     9       'V...WISCONSIN WATER VAPOR (23)   ',
     O       '$...BACKGROUND VALUE (ATL)  (52) ',/,1X,
     1       'A...AIR FORCE RECONNAISSANCE (6) ',
     2       'M...NCEP REGIONAL ANALYSIS (12)  ',
     3       'U...NCEP CLD TRK (24)            ',
     4       'S...STORM TRACK (98)             ',/,100X,
     5       'H...HURRICANE (99)               ')
C
C     MAKE A MAP OF THE DATA POINTS
C
      DO  NPG=1,NPGX
      DO  MPG=1,MPGX
C
         ML1=(MPG-1)*MPAGE+1
         MLX=MIN(MPAGE*MPG,MXX)
         MWDTH=5*(MLX-ML1+1)
         NL1=(NPG-1)*(NLPAGE/2+1)
C
C     WRITE GRID
C
         WRITE(6,910) (XMC(M),M=ML1,MLX)
         WRITE(6,810) (M,M=ML1,MLX)
  810    FORMAT(10X,'M=',I4,23I5)
         WRITE(6,811)
  811    FORMAT('  LAT.  N')
         LD=1
         LN=1
         N=NXX-NL1
   20    CONTINUE
         LINE(1:MXCOL)=' '
   40    CONTINUE
C
C     ACCEPT NEXT DATA POINT (FROM NORTH TO SOUTH)
C
         LDPS=LDX1+1-LD
         LDP =LDSORT(LDPS)
         LY  =NINT((YNXX-YDZ(LDPS))*YL+1)
         LYP =(LY-1)/NLPAGE+1
C
C     CHECK IF DATA POINT IS ON THE MAP
C
         IF(LYP .NE. NPG .OR. LY .LT. 1)  GO TO 70
         LYZ=MOD(LY,NLPAGE)
         IF(LYZ .EQ. 0)  LYZ=NLPAGE
C
C     CHECK IF DATA POINT IS ON THE MAP
C
         IF(LYZ .GT. LYMAX)  GO TO 70
         IF(LYZ-LN.NE.0) GO TO 80
         CALL DOMCHK(XDZ(LDP),YDZ(LDPS),IN)
         IF(IN .EQ. 0)  GO TO 70
         LX=5+NINT((XDZ(LDP)-XM1)*XL)
         LXP=LX/(MPAGE*5)+1
C        LXP=(LX-5)/(MPAGE*5)+1
C
C** DEBUG
c && 3 comments
CC       WRITE(6,51) LDP,LDPS,XDZ(LDP),
CC   1   YDZ(LDPS),LYZ,LX,XL,XDZ(LDP)-XM1,LXP,MPG
CC 51    FORMAT(/'....AFTER LXP CALC:',2I10,2F13.3,2I10,2F13.3,2I5)
C
         IF(LXP .NE. MPG)  GO TO 70
         LXZ=MOD(LX,MPAGE*5)
         IF(LXZ .EQ. 0 .AND. LX .NE. 0)  LXZ=MPAGE*5
C** DEBUG
c && 3 comments
CC       WRITE(6,1151) LDP,LDPS,XDZ(LDP),
CC   1    YDZ(LDPS),LYZ,LX,XL,XDZ(LDP)-XM1,LXP,MPG,LXZ
C1151    FORMAT(/'....AFTER LXZ CALC:',2I10,2F13.3,2I10,2F13.3,3I5)
C
         LXZ=MAX(LXZ-1,1)
         IF(LINE(LXZ:LXZ) .NE. ' ')  THEN
         LINE(LXZ:LXZ)='+'
         ELSE
c fixit?? - I made the following change to avoid a ZERO subscript
c            for 'DTYP'
cdak     LINE(LXZ:LXZ)=DTYP(IDTYP(IDZ(LDP)))
         if(IDTYP(IDZ(LDP)).gt.0)  then
            LINE(LXZ:LXZ)=DTYP(IDTYP(IDZ(LDP)))
         else
            line(lxz:lxz)=' '
         endif


C** DEBUG
C        IF(LDP .LE. 100)  THEN
c && 2 comments
CC       WRITE(6,8145) LDP,IDTYP(IDZ(LDP)),LXZ,LX,LDPS,LXP,MWDTH
C8145    FORMAT('...LDP,IDTYP(IDZ(LDP)),LXZ,LX,LDPS,LXP,MWDTH=',7I5)
C        ENDIF
         ENDIF
   70    CONTINUE
         IF(LD .EQ. LDX1)  GO TO 80
         LD=LD+1
         GO TO 40
C
C     XMC, YNC ARE X,Y COORDINATES OF NODAL POINTS.  HERE, WE ASSUME
C     NODAL POINTS ARE ON BOUNDARIES.  THESE MAY BE ODD OR EVEN NUMBERED
C     LINES, DEPENDING ON THE NUMBER OF PAGES IN THE Y-DIRECTION.
C
   80    CONTINUE
         IF(MOD(LN,2) .NE. MOD(NPG,2))  GO TO 85
         WRITE(6,814) YNC(N),N,LINE(1:MWDTH)
  814    FORMAT(F6.2,1X,I3,2X,A)
         N=N-1
         GO TO 90
   85    CONTINUE
         WRITE(6,815) LINE(1:MWDTH)
  815    FORMAT(12X,A)
C
C     SET UP FOR THE NEXT LINE, ONLY IF IT'S NOT THE END OF A PAGE, OR
C     THE END OF THE DATA.
C
   90    CONTINUE
         IF(LN .EQ. 2*NX+1 .OR. LN .EQ. NLPAGE .OR. N .EQ. 0)  GO TO 100
         LN=LN+1
         GO TO 20
C
C     PUT GRID AT BOTTOM OF PAGE
C
  100    CONTINUE
         WRITE(6,850) (M,M=ML1,MLX)
  850    FORMAT(/10X,'M=',I4,23I5)
         WRITE(6,910) (XMC(M),M=ML1,MLX)
  910    FORMAT(6X,'LONG.=',12F8.2/12X,12F8.2)
C
C     START NEW PAGE
C
         IF(NPG .NE. NPGX .OR. MPG .NE. MPGX)  THEN
            print *, ' '
            print *, ' '
         ENDIF
      ENDDO
      ENDDO
C
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      BLOCK DATA IBM2
      PARAMETER (NTPDIM=30)
      COMMON /DWATE/ WDR(NTPDIM),JSKEEM(NTPDIM),IDTYP(100),JDTYP(NTPDIM)
      DATA
     1     IDTYP/1,2,3,4,5,6,7,8,9,10,11,12,13,6*0,14,15,16,17,18,19,
     2           20,23*0,21,22,23,45*0,24,25,0/,JSKEEM/NTPDIM*0/
C
C     JDTYP IS THE INVERSE TABLE TO IDTYP
C
     3     JDTYP/1,2,3,4,5,6,7,8,9,10,11,12,13,20,21,22,23,24,25,26,
     4           50,51,52,7*0/
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE WTDAT(JSKMZ,LDXZ,JCELLX,WFACZ,INDXZ)
      PARAMETER (MDIM=35,NDIM=35)
      PARAMETER (LDXDIM=8000)
CIBM  COMMON /S2PRIC/ IDSPC,ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,
CIBM 1                 YNB,YNT,XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4)
      COMMON /S2PRIC/ ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,YNB,YNT,
     1                 XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4),IDSPC
C
      COMMON/S2DTPT/IDSPD1,IDSPD2,LDX,XD(LDXDIM),YD(LDXDIM),WD(LDXDIM),
     1               ID(LDXDIM),LXSORT(LDXDIM)
C
      COMMON /S2NODE/ MXX,NXX,DXM,DYN,XM(MDIM),YN(NDIM),XMC(MDIM),
     1                 YNC(NDIM),COSYN(NDIM)

      CHARACTER IDSPC*125,IDSPD1*8,IDSPD2*72
C
      DIMENSION NMCELL(MDIM,NDIM),INDXZ(LDXDIM)
C
C     VAX VERSION, MODIFIED 5/17/88 BY SJL
C
      GO TO (100,200,300)  JSKMZ+1
      WRITE(6,1)
    1 FORMAT('****** WEIGHTING OPTION NOT ALLOWED BY WTDAT,',
     1       ' DEFAULT APPLIED')
C
C     DEFAULT WEIGHTING IS RELATIVE WEIGHT FOR ALL DATA, IRRESPECTIVE
C        OF DENSITY.  IN THIS CASE, JCELLX HAS NO MEANING.
C
  100 JCELLX=-1
      WFACZ=WD(INDXZ(1))
C      DO 110 LD=1,LDXZ
C      WD(INDXZ(LD))=WDRZ
C  110 CONTINUE
      RETURN
C
C     OPTION 1: REGULARLY SPACED DATA.  JCELLX IS THE APPROXIMATE
C               NUMBER OF DATA POINTS PER CELL.  JCELLX=0 INDICATES
C               LESS THAN 1 POINT PER CELL OVER THE WHOLE MESH.
C
  200 CONTINUE
      WFAC=REAL(MXX*NXX)/REAL(LDXZ)
      JCELLX=MXX*NXX
      DO 210 LD=1,LDXZ
      WD(INDXZ(LD))=MIN(WFAC*WD(INDXZ(LD)),1.0)
  210 CONTINUE
      WFACZ=WD(INDXZ(1))
      RETURN
C
C     OPTION 2: FOR IRREGULARLY SPACED, POSSIBLY LOCALLY CLUMPED, DATA.
C               JCELLX IS THE APPROXIMATE NUMBER OF DATA POINTS PER
C               CELL.  JCELLX=0 INDICATES LESS THAN 1 POINT PER CELL
C               OVER THE WHOLE MESH.
C
  300 CONTINUE
      NMCELL(1:MXX,1:NXX)=0
C
      DX0=1./DXM
      DY0=1./DYN
      DO 320 LD=1,LDXZ
      MC=MIN(INT((XD(INDXZ(LD))-XM(1))*DX0)+1,MX)
      NC=MIN(INT((YD(INDXZ(LD))-YN(1))*DY0)+1,NX)
      NMCELL(MC,NC)=NMCELL(MC,NC)+1
  320 CONTINUE
C
C     UNIQUE CELL COUNTER
C
      JCELLX=0
      DO NCZ=1,NXX
      DO MCZ=1,MXX
      IF(NMCELL(MCZ,NCZ) .NE. 0)  JCELLX=JCELLX+1
      ENDDO
      ENDDO
C
      WFAC=REAL(JCELLX)/REAL(LDXZ)
C
      DO 340 LD=1,LDXZ
      WD(INDXZ(LD))=MIN(WD(INDXZ(LD))*WFAC,1.0)
  340 CONTINUE
      WFACZ=WD(INDXZ(1))
C
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE RWT
      PARAMETER (NTPDIM=30)
      COMMON /DSK/MSKEF,MSKEZ,MSKDA1,MSKDA2,MSKDA3,MSKDA4,MSKDA5,MSKDA6,
     1            MSKDA7,MSKDA8,MSKDA9,MSKD11,MSKD12,MSKD13,MSKD14,
     2            MSKD15,MSKD16,MSKD17,MSKD18
      COMMON /DWATE/ WDR(NTPDIM),JSKEEM(NTPDIM),IDTYP(100),JDTYP(NTPDIM)
C
      SAVE
C
      DIMENSION WREL(NTPDIM)
C
CIBM  INITIALIZATION OF JSKEEM HAS BEEN MOVED TO THE BLOCK DATA
CIBM     BEFORE SUBROUTINE VICSPL
CIBM  DATA WREL/NTPDIM*1.0/,JSKEEM/NTPDIM*0/
      DATA WREL/NTPDIM*1.0/
C
      WDR=WREL
C
C     EXCEPTIONS TO THE RELATIVE WEIGHTS AND DATA WEIGHTING SCHEMES FOR
C       EACH DATA TYPE ARE READ FROM AN EXTERNAL FILE.
C       OPEN FILE FOR DATA SCHEMES AND RELATIVE WEIGHTS.
C
CVAX  OPEN(UNIT=MSKD15,FILE='WEIGHT',STATUS='OLD',READONLY,SHARED)
CIBM  OPEN(UNIT=MSKD15,FILE='WEIGHT',STATUS='OLD',ACTION='READ')
C
C     FILE OPENS NOT USED ON CRAY
C
C     OPEN(UNIT=MSKD15,FILE='WEIGHT',STATUS='OLD')
C     OPEN(UNIT=MSKD15,STATUS='OLD')
C
      READ(MSKD15,11)
   11 FORMAT(A)
      DO 20 NTPZ=1,NTPDIM
      READ(MSKD15,*,END=30) NTP,JDTYPZ,JSKEEM(NTP),WDR(NTP)
C
C     ERROR CATCHER
C
      IF(JDTYPZ .NE. JDTYP(NTP)) GO TO 900
   20 CONTINUE
   30 CLOSE(UNIT=MSKD15,STATUS='KEEP')
      RETURN
C
  900 WRITE(6,901) NTPZ,JDTYPZ,NTP,JDTYP(NTP)
  901 FORMAT('****** ERROR READING DATA TYPES IN RWT, NTPZ,JDTYPZ,',
     1       'NTP,JDTYP(NTP)=',4I5)
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE OUTSTT(NVZ,KLZ,NRMS,RMS,RMEAN)
      PARAMETER (LDXDIM=8000)
      PARAMETER (NFXDIM=20,NTPDIM=30)
      COMMON /DSK/MSKEF,MSKEZ,MSKDA1,MSKDA2,MSKDA3,MSKDA4,MSKDA5,MSKDA6,
     1            MSKDA7,MSKDA8,MSKDA9,MSKD11,MSKD12,MSKD13,MSKD14,
     2            MSKD15,MSKD16,MSKD17,MSKD18
      COMMON/XYT/IDAYOB(LDXDIM),UTCOB(LDXDIM),XSTM(NFXDIM),YSTM(NFXDIM),
     1           WSTM(NFXDIM),IDAYST(NFXDIM),UTCSTM(NFXDIM),ELORG,GLORG,
     2           XSTM0,YSTM0,JDAY0,UTC0,NFIX0,IDAYMN
      COMMON /DWATE/ WDR(NTPDIM),JSKEEM(NTPDIM),IDTYP(100),JDTYP(NTPDIM)
C
      SAVE
C
      DIMENSION NRMS(NTPDIM),RMS(NTPDIM),RMEAN(NTPDIM)
C

C-----------------------------------------------------------------------

      ENTRY OUTST1
CIBM  OPEN(UNIT=MSKD16,FILE='DSTAT',STATUS='NEW',RECL=170)
      OPEN(UNIT=MSKD16,FILE='DSTAT',STATUS='UNKNOWN')
      WRITE(MSKD16,1) JDAY0,IFIX(UTC0),NTPDIM
      WRITE(MSKD16,2) (JDTYP(NTP),NTP=1,NTPDIM)
      WRITE(MSKD16,2) (JSKEEM(NTP),NTP=1,NTPDIM)
    1 FORMAT(I9,1X,I4,I3)
    2 FORMAT(20I3)
      RETURN
C

C-----------------------------------------------------------------------

      ENTRY OUTST2(NVZ,KLZ,NRMS,RMS,RMEAN)
      WRITE(6,11) NVZ,KLZ
      WRITE(MSKD16,12) NVZ,KLZ,(NRMS (NTP),NTP=1,NTPDIM)
      WRITE(MSKD16,13) (RMS   (NTP),NTP=1,NTPDIM)
      WRITE(MSKD16,13) (RMEAN(NTP),NTP=1,NTPDIM)
   11 FORMAT(/'...DEVIATION STATISTICS FOR VARIABLE #',I3,
     1       ' AND LEVEL=',I3,' HAVE BEEN WRITTEN TO DISK.')
   12 FORMAT(2I3,20I8,/,7X,20I8)
   13 FORMAT(6X,20F8.2)
C
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE GETSVF(IUNTQF,KDXX,KDZ,MAXFND,YSPOT,XSPOT,RAD)

      PARAMETER (KLDIM= 8)
      PARAMETER(KVDIM=20,KDTDIM=5)
      PARAMETER (KPXDIM=KVDIM*KLDIM)

      COMMON /PRES/ PLEV(KLDIM),RHANL,DATREC(KDTDIM+1),ICOOR,IDAT,IDATZ
      COMMON /S2KOMP/ IDSPK(KPXDIM),IDVAR(KPXDIM),IDLEV(KPXDIM),KPX,
     1                 DMEAN(KDTDIM*KLDIM)
      CHARACTER IDSPK*40
      CHARACTER MAXFNZ*1
      LOGICAL RHANL,MAXFND

      SAVE

      REWIND IUNTQF
      NREC=0


C-----------------------------------------------------------------------

      ENTRY GETSVM(IUNTQF,KDXX,KDZ,MAXFND,YSPOT,XSPOT,RAD)
C
C     READ REQUESTED VARIABLES FOR TRACKING
C
      NREC=NREC+1
      READ(IUNTQF,11,END=50)  IDVZZ,PRESZ,YSPOTZ,XSPOTZ,RADZ,MAXFNZ
   11 FORMAT(I4,4F10.2,1X,A)
C
C     TRANSLATE REQUESTED VARIABLES TO SPLINE VARIABLE PARLANCE
C
      IDVZ=IDVZZ
      IF(IDVZZ .EQ. 5)  IDVZ=18
C
C     SCAN THROUGH ALL AVAILABLE SPLINE VARIABLES TO FIND THE MATCHING
C       INDEX
C
      DO 30 KDXZ=1,KDXX
      IF(NINT(PLEV(IDLEV(KDXZ))*10.) .EQ. NINT(PRESZ*10.) .AND.
     $  IDVAR(KDXZ) .EQ. IDVZ)  THEN
      KDZ=KDXZ
      WRITE(6,23) NREC,IDLEV(KDXZ),PLEV(IDLEV(KDXZ)),IDVAR(KDXZ)
   23 FORMAT('...FOUND VARIABLE AND LEVEL,NREC,IDLEV(KDXZ),',
     1       'PLEV(IDLEV(KDXZ)),IDVAR(KDXZ)=',/,4X,2I5,F8.1,I5)
      IF(MAXFNZ .EQ. 'N' .OR. MAXFNZ .EQ. 'N')  THEN
      MAXFND=.FALSE.
      ELSE
      MAXFND=.TRUE.
      ENDIF
      YSPOT=YSPOTZ
      XSPOT=XSPOTZ
      RAD=RADZ
      RETURN
      ENDIF
   30 CONTINUE
      KDZ=-1
      WRITE(6,31)  IDVZ,PRESZ
   31 FORMAT(/'###VARIABLE=',I3,' AT PRESSURE=',F8.1,' NOT FOUND BY ',
     1       'GETSVF/M')
      RETURN

   50 CONTINUE
      WRITE(6,51)  NREC
   51 FORMAT(/'...ALL REQUESTED VARIABLES HAVE BEEN PROCESSED BY ',
     1       'GETSVF/M. NREC=',I3)
      KDZ=-99
      RETURN

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE OUTSV(IUNTQL,IDVW,IDLZ,YLAT,XLON,VALZ)

      PARAMETER (KLDIM= 8)
      PARAMETER (KDTDIM=5)

      COMMON /PRES/ PLEV(KLDIM),RHANL,DATREC(KDTDIM+1),ICOOR,IDAT,IDATZ

      SAVE

      IF(IABS(IDVW) .EQ. 18)  THEN
      IDVW=ISIGN(5,IDVW)
      ENDIF
      WRITE(IUNTQL,101)  IDVW,PLEV(IDLZ),YLAT,XLON,VALZ
      WRITE(6     ,103)  IDVW,PLEV(IDLZ),YLAT,XLON,VALZ
  101 FORMAT(I3,F10.1,2F12.4,E14.6)
  103 FORMAT('...WRITING TO LOCATION FILE. VARIABLE, PRESSURE,LAT,LON,',
     1       'VALUE=',/,1X,I3,F10.1,2F12.4,E14.6)
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
C                 SLOVER **   06/06/84
C                             SLOCCO ADDED FOR CORNER CONDITIONS
C
C     ++ ASSUMED DIM PARAMETERS ... MDIM=47...NDIM=35,
C                               ... KLDIM=19
C                               ... KVDIM= 7,
C
      SUBROUTINE SLOSUB(IDSPCZ,MXZ,NXZ,NSWLN,XMLZ,XMRZ,YNBZ,YNTZ,JPDZ,
     1                  ISRCDZ,IHCZ,ELORG,GLORG,XSTM,YSTM,LLWLZ,KDCTYZ,
     2                  XYDCW1,XYDCW2,KBCTY1,KBCTY2,KBCTY3,KBCTY4,
     3                  XYBCW1,XYBCW2,XYBCW3,XYBCW4)
C
C     ** COMPILATION PARAMETERS **
C
      PARAMETER (MDIM=35,NDIM=35)
      parameter (iarg_5=1)
C
C     MDIM     ARRAY DIMENSION FOR NODAL INDEX M IN THE X DIRECTION
C     NDIM     ARRAY DIMENSION FOR NODAL INDEX N IN THE Y DIRECTION
C
C     ** PRIMARY CONSTANTS FOR SPLINE ANALYSIS PACKAGE
C
CIBM  COMMON /S2PRIC/ IDSPC,ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,
CIBM 1                 YNB,YNT,XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4)
      COMMON /S2PRIC/ ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,YNB,YNT,
     1                 XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4),IDSPC
C
C     ** SECONDARY CONSTANTS FOR CONVENIENCE, DEFINED BY SLOVER
C
      COMMON /S2NODE/ MXX,NXX,DXM,DYN,XM(MDIM),YN(NDIM),XMC(MDIM),
     1                 YNC(NDIM),COSYN(NDIM)
      COMMON /S2BCDC/ DX0,DX1,DX2,DY0,DY1,DY2,CBCBF(8),XYSDCP(2)
C
C     ** DEFINED BY SLOCCO,CALLED WITHIN SLOVER
C
      COMMON /WLCONV/ DXF,DYF,DXORG,DYORG
C
      SAVE
C
C     ** DUMMY ARGUMENT
C
      CHARACTER*125 IDSPCZ,IDSPC,ULBL*15
      LOGICAL LLWL,LLWLZ

      REAL(8)  COSDEG_8
C
C     ** LOCAL WORK SPACE
C
      DIMENSION XYSBCP(4),ZC(2)
      dimension xml_1(iarg_5),ynb_1(iarg_5)
      dimension xm1_1(iarg_5),yn1_1(iarg_5)
      dimension xmr_1(iarg_5),ynt_1(iarg_5)
      dimension xmxx_1(iarg_5),ynxx_1(iarg_5)
      dimension xstmz_1(iarg_5),ystmz_1(iarg_5)
      dimension xstm_1(iarg_5),ystm_1(iarg_5)
      dimension elorgp1_1(iarg_5),glorgp1_1(iarg_5)
      dimension dxorg_1(iarg_5),dyorg_1(iarg_5)
C
C     ** NUMERICAL CONSTANTS
      DATA PI2/6.283185307180/,NFIRST/1/
C

C-----------------------------------------------------------------------

      ENTRY SLOVER
C
C     TIMING
C
      IZERO = 0
      INSEC = ISECND(IZERO)
C
C     ** OVERHEAD CHORES FOR TWO-D SPLINE ANALYSIS AND INVERSE TRANSFORM
C
C     INPUT    ALL THE PRIMARY CONSTANTS IN /S2PRIC/
C              IDSPC .. CODE AND EXPLANATION (80 CHARACTERS)
C
C     OUTPUT   ALL THE SECONDARY CONSTANTS IN /S2NODE/ AND /S2BCDC/
C
C     ENTRIES FOR DEFINING THE PRIMARY CONSTANTS
C              STSPID(IDSPCZ)
C              STSPND(MXZ,NXZ)
C              STDOMN(NSWLN,XMLZ,XMRZ,YNBZ,YNTZ,JPDZ,ISRCDZ)
C              STHORC(IHCZ,XSTM,YSTM)
C              STSPDC(KDCTYZ,XYDCW1,XYDCW2)
C
C     ENTRIES FOR PRINT OUTPUT
C              PROVRC ... TO PRINT /S2PRIC/
C              PRBCDC ... TO PRINT /S2BCDC/ AND XYSBCP
C
C     SECONDARY CONSTANTS
C
      MXX=MX+1
      DXM=(XMXX-XM1)/REAL(MX)
      XM(1)=XM1
      NXX=NX+1
      DYN=(YNXX-YN1)/REAL(NX)
      YN(1)=YN1
C
C     CHECK IF MDIM AND NDIM ARE LARGER THAN THE NUMBER OF NODAL INTERVA
C
      IF(MXX.GT.MDIM.OR.NXX.GT.NDIM) GO TO 90
C
C     SET NODAL POINTS IN BOTH EARTH- AND STORM-RELATIVE COORDINATES
C     XMC AND YNC ARE IN EARTH-RELATIVE COORDINATES, COSYN IS COS(YNC)
C     XM AND YN ARE IN STORM-RELATIVE COORDINATES
C
      DO M=2,MXX
         XM(M)=XM1+(M-1)*DXM
      ENDDO
C
C
      DO N=2,NXX
         YN(N)=YN1+(N-1)*DYN
      ENDDO
C
C
      COSYN(NXX)=COSDEG_8(YNT)
      IF(IHC .EQ. 0)  THEN
        XMC(1)=ABS(XML)
        YNC(1)=YNB
        DO M=2,MXX
          XMC(M)=ABS(XML+(M-1)*DXM)
        ENDDO
        DO N=2,NXX
          YNC(N)=YNB+(N-1)*DYN
          COSYN(NXX+1-N)=COSDEG_8(YNT-(N-1)*DYN)
        ENDDO
      ELSE
        DO 21 N=1,NXX
          CALL MERCLL(XM(1),YN(N),XMC(1),YNC(N),1)
          COSYN(NXX+1-N)=COSDEG_8(YNT-(N-1)*DYN)
   21   CONTINUE
        DO 22 M=1,MXX
          CALL MERCLL(XM(M),YN(1),XMC(M),YNC(1),1)
          XMC(M)=ABS(XMC(M))
   22   CONTINUE
      ENDIF
C
C     CONSTANTS FOR BASIS FUNCTION CALCULATION
C
      DX0=1./DXM
      DX1=3.*DX0
      DX2=6.*DX0**2
      DY0=1./DYN
      DY1=3.*DY0
      DY2=6.*DY0**2

C
C     ** DC AND BC CONSTANTS ARE NONDIMENSIONALIZED, ZC IS LENGTH OF AN
C     XYDCWL AND XYBCWL (FILTER BOUNDARY CONDITION WAVELENGTHS) MUST BE
C     IN METERS OR DEG. LAT/LON.
C
C     CONVERT TO UNITS OF DELTAY IN BOTH X AND Y DIRECTIONS
C
      IF(LLWL)  THEN
C
C     CONVERT TO DEG. LAT.
C
      DYF=DYORG
      DXF=DXORG
C
C     CONVERT TO DELTAY UNITS
C
      ELSE
      DYF=DYN
      DXF=DYF
      ENDIF
C
      IF(NFIRST .EQ. 0)  THEN
        XYDCWL(1)=XYDCWL(1)*DXF
        XYDCWL(2)=XYDCWL(2)*DYF
        XYBCWL(1)=XYBCWL(1)*DXF
        XYBCWL(2)=XYBCWL(2)*DXF
        XYBCWL(3)=XYBCWL(3)*DYF
        XYBCWL(4)=XYBCWL(4)*DYF
      ENDIF
      Z=1./PI2
      ZC(1)=Z/DXM
      ZC(2)=Z/DYN
C
      DO K=1,2
         XYSDCP(K)     =ZC(K)*XYDCWL(K)
         XYSBCP(2*K-1)=ZC(K)*XYBCWL(2*K-1)
         XYSBCP(2*K)   =ZC(K)*XYBCWL(2*K)
      ENDDO
C
C     ** BOUNDARY LINES ... K=1 AT XM1, =2 AT XMXX, =3 AT YN1, =4 AT YNX
C     ** BOUNDARY CONDITION TYPES (PERIODIC CONDITION IS NOT INCLUDED, 0
C     KBCTYP= 0 ... XSBF=0  ( YSBF=0.  SIMILAR FOR Y, IN ALL BELOW)
C             1 ... DXSBF=0
C             2 ... DDXSBF=0
C            10 ... (-/+)XSBCPI*DXSBF+XSBF=0     (- AT XM1, + AT XMXX)
C            20 ... (XSBCPI**2)*DDXSBF+XSBF=0
C            21 ... (-/+)XSBCPI*DDXSBF+DXSBF=0
C     ** COEFFICIENTS DEFINING XBF AND YBF AT THE BOUNDARY
C
      DO 38 K=1,4
      KK=2*K-1
      IF(KBCTYP(K).EQ. 0) GO TO 31
      IF(KBCTYP(K).EQ. 1) GO TO 32
      IF(KBCTYP(K).EQ. 2) GO TO 33
      IF(KBCTYP(K).EQ.10) GO TO 34
      IF(KBCTYP(K).EQ.20) GO TO 35
      IF(KBCTYP(K).EQ.21) GO TO 36
      GO TO 91
   31 CBCBF(KK)  =-1.
      CBCBF(KK+1)=-0.25
      GO TO 38
   32 CBCBF(KK)  = 0.
      CBCBF(KK+1)= 0.25
      GO TO 38
   33 CBCBF(KK)  = 0.5
      CBCBF(KK+1)=-0.25
      GO TO 38
   34 CBCBF(KK)  =-1./(3.*XYSBCP(K)+1.)
      CBCBF(KK+1)= 0.25+0.5*CBCBF(KK)
      GO TO 38
   35 Z=3.*XYSBCP(K)**2
      CBCBF(KK)  = 0.5*(Z-1.)/(Z+0.5)
      CBCBF(KK+1)=-0.25
      GO TO 38
   36 CBCBF(KK)  = 0.5*XYSBCP(K)/(0.5+XYSBCP(K))
      CBCBF(KK+1)= 0.25-CBCBF(KK)
   38 CONTINUE
C
C     ** CHECK BC TYPES AND DEFINE CORNER CONDITIONS (OCT 79)
C
      CALL SLOCCO
C
C     ** SLOVER DONE **
C
      NFIRST=1
      IDELTA = ISECND(INSEC)
      WRITE(6,840) IDELTA
  840 FORMAT(/' === SLOVER DONE ===',T91,'ELAPSED TIME=',I6)
      IF(LLWL) THEN
      ULBL='(DEG. LATITUDE)'
      ELSE
      ULBL='(DELTAY UNITS) '
      ENDIF
      IF(IHC .EQ. 0) THEN
      WRITE(6,880) IDSPC,JPD,MX,NX,KDCTYP,(KBCTYP(I),I=1,4),
     1    XM1,XMXX,YN1,YNXX,DXM,DYN,ULBL,XYDCWL(1)/DXF,XYDCWL(2)/DYF,
     2    ULBL,(XYBCWL(I)/DXF,I=1,2),(XYBCWL(I)/DYF,I=3,4)
      ELSE
      WRITE(6,881) IDSPC,JPD,MX,NX,KDCTYP,(KBCTYP(I),I=1,4),
     1    XM1,XMXX,YN1,YNXX,DXM,DYN,ULBL,XYDCWL(1)/DXF,XYDCWL(2)/DYF,
     2    ULBL,(XYBCWL(I)/DXF,I=1,2),(XYBCWL(I)/DYF,I=3,4)
      ENDIF
  880 FORMAT(/'.../S2PRIC/...',/,9X,A125,/,9X,'JPD=',I3,3X,'(MX,NX)',
     1       2I3,', (DC)',I2,', (BC)',4I3,',   (XY LIMITS)',4F8.3,
     2       '   DELTAX=',F6.3,' DEG.',/,9X,'DELTAY=',F6.3,
     3       ' DEG., (DCWL ',A15,')',2F7.3,
     4       ',  (BCWL ',A15,')',4F7.3,/)
  881 FORMAT(/'.../S2PRIC/...',/,9X,A125,/,9X,'JPD=',I3,3X,'(MX,NX)',
     1       2I3,', (DC)',I2,', (BC)',4I3,',   (XY LIMITS)',-5P,4F8.3,
     2       '   DELTAX=',-5P,F6.3,' HKM.',/,9X,'DELTAY=',-5P,F6.3,
     3       ' HKM., (DCWL ',A15,')',0P,2F7.3,
     4       ',  (BCWL ',A15,')',0P,4F7.3,/)
      RETURN
   90 WRITE(6,890) MXX,NXX,MDIM,NDIM
  890 FORMAT(/' === SLOVER FOUND (MXX,NXX).GT.(MDIM,NDIM) ===',3X,4I6)
      GO TO 99
   91 WRITE(6,891) KBCTYP,XYBCWL
  891 FORMAT(/' === SLOVER MET UNDEFINED KBCTYP ===',4I12,/,41X,4F12.3)
   99 CALL ABRT1(' SLOVER',891)

C

C-----------------------------------------------------------------------

      ENTRY STSPID(IDSPCZ)
C
C     PUT VALUE OF IDSPC INTO COMMON
C
      IDSPC=IDSPCZ
      RETURN
C

C-----------------------------------------------------------------------

      ENTRY STSPND(MXZ,NXZ)
      MX=MXZ
      NX=NXZ
      RETURN
C

C-----------------------------------------------------------------------

      ENTRY STDOMN(NSWLN,XMLZ,XMRZ,YNBZ,YNTZ,JPDZ,ISRCDZ)
      SGNWLN=REAL(-NSWLN)
      XML=XMLZ*SGNWLN
      XMR=XMRZ*SGNWLN
      YNB=YNBZ
      YNT=YNTZ
      JPD=JPDZ
      ISRCD=ISRCDZ
      RETURN
C

C-----------------------------------------------------------------------

      ENTRY STHORC(IHCZ,ELORG,GLORG,XSTM,YSTM,LLWLZ)
      IHC=IHCZ
      LLWL=LLWLZ
      XSTM=XSTM*SGNWLN
C
      IF(ELORG .EQ. -99.0 .OR. GLORG .EQ. -99.0)  THEN
        ELORG=0.5*(XML+XMR)
        GLORG=0.5*(YNB+YNT)
      ELSE
      ELORG=ELORG*SGNWLN
      ENDIF
C
      IF(IHC .EQ. 0)  THEN
      XM1 =XML-ELORG
      XMXX=XMR-ELORG
      YN1 =YNB-GLORG
      YNXX=YNT-GLORG
      DYORG=1.0
      DXORG=DYORG/COSDEG_8(GLORG)
      XSTM=XSTM-ELORG
      YSTM=YSTM-GLORG
C
      ELSE IF(IHC .EQ. 1)  THEN
      XSTMZ=XSTM
      YSTMZ=YSTM
      CALL MERCG0(ELORG,GLORG)
cc 7/3/05 dak -- below fixes subr. argument mismatch error
      XML_1(1) = XML
      YNB_1(1) = YNB
      XM1_1(1) = XM1
      YN1_1(1) = YN1
cc 7/3/05      CALL MERCXY(XML,YNB,XM1,YN1,1)
      call mercxy(XML_1,YNB_1,XM1_1,YN1_1,IARG_5)
cc 7/3/05 dak -- below fixes subr. argument mismatch error
      XMR_1(1) = XMR
      YNT_1(1) = YNT
      XMXX_1(1) = XMXX
      YNXX_1(1) = YNXX
cc 7/3/05      CALL MERCXY(XMR,YNT,XMXX,YNXX,1)
      call mercxy(XMR_1,YNT_1,XMXX_1,YNXX_1,IARG_5)
cc 7/3/05 dak -- below fixes subr. argument mismatch error
      XSTMZ_1(1) = XSTMZ
      YSTMZ_1(1) = YSTMZ
      XSTM_1(1) = XSTM
      YSTM_1(1) = YSTM
cc 7/3/05      CALL MERCXY(XSTMZ,YSTMZ,XSTM,YSTM,1)
      call mercxy(XSTMZ_1,YSTMZ_1,XSTM_1,YSTM_1,IARG_5)
C
C     CALCULATE CONVERSION FACTORS FROM DEG. LAT. TO MERCATOR (METERS)
C       AT COORDINATE ORIGIN
C
cc 7/3/05 dak -- below fixes subr. argument mismatch error
      elorgP1_1(1) = elorg+1.
      glorgP1_1(1) = glorg+1.
      dxorg_1(1) = DXORG
      dyorg_1(1) = DYORG
cc 7/3/05      CALL MERCXY(ELORG+1.,GLORG+1.,DXORG,DYORG,1)
      call mercxy(elorgP1_1,glorgP1_1,dxorg_1,dyorg_1,iarg_5)
      DXORG=DYORG
C
      ELSE
      WRITE(6,851) IHC,ELORG,GLORG,XSTM,YSTM
  851 FORMAT('****** IMPROPER COORDINATE SELECTION,',
     1       ' IHC,ELORG,GLORG,XSTM,YSTM=',/,30X,I4,4F14.2)
      CALL ABRT1(' STHORC',891)
      ENDIF
C
      RETURN
C

C-----------------------------------------------------------------------

      ENTRY STSPDC(KDCTYZ,XYDCW1,XYDCW2)
      KDCTYP=KDCTYZ
      XYDCWL(1)=XYDCW1
      XYDCWL(2)=XYDCW2
      NFIRST=0
      RETURN

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE STSPBC(KBCTY1,KBCTY2,KBCTY3,KBCTY4,XYBCW1,XYBCW2,
     1                  XYBCW3,XYBCW4)

      IMPLICIT NONE 

      COMMON /S2PRIC/ ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,YNB,YNT,
     1                XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4),IDSPC

      INTEGER ISRCD,JPD,MX,NX,KDCTYP,KBCTYP
      REAL    XML,XMR,YNB,YNT,XM1,XMXX,YN1,YNXX,XYDCWL,XYBCWL
      CHARACTER*125 IDSPC

      INTEGER KBCTY1,KBCTY2,KBCTY3,KBCTY4
      REAL    XYBCW1,XYBCW2,XYBCW3,XYBCW4

      KBCTYP(1)=KBCTY1
      KBCTYP(2)=KBCTY2
      KBCTYP(3)=KBCTY3
      KBCTYP(4)=KBCTY4
      XYBCWL(1)=XYBCW1
      XYBCWL(2)=XYBCW2
      XYBCWL(3)=XYBCW3
      XYBCWL(4)=XYBCW4

      RETURN

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      BLOCK DATA IBM3
      PARAMETER (KLDIM= 8)
      PARAMETER (KVDIM=20,KDTDIM=5)
C**SGIPARAMETER (KVDIM= 7,KDTDIM=5)
      PARAMETER (KPXDIM=KVDIM*KLDIM)
C
      COMMON /S2PRIC/ ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,YNB,YNT,
     1                 XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4),IDSPC
      COMMON /S2KOMP/ IDSPK(KPXDIM),IDVAR(KPXDIM),IDLEV(KPXDIM),KPX,
     1                 DMEAN(KDTDIM*KLDIM)
      CHARACTER IDSPC*125,IDSPK*40
      DATA IDSPC/' '/
      DATA KPX/KPXDIM/
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE SLOCCO
C
CIBM  COMMON /S2PRIC/ IDSPC,ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,
CIBM 1                 YNB,YNT,XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4)
      COMMON /S2PRIC/ ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,YNB,YNT,
     1                 XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4),IDSPC
      COMMON /S2BCDC/ DX0,DX1,DX2,DY0,DY1,DY2,CBCBF(8),XYSDCP(2)
      COMMON /S2CORN/ CORN(4,4)
C
      SAVE
C
      CHARACTER*125 IDSPC
C
C     ** DEFINITION OF CORNERS AND NEIGHBORS
C       KORN=1   MA=1   NA=1   , MB=2   NB=2
C       KORN=2   MA=1   NA=NXX , MB=2   NB=NX
C       KORN=3   MA=MXX NA=1   , MB=MX  NB=2
C       KORN=4   MA=MXX NA=NXX , MB=MX  NB=NX
C       CORNER   KPT=1 (MA,NA),  NEIGHBORS  KPT=2 (MA,NB),
C                                           KPT=3 (MB,NA),
C                                           KPT=4 (MB,NB)
C     ** CORNER CONDITIONS
C       ++ IF ANY BC TYPE, EITHER X-BC OR Y-BC, IS 0 OR 20,
C          NO CORNERING WILL BE DONE.
C       ++ IF BOTH BC TYPES ARE OF THE FIRST ORDER (1 OR 10), THE CORNER
C          CONDITION OF THE SAME ORDER IS AUTOMATICALLY SATISFIED.
C          THUS, NO NEED TO FLOAT THE CORNER.
C       ++ THE MIXTURE OF TYPE 10 AND TYPE 2 OR 21 IS NOT PRESENTLY HAND
C       ++ IF BOTH BC TYPES ARE OF THE SECOND ORDER (2 OR 21), OR
C          ONE OF THEM IS TYPE 1 (AS THE LIMITING CASE OF TYPE 21), THE
C          CORNER CONDITION IS IMPOSED BY FLOATING THE CORNER AMPLITUDE.
C  ***** THE FOLLOWING CONVENTION MUST BE ADHERED TO ***** *****
C  *****                                                   *****
C  *****     CORN(1,KORN)=0.   FOR NO CORNERING            *****
C  *****     CORN(1,KORN)=1.   FOR CORNERING               *****
C  *****                                                   *****
C  ***** ***** ***** ***** ***** ***** ***** ***** *****   *****
C     ** SET CORN(KPT,KORN) IN DEFAULT VALUES (NO CORNERING)
C
      DO KORN=1,4
      DO KPT =1,4
         CORN(KPT,KORN)=0.
      ENDDO
      ENDDO
C
C     ** SET CORN AT EACH CORNER INDEPENDENTLY
C
      DO KORN=1,4
         KXBC=(KORN-1)/2+1
         KYBC=MOD(KORN-1,2)+3
         KXTYP=KBCTYP(KXBC)
         KYTYP=KBCTYP(KYBC)
       IF(KXTYP.EQ.0.OR.KXTYP.EQ.20.OR.KYTYP.EQ.0.OR.KYTYP.EQ.20)GOTO 18
         KXFLG=0
         KYFLG=0
         IF(KXTYP.EQ.1) KXFLG=1
         IF(KYTYP.EQ.1) KYFLG=1
         IF(KXTYP.EQ.2 .OR. KXTYP.EQ.21) KXFLG=2
         IF(KYTYP.EQ.2 .OR. KYTYP.EQ.21) KYFLG=2
         IF(KXFLG+KYFLG.LE.2) GO TO 18
         IF(KXFLG.EQ.1) THEN

C       ++ SPECIAL CASE KXTYP=1 (AND KYTYP=2 OR 21)

            CORN(1,KORN)= 1.
            CORN(2,KORN)= 1.
            CORN(3,KORN)=-0.5
            CORN(4,KORN)= 0.5
            GO TO 18
         END IF
         IF(KYFLG.EQ.1) THEN

C       ++ SPECIAL CASE KYTYP=1 (AND KXTYP=2 OR 21)

            CORN(1,KORN)= 1.
            CORN(2,KORN)=-0.5
            CORN(3,KORN)= 1.
            CORN(4,KORN)= 0.5
            GO TO 18
         END IF

C       ++ BOTH BC TYPES ARE TYPE 2 OR 21

         XALP=4.*CBCBF(2*KXBC-1)
         YALP=4.*CBCBF(2*KYBC-1)
         SX=((2.-XALP)**2+12.)/XALP**2
         RX=((4.+XALP)**2-24.)/XALP**2
         SY=((2.-YALP)**2+12.)/YALP**2
         RY=((4.+YALP)**2-24.)/YALP**2
         Z=1./(SX+SY)
         CORN(1,KORN)= 1.
         CORN(2,KORN)= (SX+RY)*Z
         CORN(3,KORN)= (RX+SY)*Z
         CORN(4,KORN)=-(RX+RY)*Z
   18    CONTINUE
      ENDDO

      RETURN

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE IDSSUB(KPXZ,KP)
C
C          ENTRY SETKPX(KPXZ)
C          ENTRY PRDSPC
C          ENTRY PRDSPD
C          ENTRY PRDSPK(KP)
C
      PARAMETER (KLDIM= 8)
      PARAMETER (KVDIM=20,KDTDIM=5)
C**SGIPARAMETER (KVDIM= 7,KDTDIM=5)
      PARAMETER (KPXDIM=KVDIM*KLDIM)
C
CIBM  COMMON /S2PRIC/ IDSPC,ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,
CIBM 1                 YNB,YNT,XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4)
      COMMON /S2PRIC/ ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,YNB,YNT,
     1                 XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4),IDSPC
      COMMON /S2KOMP/ IDSPK(KPXDIM),IDVAR(KPXDIM),IDLEV(KPXDIM),KPX,
     1                 DMEAN(KDTDIM*KLDIM)
C
      CHARACTER*8 IDSPK*40,IDSPC*125
C
      SAVE
C
C     ** DEFAULT VALUE
C
CIBM  DATA KPX/KPXDIM/
C

C-----------------------------------------------------------------------

      ENTRY SETKPX(KPXZ)
C
      KPX=KPXZ
      RETURN
C

C-----------------------------------------------------------------------

      ENTRY PRDSPC
      WRITE(6,810) IDSPC
  810 FORMAT(9X,'...',A125)
      RETURN
C

C-----------------------------------------------------------------------

      ENTRY PRDSPK(KP)
      KPA=MAX(KP,1)
      KPB=MIN(KP,KPX)
      IF(KPA.NE.KPB) GO TO 18
      WRITE(6,815) IDSPK(KP)
  815 FORMAT(/30X,A40)
      RETURN
   18 CONTINUE
      IF(KPX.LT.1.OR.KPX.GT.KPXDIM) GO TO 90
      KPA=1
      KPB=KPX
      WRITE(6,820) KPX
  820 FORMAT(/' === PRDSPK LISTS ALL ENTRIES IN IDSPK ===   KPX=', I3)
      WRITE(6,822) (K,IDSPK(K),K=KPA,KPB)
  822 FORMAT(23X,I4,'...',A40)
      RETURN
   90 WRITE(6,890) KPX,KPXDIM
  890 FORMAT(/' === PRDSPK(0) FOUND KPX UNDEFINED OR IN ERROR.',   2I4)
      CALL ABRT1(' PRDSPK',890)
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      FUNCTION XBF(M,X)
C
C        ENTRY DXBF, DDXBF
C     ** THIS VERSION IS FOR THE SLOVER PACKAGE **
C        SLOVER MUST BE CALLED TO DEFINE CONSTANTS IN /S2BCDC/
C       ** THE EARLIER VERSION IN CHARM OR RCHARM DOES NOT WORK CORRECTL
C          WITH NEW BC TYPE 0, 10, OR 20, BECAUSE CBC11 AND CBCX1 ARE
C          NEGATIVE OR MAY BECOME NEGATIVE. (O.K. WITH TYPE 1,2,3,4 OF O
C       ** NOTE THE CHANGES IN THE USE OF SIGN FUNCTION AT STATEMENT
C          NO. 132 AND 142 IN CALCULATION OF DXBF.
C          THESE SIGN FUNCS ARE COMPLEMENTARY TO THE SIGN FUNC ON D1
C          NEAR THE BEGINNING OF DXBF ENTRY.  (03/30/79)
C         FOR THE BOUNDARY CONDITION DEFINITIONS, SEE COMMENTS IN SLOVER
C           ** PERIODIC BC IS NOT ALLOWED AT THIS TIME (3/26/79)
C   **ASSUMED**  M.GE.1 AND M.LE.MXX, X.GE.XM(1) AND X.LE.XM(MXX)
C                N.GE.1 AND N.LE.NXX, Y.GE.YN(1) AND Y.LE.YN(NXX)
C         SUBROUTINE DOES NOT TEST THESE CONDITIONS.
C          ALTHOUGH A HALF-NODE OVER-RUN OFF THE EDGES DOES NOT PRODUCE
C          LARGE ERRORS IN THE FUNCTION VALUE, ERRONEOUS RESULTS
C          MAY BE RETURNED IF THE CONDITIONS ARE NOT MET.
C
      PARAMETER (MDIM=35,NDIM=35)
CIBM  COMMON /S2PRIC/ IDSPC,ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,
CIBM 1                 YNB,YNT,XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4)
      COMMON /S2PRIC/ ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,YNB,YNT,
     1                 XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4),IDSPC
      COMMON /S2NODE/ MXX,NXX,DXM,DYN,XM(MDIM),YN(NDIM),XMC(MDIM),
     1                 YNC(NDIM),COSYN(NDIM)
      COMMON /S2BCDC/ DX0,DX1,DX2,DY0,DY1,DY2,CBCBF(8),XYSDCP(2)
C
      CHARACTER*125 IDSPC
      EQUIVALENCE (MX,LX),(CBCBF(1),CBC11),(CBCBF(2),CBC12),
     1                    (CBCBF(3),CBCX1),(CBCBF(4),CBCX2)
C
      L=M
      XS=(X-XM(L))*DX0
      Z=2.-ABS(XS)
      IF(Z.GT.0)  GO TO 15
      XBF=0.
      RETURN
   15 CONTINUE
      F=0.25*Z**3
      Z=Z-1.
      IF(Z.LE.0)  GO TO 23
      F=F-Z**3
   23 CONTINUE
      IF(L-2.LT.0)  THEN
         GO TO 30
      ELSE IF(L-2.EQ.0)  THEN
         GO TO 35
      END IF
      IF(LX-L.LT.0)  THEN
         GO TO 40
      ELSE  IF(LX-L.EQ.0)  THEN
         GO TO 45
      END IF
   25 CONTINUE
      XBF=F
      RETURN
C
C     BOUNDARY ADJUSTMENTS
C
   30 CONTINUE
      IF(Z.LE.0)  GO TO 25
      F=F+CBC11*(1.-XS)**3
      GO TO 25
   35 CONTINUE
      IF(XS.GE.0)  GO TO 25
      F=F-CBC12*XS**3
      GO TO  25
   40 CONTINUE
      IF(Z.LE.0)  GO TO 25
      F=F+CBCX1*(1.+XS)**3
      GO TO 25
   45 CONTINUE
      IF(XS.LE.0)  GO TO 25
      F=F+CBCX2*XS**3
      GO TO  25

C-----------------------------------------------------------------------

C
C   **FIRST DERIVATIVE OF CUBIC SPLINE BASIS FUNCTION
C
      ENTRY DXBF(M,X)
      D1=DX1
      L=M
      XS=(X-XM(L))*DX0
      D1=-SIGN(D1,XS)
      Z=2.-ABS(XS)
      IF(Z.GT.0)  GO TO 115
      XBF=0.
      RETURN
  115 CONTINUE
      F=0.25*Z**2
      Z=Z-1.
      IF(Z.LE.0)  GO TO 123
      F=F-Z**2
  123 CONTINUE
      IF(L-2.LT.0)  THEN
         GO TO 130
      ELSE IF (L-2.EQ.0)  THEN
         GO TO 135
      END IF
      IF(LX-L.LT.0)  THEN
         GO TO 140
      ELSE  IF(LX-L.EQ.0)  THEN
         GO TO 145
      END IF
  125 CONTINUE
      XBF=F*D1
      RETURN
  130 CONTINUE
      IF(Z.LE.0)  GO TO 125
      F=F+CBC11*SIGN((1.-XS)**2,XS)
      GO TO 125
  135 CONTINUE
      IF(XS.GE.0)  GO TO 125
      F=F-CBC12*XS**2
      GO TO 125
  140 CONTINUE
      IF(Z.LE.0) GO TO 125
      F=F-CBCX1*SIGN((1.+XS)**2,XS)
      GO TO 125
  145 CONTINUE
      IF(XS.LE.0) GO TO 125
      F=F-CBCX2*XS**2
      GO TO 125

C-----------------------------------------------------------------------

C
C   **SECOND DERIVATIVE OF CUBIC SPLINE BASIS FUNCTION
C
      ENTRY DDXBF(M,X)
      D2=DX2
      L=M
      XS=(X-XM(L))*DX0
      Z=2.-ABS(XS)
      IF(Z.GT.0)  GO TO 215
      XBF=0.
      RETURN
  215 CONTINUE
      F=0.25*Z
      Z=Z-1.
      IF(Z.LE.0)  GO TO 223
      F=F-Z
  223 CONTINUE
      IF(L-2.LT.0)  THEN
         GO TO 230
      ELSE  IF(L-2.EQ.0)  THEN
         GO TO 235
      END IF
      IF(LX-L.LT.0) THEN
         GO TO 240
      ELSE  IF(LX-L.EQ.0)  THEN
         GO TO 245
      END IF
  225 CONTINUE
      XBF=F*D2
      RETURN
  230 CONTINUE
      IF(Z.LE.0) GO TO 225
      F=F+CBC11*(1.-XS)
      GO TO 225
  235 CONTINUE
      IF(XS.GE.0) GO TO 225
      F=F-CBC12*XS
      GO TO 225
  240 CONTINUE
      IF(Z.LE.0) GO TO 225
      F=F+CBCX1*(1.+XS)
      GO TO 225
  245 CONTINUE
      IF(XS.LE.0) GO TO 225
      F=F+CBCX2*XS
      GO TO 225
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      FUNCTION Y1BF(N,Y)
CCCCC    ENTRY D1YBF, D1YSBF, DD1YBF, DD1YSF
C
      PARAMETER (NDIM=71)
C
      COMMON /S1PRIC/ NX,KDCTYP,KBCTYP(2),YN1,YNXX,YDCWL,YBCWL(2),IDSPC
      COMMON /S1NODE/ NXX,DYN,YN(NDIM)
      COMMON /S1BCDC/ DY0,DY1,DY2,CBCBF(4),YSDCPI
C
      CHARACTER*125 IDSPC
C
      EQUIVALENCE (NX,LX),(CBCBF(1),CBC11),(CBCBF(2),CBC12),
     1                    (CBCBF(3),CBCX1),(CBCBF(4),CBCX2)
C
CCCC  ENTRY Y1BF

      L=N
      XS=(Y-YN(L))*DY0
      Z=2.-ABS(XS)
      IF(Z.GT.0) GO TO 15
      Y1BF=0.
      RETURN
   15 CONTINUE
      F=0.25*Z**3
      Z=Z-1.
      IF(Z.LE.0)  GO TO 23
      F=F-Z**3
   23 CONTINUE
      IF(L-2.LT.0) THEN
         GO TO 30
      ELSE  IF(L-2.EQ.0) THEN
         GO TO 35
      END IF
      IF(LX-L.LT.0) THEN
         GO TO 40
      ELSE  IF(LX-L.EQ.0) THEN
         GO TO 45
      END IF
   25 CONTINUE
      Y1BF=F
      RETURN
C
C     BOUNDARY ADJUSTMENTS
C
   30 CONTINUE
      IF(Z.LE.0)  GO TO 25
      F=F+CBC11*(1.-XS)**3
      GO TO 25
   35 CONTINUE
      IF(XS.GE.0) GO TO 25
      F=F-CBC12*XS**3
      GO TO  25
   40 CONTINUE
      IF(Z.LE.0)  GO TO 25
      F=F+CBCX1*(1.+XS)**3
      GO TO 25
   45 CONTINUE
      IF(XS.LE.0)  GO TO 25
      F=F+CBCX2*XS**3
      GO TO  25


C-----------------------------------------------------------------------

C
      ENTRY D1YBF(N,Y)
      D1=DY1
      L=N
      XS=(Y-YN(L))*DY0
      D1=-SIGN(D1,XS)
      Z=2.-ABS(XS)
      IF(Z.GT.0) GO TO 115
      Y1BF=0.
      RETURN
  115 CONTINUE
      F=0.25*Z**2
      Z=Z-1.
      IF(Z.LE.0) GO TO 123
      F=F-Z**2
  123 CONTINUE
      IF(L-2.LT.0) THEN
         GO TO 130
      ELSE  IF(L-2.EQ.0) THEN
         GO TO 135
      END IF
      IF(LX-L.LT.0) THEN
         GO TO 140
      ELSE  IF(LX-L.EQ.0) THEN
         GO TO 145
      END IF
  125 CONTINUE
      Y1BF=F*D1
      RETURN
  130 CONTINUE
      IF(Z.LE.0) GO TO 125
      F=F+CBC11*SIGN((1.-XS)**2,XS)
      GO TO 125
  135 CONTINUE
      IF(XS.GE.0) GO TO 125
      F=F-CBC12*XS**2
      GO TO 125
  140 CONTINUE
      IF(Z.LE.0) GO TO 125
      F=F-CBCX1*SIGN((1.+XS)**2,XS)
      GO TO 125
  145 CONTINUE
      IF(XS.LE.0) GO TO 125
      F=F-CBCX2*XS**2
      GO TO 125
C

C-----------------------------------------------------------------------

      ENTRY DD1YBF(N,Y)
      D2=DY2
      L=N
      XS=(Y-YN(L))*DY0
      Z=2.-ABS(XS)
      IF(Z.GT.0) GO TO 215
      Y1BF=0.
      RETURN
  215 CONTINUE
      F=0.25*Z
      Z=Z-1.
      IF(Z.LE.0) GO TO 223
      F=F-Z
  223 CONTINUE
      IF(L-2.LT.0) THEN
         GO TO 230
      ELSE  IF(L-2.EQ.0) THEN
         GO TO 235
      END IF
      IF(LX-L.LT.0) THEN
         GO TO 240
      ELSE  IF(LX-L.EQ.0) THEN
         GO TO 245
      END IF
  225 CONTINUE
      Y1BF=F*D2
      RETURN
  230 CONTINUE
      IF(Z.LE.0) GO TO 225
      F=F+CBC11*(1.-XS)
      GO TO 225
  235 CONTINUE
      IF(XS.GE.0) GO TO 225
      F=F-CBC12*XS
      GO TO 225
  240 CONTINUE
      IF(Z.LE.0) GO TO 225
      F=F+CBCX1*(1.+XS)
      GO TO 225
  245 CONTINUE
      IF(XS.LE.0) GO TO 225
      F=F+CBCX2*XS
      GO TO 225
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE MERCAT(ELO0,GGL0,ELO,GGL,X,Y,LLX)
C
C          ENTRY MERCG0(ELO0,GGL0)    SET THE ORIGIN IF AND ONLY IF MFLA
C          ENTRY MERCXY(ELO,GGL,X,Y)  CONVERT (ELO,GGL) TO (X,Y)
C          ENTRY MERCLL(X,Y,ELO,GGL)  CONVERT (X,Y) TO (ELO,GGL)
C     BASIC VARIABLES OF MERCATOR PROJECTION ROUTINE
C        X,Y   MERCATOR COORDINATES IN METER.
C        ELO   EAST LONGITUDE (NEGATIVE IF WEST) IN DEGREE
C        GGL   GEOGRAPHICAL LATITUDE IN DEGREE
C        GCL   GEOCENTRIC LATITUDE IN RADIAN
C     FOR FASTER CALCULATIONS, USE GCL=1.0067*CRDNDG*GGL,AND (Y,GCL)-TAB
C       ARG1,ARG2 MAY BE PLACED IN COMMON.
C
      SAVE
C
      DIMENSION ELO(LLX),GGL(LLX),X(LLX),Y(LLX)
      COMMON /MERCON/ RDSEQU,RDSPOL,RDSSPH,MFLAG,ORGELO,ORGGGL
CIBM  DATA INITIALIZATION MOVED TO BLOCK DATA BELOW THIS SUBROUTINE
CIBM  DATA RDSEQU/6378.4E3/,RDSPOL/6356.9E3/,RDSSPH/6378.E3/, MFLAG/0/
C

C-----------------------------------------------------------------------

      ENTRY MERCG0(ELO0,GGL0)
      IF(MFLAG.NE.0) RETURN
C
C     INPUT ELO0,GGL0 LONGITUDE AND LATITUDE OF THE ORIGIN IN DEGREES
C
      ORGELO=ELO0
      ORGGGL=GGL0
      CGCLGG=(RDSPOL/RDSEQU)**2
      CRDNDG=3.1415926536/180.
      GCL0=ATAN(CGCLGG*TAN(CRDNDG*GGL0))
      FML0=1./COS(GCL0)
      CRDSS2=RDSSPH*2./FML0
      CXELO=RDSSPH*CRDNDG/FML0
      CYGCL=RDSSPH/FML0
      X0=CXELO*ELO0
      Y0=CYGCL*ALOG((1.+TAN(.5*GCL0))/(1.-TAN(.5*GCL0)))
      MFLAG=1
      RETURN

C-----------------------------------------------------------------------

C
      ENTRY MERCXY(ELO,GGL,X,Y,LLX)
C
C     INPUT    ELO,GGL   LONGITUDE AND LATITUDE IN DEGREES
C     OUTPUT   X,  Y     MERCATOR COORDINATES IN METERS
C
      DO 10 LL=1,LLX
        GCL=ATAN(CGCLGG*TAN(CRDNDG*GGL(LL)))
        Z=TAN(0.5*GCL)
        X(LL)=CXELO*ELO(LL)-X0
        Y(LL)=CYGCL*ALOG((1.+Z)/(1.-Z))-Y0
   10 CONTINUE
      RETURN

C-----------------------------------------------------------------------

C
      ENTRY MERCLL(X,Y,ELO,GGL,LLX)
C
C     INPUT    X,  Y     MERCATOR COORDINATES IN METERS
C     OUTPUT   ELO,GGL   LONGITUDE AND LATITUDE IN DEGREES
C
      DO  LL=1,LLX
         GCL=2.*ATAN(TANH((Y(LL)+Y0)/CRDSS2))
         ELO(LL)=(X(LL)+X0)/CXELO
         GGL(LL)=ATAN(TAN(GCL)/CGCLGG)/CRDNDG
      ENDDO
      RETURN

C-----------------------------------------------------------------------
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      BLOCK DATA IBM5
      COMMON /MERCON/ RDSEQU,RDSPOL,RDSSPH,MFLAG,ORGELO,ORGGGL
      DATA RDSEQU/6378.4E3/,RDSPOL/6356.9E3/,RDSSPH/6378.E3/, MFLAG/0/
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE DOMCHK(XZ,YZ,IN)
CIBM  COMMON /S2PRIC/ IDSPC,ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,
CIBM 1                 YNB,YNT,XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4)
      COMMON /S2PRIC/ ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,YNB,YNT,
     1                 XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4),IDSPC
      CHARACTER IDSPC*125
C
      SAVE
C
C     THIS SUBROUTINE DETERMINES IF A GIVEN LOCATION IS WITHIN
C     DOMAIN BOUNDARIES.  THE INTERNAL COORDINATE (XM1,XMXX)
C     AND (YN1,YNXX) IS USED.  THE SUBROUTINE RETURNS IN=1 IF
C     INSIDE THE DOMAIN, IN=0 IF OUTSIDE.
C
      IN=1
      IF(XZ .LT. XM1 .OR. XZ .GT. XMXX)  IN=0
      IF(YZ .LT. YN1 .OR. YZ .GT. YNXX)  IN=0
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE COORDS(NFIX,ihz)
C
      PARAMETER (LDXDIM=8000)
      PARAMETER (NFXDIM=20)
CIBM  COMMON /S2PRIC/ IDSPC,ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,
CIBM 1                 YNB,YNT,XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4)
      COMMON /S2PRIC/ ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,YNB,YNT,
     1                 XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4),IDSPC
      COMMON/S2DTPT/IDSPD1,IDSPD2,LDX,XD(LDXDIM),YD(LDXDIM),WD(LDXDIM),
     1               ID(LDXDIM),LXSORT(LDXDIM)
      COMMON/XYT/IDAYOB(LDXDIM),UTCOB(LDXDIM),XSTM(NFXDIM),YSTM(NFXDIM),
     1            WSTM(NFXDIM),IDAYST(NFXDIM),UTCSTM(NFXDIM),
     2            ELORG,GLORG,XSTM0,YSTM0,JDAY0,UTC0,NFIX0,IDAYMN
C
      SAVE
      CHARACTER*8 HORCZ,IDSPD1,IDSPD2*72,IDSPC*125
      DIMENSION DTFIX(NFXDIM),DTOB(LDXDIM),XDZ(LDXDIM),YDZ(LDXDIM),
     1          HORCZ(2),XZA(1),YZA(1),XSTM0A(1),YSTM0A(1)
      DATA HORCZ/'LAT/LONG','MERCATOR'/
C
C     THIS SUBROUTINE DEFINES COORDINATE LOCATION OF ALL DATA POINTS.
C     THE DOMAIN SIZE IS NOT AFFECTED.  THE CENTER (0,0) OF THE COORDINA
C     SYSTEM HAS BEEN DEFINED IN ENTRY STHORC OF SUBROUTINE SLOVER.
C       "EARTH COORDINATES" (EC) MAINTAINS THE (X,Y) POSITION OF EACH OB
C          IRRESPECTIVE OF THE OBS. TIME.
C       "STORM-RELATIVE COORDINATES" (SRC) ADJUSTS THE (X,Y) POSITION
C          OF EACH OBSERVATION TO BE IN THE SAME RELATIVE POSITION TO
C          THE STORM CENTER AT THE ANALYSIS TIME.
C

C-----------------------------------------------------------------------

      ENTRY CHORC(IHZ)
      IHCSET=IHZ
      RETURN
C

C-----------------------------------------------------------------------

      ENTRY CTRANS(NFIX)
C
      IF(IHCSET .EQ. 0)  THEN
C
C     CONVERT STORM POSITIONS AND DATA LOCATIONS FOR LAT./LONG.
C       COORDINATES BY SUBTRACTING OFF LAT./LONG. OF COORDINATE
C       ORIGIN.
C
      DO N=1,NFIX
      XSTM(N)=XSTM(N)-ELORG
      YSTM(N)=YSTM(N)-GLORG
      ENDDO
C
      DO LD=1,LDX
      XD(LD)=XD(LD)-ELORG
      YD(LD)=YD(LD)-GLORG
      ENDDO
C
C     CONVERT STORM POSITIONS AND DATA LOCATIONS FOR MERCATOR
C       COORDINATES.
C
      ELSE IF(IHCSET .EQ. 1)  THEN

      XDZ(1:LDX)=XD(1:LDX)
      YDZ(1:LDX)=YD(1:LDX)
C
      CALL MERCXY(XDZ,YDZ,XD,YD,LDX)
C
      XDZ(1:NFIX)=XSTM(1:NFIX)
      YDZ(1:NFIX)=YSTM(1:NFIX)
C
      CALL MERCXY(XDZ,YDZ,XSTM,YSTM,NFIX)
      ELSE
      WRITE(6,31) IHCSET
   31 FORMAT('******IMPROPER COORDINATE SYSTEM IN CTRANS,',
     1       ' IHCSET=',I5)
      CALL ABRT1(' CTRANS',31)
      ENDIF
C
C     FOR EARTH-RELATIVE COORDINATES
C
      IF(ISRCD .EQ. 0) THEN
      WRITE(6,126) HORCZ(IHCSET+1),ELORG,GLORG
  126 FORMAT('....FIXED (',A8,') EARTH COORDINATES RELATIVE TO LONG.=',
     1       F8.3,' AND LATITUDE=',F7.3)
      RETURN
C
C     FOR STORM-RELATIVE COORDINATES:  CONVERTING OBSERVATIONS
C
      ELSE IF(ISRCD .EQ. 1)  THEN
      CALL XTIME(IDAYMN,000.0,IYMN,IMMN,IDMN,HRMN)
C
      DO 210 N=1,NFIX
      CALL XTIME(IDAYST(N),UTCSTM(N),IYR,IMO,IDA,HR)
      CALL DTIME(IYMN,IMMN,IDMN,HRMN,IYR,IMO,IDA,HR,DTFIX(N))
  210 CONTINUE
C
      DO 400 LD=1,LDX
      CALL XTIME(IDAYOB(LD),UTCOB(LD),IYR,IMO,IDA,HR)
      CALL DTIME(IYMN,IMMN,IDMN,HRMN,IYR,IMO,IDA,HR,DTOB(LD))
      NFIX1=NFIX-1
      DO 300 N=1,NFIX1
      NF=N
      IF(DTOB(LD) .GT. DTFIX(N) .AND. DTOB(LD) .LE. DTFIX(N+1))
     1      GO TO 310
  300 CONTINUE
      WRITE(6,301)  LD,DTOB(LD),(DTFIX(NN),NN=1,NFIX),IDAYOB(LD),
     1              UTCOB(LD),IYR,IMO,IDA,HR,IYMN,IMMN,IDMN,HRMN
  301 FORMAT(/'****** OBS. TIME',I5,'...CANNOT FIND 2 FIX POSITIONS',
     1       F10.2/3(10X,F10.2/),I13,F13.3/2(3I10,F13.3/))
      CALL ABRT1(' CTRANS',301)
  310 DT=DTFIX(NF+1)-DTFIX(NF)
      IF(ABS(DT) .LT. 1.E-4)  GO TO 910
      RAT=(DTOB(LD)-DTFIX(NF))/(DTFIX(NF+1)-DTFIX(NF))
      XSTOB=XSTM(NF)+(XSTM(NF+1)-XSTM(NF))*RAT-XSTM0
      YSTOB=YSTM(NF)+(YSTM(NF+1)-YSTM(NF))*RAT-YSTM0
      XD(LD)=XD(LD)-XSTOB
      YD(LD)=YD(LD)-YSTOB
  400 CONTINUE
C
      IF(IHCSET .EQ. 1)  THEN
      XSTM0A(1) = XSTM0
      YSTM0A(1) = YSTM0
      XZA(1) = XZ
      YZA(1) = YZ
      CALL MERCLL(XSTM0A,YSTM0A,XZA,YZA,1)
      ELSE
      XZ=XSTM0+ELORG
      YZ=YSTM0+GLORG
      ENDIF
C
      CALL XTIME(JDAY0,UTC0,IYR,IMO,IDA,HR)
      WRITE(6,411)  HORCZ(IHCSET+1),HR,IDA,IMO,IYR,YZ,XZ
  411 FORMAT('....',A8,' COORDINATES ADJUSTED FOR MOVING STORM',
     1       ' AT TIME',F9.0,' UTC, ON',I3,'/',I3,'/',I5,/,38X,
     2       'STORM LOCATION: ',' LATITUDE=',F7.3,'   LONGITUDE=',F8.3)
C
C     FOR STORM-RELATIVE COORDINATES, PRINT ONLY THE POSITION OF THE
C         STORM AT TIME=T0  (JDAY0,UTC0)
C
C      DO 500 N=1,NFIX
C      XSTM(N)=XSTM(N)-XSTM(NFIX0)
C      YSTM(N)=YSTM(N)-YSTM(NFIX0)
C  500 CONTINUE
      NFIX=1
      WSTM(NFIX0)=99
      RETURN
C
      ELSE
      WRITE(6,901) ISRCD
  901 FORMAT('******INVALID OPTION FOR ISRCD IN COORDS, ISRCD=',I5)
      CALL ABRT1(' CTRANS',901)
      ENDIF
C
  910 WRITE(6,911)  NF,DTFIX(NF),DTFIX(NF+1)
  911 FORMAT(/'***** FIX TIMES ARE EQUAL IN CTRANS',I5,2F15.5)
      CALL ABRT1(' CTRANS',911)
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE DTIME(IYZ,IMZ,IDZ,HRZ,IYX,IMX,IDX,HRX,DHR)
      DIMENSION MODA(12)
      DATA MODA/31,28,31,30,31,30,31,31,30,31,30,31/
C
C     THIS OUTINE CALCULATES TIME DIFFERENCES.
C          'Z' IS REFERENCE TIME.
C          'X' IS TIME RELATIVE TO REFERENCE TIME IN DECIMAL HOURS,
C               MUST BE GREATER THAN TIME 'Z'.
C
      DHR=0.0
      IDZZ=IDZ
      IMZZ=IMZ
      HRZZ=HRZ
C
      IF(IYZ .EQ. IYX)  GO TO 100
      DHR=24.-HRZZ+REAL((MODA(IMZZ)-IDZZ)*24+MAX(IYX-(IYZ+1),0)*8760)
      IMZZ=MOD(IMZZ+1,12)
      IDZZ=1
      HRZZ=0.0
C
      IF(IMZZ .EQ. 1)  GO TO 100
C
      DO I=IMZZ,12
      DHR=DHR+REAL(MODA(I)*24)
      ENDDO
C
      IMZZ=1
  100 IF(IMZZ .EQ. IMX)  GO TO 200
      DHR=DHR+REAL((MODA(IMZZ)-IDZZ)*24)+24.-HRZZ
      IMZZ1=IMZZ+1
      IF(IMZZ1 .GE. IMX)  GO TO 120
      IMX1=IMX-1
C
      DO I=IMZZ1,IMX1
      DHR=DHR+REAL(MODA(I)*24)
      ENDDO
C
  120 IMZZ=IMZZ1
      IDZZ=1
      HRZZ=0.0
  200 DHR=DHR+REAL((IDX-IDZZ-1)*24)+24.-HRZZ+HRX
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    XTIME       GET YEAR,MONTH,DAY & HR FROM DATE & TIME
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: GET YEAR, MONTH, DAY, AND HOUR FROM DATE (YYYYMMDD) AND
C   TIME (HHMM).
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL XTIME(IDATEJ,UTC,IYR,IMO,IDA,HR)
C   INPUT ARGUMENT LIST:
C     IDATEJ   - SLORD DATE FORMAT FOR DATE (YYYYMMDD)
C     UTC      - SLORD DATE FORMAT FOR DATE (HHMM.)
C
C   OUTPUT ARGUMENT LIST:
C     IYR      - YEAR (YYYY)
C     IMO      - MONTH
C     IDA      - DAY
C     HR       - HOUR
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE XTIME(IDATEJ,UTC,IYR,IMO,IDA,HR)
      IYR = IDATEJ/10000
      IMO = MOD((IDATEJ/100),100)
      IDA = MOD(IDATEJ,100)
      HR =REAL(NINT(UTC/100.-0.3))
      HR =HR+(UTC-HR*100.)/60.

      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE WDWSP(U,V)
      DATA EPS/1.E-3/
C
C     THIS ENTRY PRODUCES PACKED SPEED (*100) AND WIND DIRECTION
C
      WDX= 0.0
      WSX=-900.
      IF(U .EQ. -99.0 .OR. V .EQ. -99.0)  GO TO 10
      IF(V .NE. EPS)  V=V-EPS
      WSX=REAL(NINT(SQRT(U**2+V**2)*100.))
      WDX=ATAN2DEG(-U,-V)
      IF(WDX .LT. 0.0)  WDX=360.+WDX
      WDX=REAL(NINT(WDX))/1000.0
   10 V=WDX+WSX
      RETURN

C-----------------------------------------------------------------------

C
      ENTRY WDWS(U,V)
C
C     THIS ENTRY PRODUCED WIND DIRECTION/SPEED FROM U,V
C
      IF(V .NE. EPS)  V=V-EPS
      WSX=SQRT(U**2+V**2)
      WDX=ATAN2DEG(-U,-V)
      IF(WDX .LT. 0.0)  WDX=WDX+360.
      U=WDX
      V=WSX
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE BOGUS(LD,LP,FDD,DPV,IPRT)
C
      PARAMETER (LDXDIM=8000)
      COMMON/S2DTPT/IDSPD1,IDSPD2,LDX,XD(LDXDIM),YD(LDXDIM),WD(LDXDIM),
     1               ID(LDXDIM),LXSORT(LDXDIM)
C
      CHARACTER*8 IDSPD1,IDSPD2*72
C
      SAVE
C
      DIMENSION DDP(4),XDP(4),YDP(4),RAD(4),FDD(LDXDIM)
C
C     THIS ROUTINE SUPPLIES BOGUS POINT DATA BY LINEAR INTERPOLATION
C     FROM NEIGHBORING POINTS.
C     IMPORTANT:  IT IS ASSUMED THAT DATA HAS BEEN SORTED PREVIOUSLY
C                 BY X-VALUE (LONGITUDE).
C           LD IS LXSORT INDEX OF BOGUS POINT.
C           LP IS LOCATION IN FDD ARRAY.
C           QUADRANTS:            |
C                             1   |   2
C                           -------------
C                             4   |   3
C                                 |
C
      DATA RADMX/1.0E10/
      X0=XD(LXSORT(LD))
      Y0=YD(LXSORT(LD))
      LST =LD+1
      LEND=LDX
      LINC=1
      NQD =2
      NQDD=1
      EPS =1.E-3
C
      RAD=RADMX
C
      IF(LST .GT. LEND)  GO TO 110
      lgo = 110
C
C     SEARCH LOOP: FIRST SEARCH EAST QUADRANTS (2&3).  THEN CHANGE
C                  DO-LOOP INDICES FOR WEST QUADRANTS (1&4)
C
   10 DO 100 LL=LST,LEND,LINC
      LS=LXSORT(LL)
      XP=XD(LS)-X0
      YP=YD(LS)-Y0
      DP=FDD(LS)
      IF(DP .EQ. -99.0) GO TO 100
      RAD0=SQRT(XP**2+YP**2)
      IF(YP .LE. EPS) GO TO 50
C
C     OFFSETS OF VALUE EPS ARE GIVEN TO XDP AND YPD TO ENSURE THAT THEY
C     ARE IN THE PROPER QUADRANTS
C
      IF(RAD0 .GE. RAD(NQD))  GO TO 90
      RAD(NQD)=RAD0
      XDP(NQD)=XP+EPS
      YDP(NQD)=YP+ABS(EPS)
      DDP(NQD)=DP
      GO TO 100
   50 CONTINUE
      IF(RAD0 .GE. RAD(NQD+NQDD))  GO TO 90
      RAD(NQD+NQDD)=RAD0
      XDP(NQD+NQDD)=XP+EPS
      YDP(NQD+NQDD)=YP-ABS(EPS)
      DDP(NQD+NQDD)=DP
      GO TO 100
C
C     EXIT IF X DISTANCE EXCEEDS MAXIMUM RADIUS FOR BOTH QUADRANTS
C
   90 RAD2=MAX(RAD(NQD),RAD(NQD+NQDD))
      XD2 =ABS(XP)
      IF(XD2 .GT. RAD2)  THEN
      if(lgo.eq.110)  then
         go to 110
      else  if(lgo.eq.200)  then
         go to 200
      else
         call ABRT1(' BOGUS ',90)
      endif
      ENDIF
  100 CONTINUE
C
      if(lgo.eq.110)  then
         go to 110
      else  if(lgo.eq.200)  then
         go to 200
      else
         call ABRT1(' BOGUS ',100)
      endif
C
C     RE-LOOP FOR WEST QUADRANTS BY CHANGING INDICES
C
  110 LST =LD-1
      LEND=1
      LINC=-1
      NQD =1
      NQDD=3
      EPS =-1.E-4
      IF(LST .LT. LEND)  GO TO 200
      lgo = 200
      GO TO 10
C
C     ELIMINATE QUADRANTS WITH NO DATA POINTS FOR INTERPOLATION
C
  200 KQD=0
      RADMN=1.E10
C
      DO 210 NQD=1,4
      IF(RAD(NQD) .EQ. RADMX)  GO TO 210
      KQD=KQD+1
      RAD(KQD)=RAD(NQD)
      XDP(KQD)=XDP(NQD)
      YDP(KQD)=YDP(NQD)
      DDP(KQD)=DDP(NQD)
      IF(RAD(KQD) .GE. RADMN)  GO TO 210
      RADMN=RAD(KQD)
      NQMN=KQD
  210 CONTINUE
C
C     DO LINEAR INTERPOLATION
C
C** DEBUG  (BLOCK IF)
c && 6 comments
CC    IF(IPRT .EQ. 1)  THEN
CC    WRITE(6,2211) KQD
C2211 FORMAT(/'...KQD=',I4,/,' ...KQZ,DDP,XDP,YDP=')
CC    WRITE(6,2212) (KQZ,DDP(KQZ),XDP(KQZ),YDP(KQZ),KQZ=1,KQD)
C2212 FORMAT('...',I3,3F14.2)
CC    ENDIF
      CALL LINT(DDP,XDP,YDP,KQD,DPV,IER)
C** DEBUG
c && 2 comments
CC    WRITE(6,2213) DPV
C2213 FORMAT('...DPV=',F10.3)
      IF(IER .EQ. 0)  RETURN
      WRITE(2,2222)  X0,Y0,LD,LP,KQD,XP,YP,DP
 2222 FORMAT('****** BOGUS COORDINATE INFO..',2F10.2,3I6,/,20X,3F10.2)
C
C     WHEN ALL ELSE FAILS, PICK DATA FROM THE NEAREST POINT
C
      DPV=DDP(NQMN)
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE LINT(D,X,Y,KK,DINT,IER)
      DIMENSION D(4),X(4),Y(4),D5(5),X5(5),Y5(5),ZR(4),FZ(4)
C
      SAVE
C
      DATA DLMIN/1.E-3/,AMX/1.E10/,EPS/-1.E-5/
C
C     KK IS NUMBER OF POINTS TO INTERPOLATE WITH
C
      IER=0
      GO TO (10,20,30,40), KK
      CALL ABRT1('   LINT',10)
C
C     SINGLE POINT:  ASSUME CONSTANT VALUE RATHER THAN EXTRAPOLATE
C
   10 DINT=D(1)
      RETURN
C
C     TWO POINTS:  ASSUME GRADIENT=0 PERPENDICULAR TO LINE JOINING THE
C                  TWO POINTS.  IF PERPENDICULAR DOES NOT INTERSECT THE
C                  SEGMENT CONNECTING THE TWO POINTS, THEN EXTRAPOLATION
C                  WILL OCCUR: THIS IS NOT ALLOWED, SO VALUE OF CLOSEST
C                  POINT IS CHOSEN.
C
   20 XZ=0.0
      IF(ABS(Y(1)-Y(2)) .LT. DLMIN)  GO TO 25
      IF(ABS(X(1)-X(2)) .LT. DLMIN)  GO TO 27
      XZ=(Y(2)*X(1)-Y(1)*X(2))*(Y(2)-Y(1))/
     1   ((Y(2)-Y(1))**2+(X(2)-X(1))**2)
      IF(XZ .LT. MIN(X(1),X(2)) .OR. XZ .GT. MAX(X(1),X(2)))
     1  GO TO 29
C
C     IF THE TWO POINTS ARE LINED UP IN THE Y-DIRECTION
C
   25 IF(ABS(X(1)-X(2)) .LT. DLMIN)  THEN
      DINT=0.5*(D(1)+D(2))
      ELSE
      DINT=D(2)+(XZ-X(2))*(D(1)-D(2))/(X(1)-X(2))
      ENDIF
      RETURN
C
C     IF THE TWO POINTS ARE LINED UP IN THE X-DIRECTION
C
   27 DINT=(D(2)*Y(1)-D(1)*Y(2))/(Y(1)-Y(2))
      RETURN
C
C     IF ALL ELSE FAILS, USE CLOSEST POINT
C
   29 IND=1
      IF(X(1)**2+Y(1)**2 .GT. X(2)**2+Y(2)**2) IND=2
      DINT=D(IND)
      RETURN
C
C     THREE POINTS
C
   30 NQD=0
C
      ZR=-AMX
C
C     WRAP AROUND
C
      D(4)=D(1)
      X(4)=X(1)
      Y(4)=Y(1)
C
      DO 35 KL=1,3
C
C     Y-INTERCEPT=A1
C
      IF(ABS(X(KL+1)-X(KL)) .LT. DLMIN)  GO TO 33
      A1  =(Y(KL  )*X(KL+1)-X(KL  )*Y(KL+1))/(X(KL+1)-X(KL  ))
C
C     CHECK IF INTERPOLATION CAN OCCUR
C
      IF(A1 .LT. MIN(Y(KL),Y(KL+1))+EPS .OR. A1 .GT.
     1           MAX(Y(KL),Y(KL+1))-EPS)  GO TO 33
      KQD=1
      IF(A1 .LT. EPS)  KQD=3
      ZR(KQD)=A1
      IF(ABS(Y(KL+1)-Y(KL)) .LT. DLMIN)  GO TO 32
C
C     LINEAR INTERPOLATION
C
      FZ(KQD) =D(KL  )+(A1-Y(KL  ))*(D(KL+1)-D(KL  ))/(Y(KL+1)-Y(KL  ))
      GO TO 33
   32 FZ(KQD)=(D(KL  )*ABS(X(KL+1))+D(KL+1)*ABS(X(KL  )))/
     1        (ABS(X(KL  ))+ABS(X(KL+1)))
C
C     X-INTERCEPT=A2
C
   33 IF(ABS(Y(KL+1)-Y(KL)) .LT. DLMIN)  GO TO 35
      A2  =(X(KL  )*Y(KL+1)-Y(KL  )*X(KL+1))/(Y(KL+1)-Y(KL  ))
C
C     CHECK IF INTERPOLATION CAN OCCUR
C
      IF(A2 .LT. MIN(X(KL),X(KL+1))+EPS .OR. A2 .GT.
     1           MAX(X(KL),X(KL+1))-EPS)  GO TO 35
      KQD=2
      IF(A2 .LT. EPS)  KQD=4
      ZR(KQD)=A2
      IF(ABS(X(KL+1)-X(KL)) .LT. DLMIN)  GO TO 34
C
C     LINEAR INTERPOLATION
C
      FZ(KQD)=D(KL  )+(A2-X(KL ))*(D(KL+1)-D(KL  ))/
     1        (X(KL+1)-X(KL  ))
      GO TO 35
   34 FZ(KQD)=(D(KL  )*ABS(Y(KL+1))+D(KL+1)*ABS(Y(KL  )))/
     1        (ABS(Y(KL  ))+ABS(Y(KL+1)))
   35 CONTINUE
C
      KQD=0
C
C     SAVE VALID INTERCEPTS AND INTERPOLATION VALUES
C
      DO 36 NQD=1,4
      IF(ZR(NQD) .EQ. -AMX)  GO TO 36
      KQD=KQD+1
      ZR(KQD)=ZR(NQD)
      FZ(KQD)=FZ(NQD)
   36 CONTINUE
C
C     BRANCH FOR KQD=1 INDICATES ALL POINTS LIE IN STRAIGHT LINE ON A
C          PARTICULAR AXIS
C
      GO TO (20,37,38,47), KQD
      WRITE(2,361) KQD
  361 FORMAT(/'*******KQD WRONG AT 36',I4)
      IER=1
      RETURN
C
C     COLLAPSE TO 2-POINT CASE
C
   37 Y(1)=ZR(1)
      X(2)=ZR(2)
      D(1)=FZ(1)
      D(2)=FZ(2)
      X(1)=0.0
      Y(2)=0.0
      GO TO 20
   38 WRITE(2,381)  KQD,(X(K),Y(K),D(K),ZR(K),FZ(K),K=1,4)
  381 FORMAT(/'*******KQD WRONG',I4,/,(5F16.6))
      IER=1
      RETURN
C
C     ONE POINT IN EACH QUADRANT: LINEARLY INTERPOLATE TO X,Y AXES,
C                                 THEN TO ORIGIN.
C
   40 CONTINUE

      D5(1:4)=D
      X5(1:4)=X
      Y5(1:4)=Y
C
C     WRAP AROUND
C
      D5(5)=D5(1)
      X5(5)=X5(1)
      Y5(5)=Y5(1)
C
C     CALCULATE INTERCEPTS AND INTERPOLATE
C
      DO 45 KL=1,3,2
      ZR(KL)  =(Y5(KL  )*X5(KL+1)-X5(KL  )*Y5(KL+1))/(X5(KL+1)-X5(KL  ))
      ZR(KL+1)=(X5(KL+1)*Y5(KL+2)-Y5(KL+1)*X5(KL+2))/(Y5(KL+2)-Y5(KL+1))
      IF(ABS(Y5(KL+1)-Y5(KL)) .LT. DLMIN)  GO TO 42
      FZ(KL)  =D5(KL  )+(ZR(KL  )-Y5(KL  ))*(D5(KL+1)-D5(KL  ))/
     1         (Y5(KL+1)-Y5(KL  ))
      GO TO 43
   42 FZ(KL  )  =(D5(KL  )*ABS(X5(KL+1))+D5(KL+1)*ABS(X5(KL  )))/
     1           (ABS(X5(KL  ))+ABS(X5(KL+1)))
   43 IF(ABS(X5(KL+2)-X5(KL+1)) .LT. DLMIN)  GO TO 44
      FZ(KL+1)=D5(KL+1)+(ZR(KL+1)-X5(KL+1))*(D5(KL+2)-D5(KL+1))/
     1         (X5(KL+2)-X5(KL+1))
      GO TO 45
   44 FZ(KL+1)  =(D5(KL+1)*ABS(Y5(KL+2))+D5(KL+2)*ABS(Y5(KL+1)))/
     1           (ABS(Y5(KL+1))+ABS(Y5(KL+2)))
   45 CONTINUE
C
C     LINEAR INTERPOLATION
C
   47 DINT=0.0
C
      DO KL=1,2
      DINT=DINT+(ZR(KL)*FZ(KL+2)-ZR(KL+2)*FZ(KL))/(ZR(KL)-ZR(KL+2))
      ENDDO
C
      DINT=0.5*DINT
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE VFIND(KDX,KV,KL,KPF)
C
      PARAMETER (KLDIM= 8)
      PARAMETER (KVDIM=20,KDTDIM=5)
C**SGIPARAMETER (KVDIM= 7,KDTDIM=5)
      PARAMETER (KPXDIM=KVDIM*KLDIM)
C
      COMMON /S2KOMP/ IDSPK(KPXDIM),IDVAR(KPXDIM),IDLEV(KPXDIM),KPX,
     1                 DMEAN(KDTDIM*KLDIM)
      CHARACTER*40 IDSPK
C
      SAVE
C
      DO 10 KP=1,KDX
      KPF=KP
      IF(IDVAR(KP) .EQ. KV .AND. IDLEV(KP) .EQ. KL)  GO TO 20
   10 CONTINUE
C
      KPF=-1
   20 RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE DSKNMC(FKMN,KP1,KP2,FWS,FWV,MXZ,NXZ)
C
      PARAMETER (MDIM=35,NDIM=35)
      PARAMETER (LDXDIM=8000)
      PARAMETER (NFXDIM=20)
      PARAMETER (KLDIM= 8)
      PARAMETER (KVDIM=20,KDTDIM=5)
C**SGIPARAMETER (KVDIM= 7,KDTDIM=5)
      PARAMETER (KPXDIM=KVDIM*KLDIM)
C
      COMMON /DSK/MSKEF,MSKEZ,MSKDA1,MSKDA2,MSKDA3,MSKDA4,MSKDA5,MSKDA6,
     1            MSKDA7,MSKDA8,MSKDA9,MSKD11,MSKD12,MSKD13,
     2            MSKD14,MSKD15,MSKD16,MSKD17,MSKD18
CIBM  COMMON /S2PRIC/ IDSPC,ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,
CIBM 1                 YNB,YNT,XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4)
      COMMON /S2PRIC/ ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,YNB,YNT,
     1                 XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4),IDSPC
      COMMON /S2KOMP/ IDSPK(KPXDIM),IDVAR(KPXDIM),IDLEV(KPXDIM),KPX,
     1                 DMEAN(KDTDIM*KLDIM)
      COMMON/XYT/IDAYOB(LDXDIM),UTCOB(LDXDIM),XSTM(NFXDIM),YSTM(NFXDIM),
     1            WSTM(NFXDIM),IDAYST(NFXDIM),UTCSTM(NFXDIM),
     2            ELORG,GLORG,XSTM0,YSTM0,JDAY0,UTC0,NFIX0,IDAYMN
C
      SAVE
C
      CHARACTER IDSPC*125,IDSPK*40
      DIMENSION FKMN(KPXDIM,MDIM,NDIM),FWV(MXZ,NXZ,2),FWS(MXZ,NXZ)
C
      PARAMETER(IPLTUN=88)
      CHARACTER MTITLE*80
      DATA      NCHAR/40/
C
      IF(MX+1 .EQ. MXZ .AND. NX+1 .EQ. NXZ) THEN
        OPEN(UNIT=IPLTUN,FILE='GRIDDAT',STATUS='NEW',
     $    ACCESS='SEQUENTIAL',FORM='UNFORMATTED')
        DO 100 KP=KP1,KP2
          MTITLE = IDSPK(KP)
          IF(IDVAR(KP).EQ.5) THEN
            DO 70 N=1,NXZ
C
C               LATITUDE INDICES MUST BE FLIPPED
C               (UNIPLOT WANTS INDEX 1 AT NORTH POLE)
C
              N1 = NXZ - N + 1
              DO 60 M=1,MXZ
                FWV(M,N1,2)=FKMN(KP,M,N)
  60          CONTINUE
  70        CONTINUE
          ELSE
            DO 90 N=1,NXZ
              N1 = NXZ - N + 1
              DO 80 M=1,MXZ
                FWV(M,N1,1)=FKMN(KP,M,N)
                FWS(M,N1) =FKMN(KP,M,N)
  80          CONTINUE
  90        CONTINUE
          ENDIF
          IF(IDVAR(KP).EQ.5) THEN
            MTITLE = '50 MB WIND                              '
            WRITE(IPLTUN) MXZ,NXZ,FWV,MTITLE,NCHAR
          ELSEIF(IDVAR(KP).NE.4) THEN
            WRITE(IPLTUN) MXZ,NXZ,FWS,MTITLE,NCHAR
          ENDIF
          WRITE(*,'(1X,''        ... KP='',I4,''   VARIABLE #'',I3,
     $      ''   LEVEL #'',I3)') KP,IDVAR(KP),IDLEV(KP)
  100   CONTINUE
        CLOSE(UNIT=IPLTUN,STATUS='KEEP')
        WRITE(*,'(1X,''.... SPLINE INTERPOLATED VARIABLES WRITTEN '',
     $    ''TO UNIT'',I4)') IPLTUN
      ELSE
        WRITE(*,'(1X,''**** MX+1,NX+1=,'',2I5,'' ARE INCONSISTENT '',
     $    ''WITH MXZ,NXZ='',2I5,'' IN DSKNMC'')') MX+1,NX+1,MXZ,NXZ
        CALL ABRT1(' DSKNMC',100)
      ENDIF
      RETURN

C-----------------------------------------------------------------------

C
      ENTRY DSKCHR(FKMN,KP1,KP2,MXZ,NXZ)
C
C     OPEN FORMATTED FILE
C
      OPEN(UNIT=MSKDA4,FILE='GRIDDAT',STATUS='NEW',
     1    ACCESS='SEQUENTIAL')
C
C fixit?? "JOBHED" is never assigned a value (set to ZERO)
      jobhed = 0
      WRITE(MSKDA4,111) JOBHED
  111 FORMAT(A80)
      WRITE(MSKDA4,113) KP1,KP2,MXZ,NXZ,YSTM0,XSTM0,XML,XMR,YNB,YNT
  113 FORMAT(1X,4I4,6F10.3)
C
      DO 140 KP=KP1,KP2
      WRITE(MSKDA4,115) KP,IDSPK(KP)
  115 FORMAT(1X,I5,A40)
      WRITE(MSKDA4,117) ((FKMN(KP,M,N),M=1,MXZ),N=1,NXZ)
  117 FORMAT(3X,7E11.3)
      WRITE(6,11)  KP,IDVAR(KP),IDLEV(KP)
   11 FORMAT('       ... KP=',I4,'   VARIABLE #',I3,'   LEVEL #',I3)
  140 CONTINUE
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE DPREP(F,KV,NF1,NF2)
C
      PARAMETER (LDXDIM=8000)
      PARAMETER (NFFDIM=LDXDIM)
C
      SAVE
C
      DIMENSION F(NF1,NF2),FF(NFFDIM,2)
C
      IF(NF1*NF2 .GT. NFFDIM)  GO TO 900
      SCS=0.0
      SCM=1.0
      GO TO (90,90,90,40,50,60,60,60),KV
      WRITE(6,11) KV
   11 FORMAT(/'***** KV HAS IMPROPER VALUE IN DPREP',I9)
      CALL ABRT1('  DPREP',11)
C
C     GEOPOTENTIAL:  SCALE ONLY IF MAXIMUM HEIGHTS EXCEED 10000 METERS
C
CIBM30 ZMAX=-1.E10
C
CIBM  DO 35 N2=1,NF2
CIBM  DO 35 N1=1,NF1
CIBM  IF(F(N1,N2) .EQ. -99.0)  GO TO 35
CIBM  ZMAX=MAX(ZMAX,F(N1,N2))
CIBM5 CONTINUE
C
CIBM  IF(ZMAX .GT. 9999.)  SCM=0.1
CIBM  GO TO 90
C
C     SAVE U-COMPONENT OF WIND FOR DIRECTION/SPEED CALCULATION
C
   40 NF=0
C
      DO N2=1,NF2
      DO N1=1,NF1
      NF=NF+1
      FF(NF,1)=F(N1,N2)
      ENDDO
      ENDDO
C
      RETURN
C
C     SAVE V-COMPONENT OF WIND AND DIRECTION/SPEED CALCULATION
C
   50 NF=0
C
      DO N2=1,NF2
      DO N1=1,NF1
      NF=NF+1
      FF(NF,2)=F(N1,N2)
      ENDDO
      ENDDO
C
      RETURN
C
C     SAVE OTHER DATA
C
   60 NF=0
C
      DO N2=1,NF2
      DO N1=1,NF1
      NF=NF+1
      CALL WDWSP(FF(NF,1),FF(NF,2))
      F(N1,N2)=FF(NF,2)
      ENDDO
      ENDDO
C
      RETURN
C
C     SAVE OTHER DATA
C
   90 DO N2=1,NF2
      DO N1=1,NF1
      IF(F(N1,N2) .EQ. -99.0)  GO TO 95
      F(N1,N2)=(F(N1,N2)-SCS)*SCM
   95 CONTINUE
      ENDDO
      ENDDO
C
      RETURN
  900 WRITE(6,901)  NF1,NF2,NF1*NF2,NFFDIM
  901 FORMAT(/'****** NF1,NF2,NF1*NF2=',3I6,' ARE GREATER THAN',
     1       ' NFFDIM=LDXD=',I6,' IN DPREP')
      CALL ABRT1('  DPREP',901)
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE PRFSUB(F,KFDIM,MFDIM,NFDIM,KF,MF1,MF2,NF1,NF2,KVID,
     1                  KSCALP,KFMT)
C
C
      PARAMETER (MDIM=35,NDIM=35)
C
C     ** PRINT F(KF,MF,NF) FOR SINGLE KF, MF=MF1,MF2 AND NF=NF1,NF2
C        EACH VALUE OF F IS ENCODED AS  F5.1, AND PRINTED AS A5
C        UP TO 24 VALUES OF F ARE ALLOWED IN THE FULL WIDTH OF A PAGE
C
      COMMON /S2NODE/ MXX,NXX,DXM,DYN,XM(MDIM),YN(NDIM),XMC(MDIM),
     1                 YNC(NDIM),COSYN(NDIM)
      SAVE
      DIMENSION F(KFDIM,MFDIM,NFDIM)
C
      CHARACTER IFMTA4*16,LF*121
      CHARACTER*1 IFM1,IFM2*3,IFM3*11,IFM4,KSCALP*3,KFMT*11
      DATA IFM1/'('/,IFM2/'   '/,IFM3/'       F5.0'/,IFM4/')'/

C-----------------------------------------------------------------------

C
      ENTRY PRF24A(F,KFDIM,MFDIM,NFDIM,KF,MF1,MF2,NF1,NF2,KVID)
C
C     PUT DATA INTO A ONE-DIMENSIONAL ARRAY FOR SIMPLICITY (PARALLEL TO
C     PRDFLD
C
      MFA=MF1
      MFB=MF2
      LX=MIN(MFB-MFA+1,24)
      NFB=NF2
      NFA=NF1
C
C     WRITE LONGITUDE ACROSS
C
      WRITE(6,710) (XMC(M),M=MFA,MFB)
C
C     WRITE NODAL POINT NUMBER ACROSS
C
      WRITE(6,810) (M,M=MFA,MFB)
      WRITE(6,811)
C
      DO 16 N=NFB,NFA,-1
        IF(KVID .EQ. 6)  THEN
          DO 14 L=1,LX
            IWD=IFIX(F(KF,L+MFA-1,N))
            ISP=NINT((F(KF,L+MFA-1,N)-REAL(IWD))*100.)
            WRITE(LF(5*(L-1)+1:5*L+1),IFMTA4)  IWD,ISP
   14     CONTINUE
        ELSE
          DO 12 L=1,LX
            WRITE(LF(5*(L-1)+1:5*L+1),IFMTA4) F(KF,L+MFA-1,N)
   12     CONTINUE
        ENDIF
        WRITE(6,814) YNC(N),N,LF(1:5*LX)
   16 CONTINUE
C
C     WRITE LONGITUDE AGAIN
C
      WRITE(6,850) (M,M=MFA,MFB)
C
C     WRITE NODAL POINT NUMBER AGAIN
C
      WRITE(6,910)  (XMC(M),M=MFA,MFB)
      RETURN
  710 FORMAT(6X,'LONG.=',12F8.2/12X,12F8.2)
  810 FORMAT(10X,'M=',I4,23I5)
  811 FORMAT('  LAT.  N')
  814 FORMAT(/F6.2,1X,I3,2X,A)
  850 FORMAT(/10X,'M=',I4,23I5)
  910 FORMAT(6X,'LONG.=',12F8.2/12X,12F8.2)

C-----------------------------------------------------------------------

C
C     ** SET PRINT SCALE AND THE FORMAT
C
      ENTRY STFMTA(KSCALP,KFMT)
      WRITE(IFM2,823) KSCALP
  823 FORMAT(A3)
      WRITE(IFM3,829)  KFMT
  829 FORMAT(A11)
      IFMTA4 = IFM1//IFM2//IFM3//IFM4
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE PRFMSC(KSCALE,KFMT,NV,SCLF)

C
C
      PARAMETER (KVDIM=20)
C**SGIPARAMETER (KVDIM= 7)
      DIMENSION IFMV(KVDIM),ISCLV(KVDIM)
C
      CHARACTER*11 KFMT,IFMV
      CHARACTER*3 KSCALE,ISCLV,SCLF*2
C
      SAVE
C
      DATA IFMV /2*'       F5.1','       F6.0',
C*SGI1           2*'       F5.1','I2.2,'/',I2',
C*SGI2             '       F5.1'/
     1           2*'       F5.1',"I2.2,'/',I2",
     2          14*'       F5.1'/
      DATA ISCLV/KVDIM*' 0P'/
C
      NVPS=NV
C
C     DEFAULT FORMAT FOR ALL EXTERNAL VARIABLES (NV=21 OR NV>=70)
C        IS F5.1
C
      IF(NVPS .EQ. 21 .OR. NVPS .GE. 70)  NVPS=1
      IF(NVPS .LE. KVDIM)  GO TO 10
C
C     SORRY:  A KLUGE TO MAKE SECOND DERIVATIVES THE SAME PRINT FORMAT
C             AS THE FIRST DERIVATIVE (GRADIENT) QUANTITIES^
C     FOR KVDIM=20:
C             NV      NVP     NVPS
C            1-20    UNDEF.   1-19
C            21-29     7        7
C            31-39     9        9
C            41-49    11       11
C            51-59    13       13
C            61-69    15       14
C
      NVP=2*INT(REAL(NV)*0.1-1.0)+5
      NVPS=NVP
      IF(NVP .EQ. 15)  NVPS=14
   10 KFMT=IFMV(NVPS)
      KSCALE=ISCLV(NVPS)
      IF(SCLF .NE. ' 0') KSCALE(1:2)=SCLF
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE PRFKMD(A,FKMN,KP1,KP2)
C
      PARAMETER (MDIM=35,NDIM=35)
      PARAMETER (KLDIM= 8)
      PARAMETER (KVDIM=20,KDTDIM=5)
C**SGIPARAMETER (KVDIM= 7,KDTDIM=5)
      PARAMETER (KPXDIM=KVDIM*KLDIM)
      PARAMETER (KDXDIM=KDTDIM*KLDIM)
C
C     ** ** EXTERNALS MUST BE DECLARED ** **
C
      EXTERNAL XBF,YBF,DXBF,DYBF,DDXBF,DDYBF
C
      COMMON /S2NODE/ MXX,NXX,DXM,DYN,XM(MDIM),YN(NDIM),XMC(MDIM),
     1                 YNC(NDIM),COSYN(NDIM)
      COMMON /S2KOMP/ IDSPK(KPXDIM),IDVAR(KPXDIM),IDLEV(KPXDIM),KPX,
     1                 DMEAN(KDTDIM*KLDIM)
C
      SAVE
C
      DIMENSION A(KDXDIM,MDIM,NDIM),FKMN(KPXDIM,MDIM,NDIM)
      CHARACTER*40 IDSPK,KFMT*11,KSCALE*3,SCLF*2
      DATA NNPAGE/51/,NMPAGE/24/,SCLF/' 0'/,KSCALE/'   '/
C
      CALL SLINTA(A,1,MXX,1,1,NXX,1)
      CALL SLINTD(XBF,YBF)
C
      DO 21 KP=KP1,KP2
      CALL SLINTO(A,KP,FKMN,KPXDIM,MDIM,NDIM,KP)
C
C     ADD IN MEAN VALUES
C
      DO M=1,MXX
      DO N=1,NXX
      FKMN(KP,M,N)=FKMN(KP,M,N)+DMEAN(KP)
      ENDDO
      ENDDO
   21 CONTINUE

C-----------------------------------------------------------------------

C
      ENTRY PRFKMV(FKMN,KP1,KP2)
C
C     WRITE GRIDDED DATA VALUES
C
      NODMAX=(NNPAGE-1)/2+1
      NPGMAX=(NXX-1)/NODMAX+1
      MPGMAX=(MXX-1)/NMPAGE+1
      DO 25 KP=KP1,KP2
      NARG1=NXX
        DO 23 NPG=1,NPGMAX
        NARG2=MAX(NARG1+1-NODMAX,1)
          DO 22 MPG=1,MPGMAX
            CALL PRTITL(1)
            CALL PRDSPC
            print *, ' '
            print *, ' '
            CALL PRDSPK(KP)
            CALL SETSCL(FKMN,KP,SCLF)
            CALL DVLAB(KP,4,SCLF)
            CALL PRFMSC(KSCALE,KFMT,IDVAR(KP),SCLF)
            CALL STFMTA(KSCALE,KFMT)
            MARG1=(MPG-1)*NMPAGE+1
            MARG2=MIN(NMPAGE*MPG,MXX)
            CALL PRF24A(FKMN,KPXDIM,MDIM,NDIM,KP,MARG1,MARG2,NARG2,
     1                   NARG1,IDVAR(KP))
   22   CONTINUE
      NARG1=NARG2-1
   23 CONTINUE
   25 CONTINUE
C
      RETURN

C-----------------------------------------------------------------------
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE MEANV(KF,FD)
C
      PARAMETER (LDXDIM=8000)
      PARAMETER (KLDIM= 8)
      PARAMETER (KVDIM=20,KDTDIM=5)
C**SGIPARAMETER (KVDIM= 7,KDTDIM=5)
      PARAMETER (KPXDIM=KVDIM*KLDIM)
      PARAMETER (KDXDIM=KDTDIM*KLDIM)
C
      COMMON/S2DTPT/IDSPD1,IDSPD2,LDX,XD(LDXDIM),YD(LDXDIM),WD(LDXDIM),
     1               ID(LDXDIM),LXSORT(LDXDIM)
      COMMON /S2KOMP/ IDSPK(KPXDIM),IDVAR(KPXDIM),IDLEV(KPXDIM),KPX,
     1                 DMEAN(KDTDIM*KLDIM)
C
      CHARACTER IDSPD1*8,IDSPD2*72,IDSPK*40
C
      SAVE
C
      DIMENSION FD(KDXDIM,LDXDIM)
C
C     CALCULATE THE MEAN
C
      DMEAN(KF)=0.0
C
      DO LD=1,LDX
      DMEAN(KF)=DMEAN(KF)+FD(KF,LD)
      ENDDO
C
      DMEAN(KF)=DMEAN(KF)/REAL(LDX)
C
C     CALCULATE THE DEVIATION FROM THE MEAN
C
      DO LD=1,LDX
      FD(KF,LD)=FD(KF,LD)-DMEAN(KF)
      ENDDO
C
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE OUTSUB(MSKDAZ,OUTFIL,NV,KL,FDZ,XSPOT,YSPOT,NLEVEL,
     1                  SKWVAL)
C
      PARAMETER (LDXDIM=8000)
      PARAMETER (NFXDIM=20)
C
CIBM  COMMON /S2PRIC/ IDSPC,ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,
CIBM 1                 YNB,YNT,XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4)
      COMMON /S2PRIC/ ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,YNB,YNT,
     1                 XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4),IDSPC
      COMMON/S2DTPT/IDSPD1,IDSPD2,LDX,XD(LDXDIM),YD(LDXDIM),WD(LDXDIM),
     1               ID(LDXDIM),LXSORT(LDXDIM)
      COMMON/XYT/IDAYOB(LDXDIM),UTCOB(LDXDIM),XSTM(NFXDIM),YSTM(NFXDIM),
     1           WSTM(NFXDIM),IDAYST(NFXDIM),UTCSTM(NFXDIM),ELORG,GLORG,
     2           XSTM0,YSTM0,JDAY0,UTC0,NFIX0,IDAYMN
C
      DIMENSION WDZ(LDXDIM),FDZ(LDXDIM),SKWVAL(5,19)
C
      CHARACTER IDSPC*125,IDSPD1*8,IDSPD2*72
      CHARACTER ZTIME*8,ZDATE*11,OUTFIL*(*)
C
      SAVE
C

C-----------------------------------------------------------------------

      ENTRY OUTDV1(MSKDAZ,OUTFIL)
      MSKZ=MSKDAZ
C
C     OPEN THE FILE, GET THE CORRECT TIME AND DATE, AND WRITE THE HEADER
C     TO THE FILE
C
      OPEN(UNIT=MSKZ,FILE=OUTFIL,STATUS='NEW',ACCESS='SEQUENTIAL',
     1     FORM='UNFORMATTED')
      CALL SPDATE(ZDATE)
      CALL SPTIME(ZTIME)
C** DEBUG
C     WE CURRENTLY WRITE THE NEGATIVE OF ALL LONGITUDES UNTIL
C       THE "NCEP" PART OF THE PLOTTING PACKAGE ACCEPTS THE FACT
C       THAT POSITIVE LONGITUDES ARE IN THE EASTERN HEMISPHERE AND
C       LONGITUDE INCREASES EASTWARD.
C
      WRITE(MSKZ) IDSPC,MX,NX,KDCTYP,KBCTYP,ISRCD,-XML,-XMR,YNB,
     1            YNT,-ELORG,GLORG,JPD,XYDCWL,XYBCWL,XD,YD,LDX,
     2            ZDATE,ZTIME
C
C     CHOOSE THE CORRECT OUTPUT STATEMENT AND WRITE
C
      IF(OUTFIL.EQ.'SKWT')     WRITE(6,100)MSKZ,OUTFIL
      IF(OUTFIL .NE. 'SKWT')  WRITE(6,1)  MSKZ,OUTFIL
C
C     FOR COMPATIBILITY WITH PREVIOUS FILES OF THIS TYPE, CREATE WDZ FRO
C       THE ID ARRAY.
C
      WDZ(1:LDX)=REAL(ID(1:LDX))
C
c && 4 comments
CC    WRITE(6,13)  IDSPC,MX,NX,KDCTYP,KBCTYP,ISRCD,XML,XMXX,YNB,YNXX,
CC   1             YNT,JPD,XYDCWL,XYBCWL,(XD(LD),YD(LD),LD=1,LDX),
CC   2             ZDATE,ZTIME
CC 13 FORMAT(/A125/8I10/5F10.2,I10/6F10.2/41(2F10.2/),A11,A9)
C
    1 FORMAT(/'....(DATA-SPLINE) DEVIATIONS WILL BE WRITTEN TO UNIT',I4,
     1       ' AND NAME=',A10)
  100 FORMAT(/'....DATA FOR SKW-T DIAGRAMS WILL BE WRITTEN TO UNIT'
     1      ,I4,' AND NAME=',A4)

      RETURN
C

C-----------------------------------------------------------------------

      ENTRY OUTDV2(NV,KL,FDZ)
C
      WRITE(MSKZ) NV,KL,XD,YD,WDZ,FDZ
      WRITE(6,111)  NV,KL
  111 FORMAT('       ... VARIABLE #',I3,'   LEVEL #',I3,' WRITTEN TO ',
     1       'DISK')
C
c && 2 comments
CC    WRITE(6,112) NV,KL,(WDZ(LD),XD(LD),YD(LD),FDZ(LD),LD=1,LDX)
CC112 FORMAT(/'  ...NV,KL=',2I5/' ...WDZ,XD,YD,FDZ='/(F4.0,2F6.1,F10.3))
C
      RETURN

C-----------------------------------------------------------------------

C
      ENTRY OUTDV3(XSPOT,YSPOT,NLEVEL,SKWVAL)
C
C     WRITE P, T, RH, WSPD, WDIR TO FILE 24 FOR SKW-T LOG-P PLOT
C
      WRITE(MSKZ)NLEVEL,YSPOT,XSPOT,JDAY0,UTC0
      WRITE(2,*)NLEVEL,YSPOT,XSPOT,JDAY0,UTC0
      DO 113 I=1,19
        IDTTST=0
        DO 114 II=2,5
          IF(SKWVAL(II,I).NE.-99.)THEN
            IDTTST=1
          ENDIF
  114   CONTINUE
        IF(IDTTST.EQ.1)THEN
          WRITE(MSKZ)(SKWVAL(II,I),II=1,5)
          WRITE(2,*)(SKWVAL(II,I),II=1,5)
        ENDIF
  113 CONTINUE
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      FUNCTION QSATW(TA,P)
C
C     TA IS TEMPERATURE IN DEG KELVIN
C     P IS PRESSURE IN MB
C     QSATW IS SATURATION MIXING RATIO IN G/G
C
      DATA PS/1013.246/,TS/373.16/
      E1=11.344*(1.0-TA/TS)
      E2=-3.49149*(TS/TA-1.0)
      F1=-7.90298*(TS/TA-1.0)
      F2=5.02808*ALOG10(TS/TA)
      F3=-1.3816*(10.0**E1-1.0)*1.E-7
      F4=8.1328*(10.0**E2-1.0)*1.E-3
      F5=ALOG10(PS)
      F=F1+F2+F3+F4+F5
      ES=10.0**F
      QSATW=.62197*ES/(P-ES)
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      FUNCTION QSATI(TA,P)
C
C     TA IS TEMPERATURE IN DEG KELVIN
C     P IS PRESSURE IN MB
C     QSATI IS SATURATION MIXING RATIO WITH RESPECT TO ICE IN G/G
C
      DATA P0/6.1071/,T0/273.16/
      F1=-9.09718*(T0/TA-1.0)
      F2=-3.56654*ALOG10(T0/TA)
      F3=0.876793*(1.0-TA/T0)
      F4=ALOG10(P0)
      ES=10.0**(F1+F2+F3+F4)
      QSATI=.62197*ES/(P-ES)
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      FUNCTION PCKPRW(UV,PRX,WX)
      DOUBLE PRECISION PCKPRW
      PCKPRW=DBLE(IFIX(SIGN(PRX,UV))+
     1        NINT(UV*10.)*1000)+
     2        DSIGN(DBLE(WX),DBLE(UV))/100.
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE UPKPRW(PCKX,UVX,PRX,WX)
      DOUBLE PRECISION PCKX
      IPCKX=INT(PCKX)
      PCKX3=PCKX*0.001
      WX=REAL(NINT(DABS(PCKX-DBLE(IPCKX))*100.))
      PRX=REAL(INT(DABS(PCKX3-DBLE(INT(PCKX3)))*1000.))
      IF(NINT(PRX*10.) .LT. 1000)  PRX=PRX+1000.
      UVX=SIGN(REAL(INT(PCKX3)),PCKX3)*0.1
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE OUTSTK(KD,LDXX,FDD,KLSTIK,LDWX)
C
      PARAMETER (KLDIM= 8)
      PARAMETER (KDTDIM=5)
C**SGIPARAMETER (KDTDIM=5)
C
      COMMON /DSK/MSKEF,MSKEZ,MSKDA1,MSKDA2,MSKDA3,MSKDA4,MSKDA5,MSKDA6,
     1            MSKDA7,MSKDA8,MSKDA9,MSKD11,MSKD12,MSKD13,
     2            MSKD14,MSKD15,MSKD16,MSKD17,MSKD18
      COMMON /PRES/ PLEV(KLDIM),RHANL,DATREC(KDTDIM+1),ICOOR,IDAT,IDATZ
C
      LOGICAL RHANL
      DOUBLE PRECISION PCKPRW
C
      SAVE
C
      DIMENSION FDD(LDXX)
C
C     ******  WARNING: SINGLE PRECISION VALUES ARE WRITTEN TO
C                      DISK.  THIS IS ADEQUATE ONLY FOR SINGLE
C                      DIGIT VALUES OF WX.
C
      WX=6.
      PRX=PLEV(KLSTIK)
C
      DO LD=1,LDXX
      FDD(LD)=PCKPRW(FDD(LD),PRX,WX)
      ENDDO
C
      WRITE(MSKDA9) KLSTIK,KD,LDXX,FDD,LDWX
C
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE OPNFIL(MSKDA9)
      OPEN(UNIT=MSKDA9,FILE='STKDATO',ACCESS='SEQUENTIAL',
     1     STATUS='UNKNOWN',FORM='UNFORMATTED')
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE ENDFIL(MSKDA9)
      OPEN(UNIT=MSKDA9,FILE='STKDATO',ACCESS='SEQUENTIAL',
     1     STATUS='UNKNOWN',FORM='UNFORMATTED',ERR=990)
    1 READ(MSKDA9,END=100,ERR=900)
      GO TO 1
  100 RETURN
  900 WRITE(6,901)  MSKDA9
  901 FORMAT('******  ERROR READING UNIT',I4,' IN ENDFIL')
      CALL ABRT1(' ENDFIL',901)
  990 WRITE(6,991) MSKDA9
  991 FORMAT(/'****** ERROR SKIPPING TO END OF FILE',I4,'.  OPENING',
     1       ' A NEW FILE')
      CALL OPNFIL(MSKDA9)
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE SPTDER(X,Y,A,K1,K2,F)
C
      PARAMETER (MDIM=35,NDIM=35)
      PARAMETER (KLDIM= 8)
      PARAMETER (KDTDIM=5)
      PARAMETER (KDXDIM=KDTDIM*KLDIM)
C
      SAVE
C
C     ** ** SPOT INVERSE TRANSFORMATION OF SPLINE AMPLITUDES TO
C               DERIVATIVES OF F AT X,Y
C       X,Y        THE SPOT COORDINATES AT WHICH OUTPUT F IS DESIRED
C       A(K,M,N)   KTH COMPONET OF NODAL AMPLITUDE AT M,N
C       K1,K2      THE  RANGE OF COMPONENTS K OF THE AMPLITUDE (NOT OF O
C       F(KF)      THE SPOT OUTPUT F.  KF=1 FOR K=K1
C                                      KF=2 FOR K=K1+1,  TILL
C                                      KF=K2-K1+1 FOR K=K2
C     THERE ARE SEPARATE ENTRY POINTS FOR EACH DERIVATIVE.
C SPOTDX: FIRST X DERIVATIVE
C SPOTDY: FIRST Y DERIVATIVE
C SPDDXX: SECOND X DERIVATIVE
C SPDDYY: SECOND Y DERIVATIVE
C SPDDXY: SECOND CROSS DERIVATIVE
C     ** DUMMY ARGUMENTS
C
      DIMENSION A(KDXDIM,MDIM,NDIM)
cc dak 07/03/05      DIMENSION F(1)
      dimension f(*) ! dak 7/3/05: fix bounds-check error
      COMMON /S2NODE/ MXX,NXX,DXM,DYN,XM(MDIM),YN(NDIM),XMC(MDIM),
     1                 YNC(NDIM),COSYN(NDIM)
      EQUIVALENCE (XM(1),X1),(YN(1),Y1)
C
C     ** LOCAL WORK SPACE
C
      DIMENSION BM(4),BN(4),ZN(4)
C

C-----------------------------------------------------------------------

      ENTRY SPOTDX(X,Y,A,K1,K2,F)
      M0=MAX(INT((X-X1)/DXM),1)-1
      N0=MAX(INT((Y-Y1)/DYN),1)-1
      M4=MIN(MXX-M0,4)
      N4=MIN(NXX-N0,4)
C
C     FIRST X DERIVATIVE
C
      DO M=1,M4
      BM(M)=DXBF(M+M0,X)
      ENDDO
C
      DO N=1,N4
C
      BN(N)=YBF(N+N0,Y)
      ENDDO
      GO TO 30
C

C-----------------------------------------------------------------------

      ENTRY SPOTDY(X,Y,A,K1,K2,F)
      M0=MAX(INT((X-X1)/DXM),1)-1
      N0=MAX(INT((Y-Y1)/DYN),1)-1
      M4=MIN(MXX-M0,4)
      N4=MIN(NXX-N0,4)
C
C     FIRST Y DERIVATIVE
C
      DO M=1,M4
      BM(M)=XBF(M+M0,X)
      ENDDO
C
      DO N=1,N4
      BN(N)=DYBF(N+N0,Y)
      ENDDO
C
      GO TO 30
C

C-----------------------------------------------------------------------

      ENTRY SPDDXX(X,Y,A,K1,K2,F)
      M0=MAX(INT((X-X1)/DXM),1)-1
      N0=MAX(INT((Y-Y1)/DYN),1)-1
      M4=MIN(MXX-M0,4)
      N4=MIN(NXX-N0,4)
C
C     SECOND X DERIVATIVE
C
      DO M=1,M4
         BM(M)=DDXBF(M+M0,X)
      ENDDO
C
      DO N=1,N4
         BN(N)=YBF(N+N0,Y)
      ENDDO
C
      GO TO 30
C

C-----------------------------------------------------------------------

      ENTRY SPDDYY(X,Y,A,K1,K2,F)
      M0=MAX(INT((X-X1)/DXM),1)-1
      N0=MAX(INT((Y-Y1)/DYN),1)-1
      M4=MIN(MXX-M0,4)
      N4=MIN(NXX-N0,4)
C
C     SECOND Y DERIVATIVE
C
      DO M=1,M4
      BM(M)=XBF(M+M0,X)
      ENDDO
C
      DO N=1,N4
      BN(N)=DDYBF(N+N0,Y)
      ENDDO
C
      GO TO 30
C

C-----------------------------------------------------------------------

      ENTRY SPDDXY(X,Y,A,K1,K2,F)
      M0=MAX(INT((X-X1)/DXM),1)-1
      N0=MAX(INT((Y-Y1)/DYN),1)-1
      M4=MIN(MXX-M0,4)
      N4=MIN(NXX-N0,4)
C
C     SECOND CROSS DERIVATIVE
C
      DO M=1,M4
      BM(M)=DXBF(M+M0,X)
      ENDDO
C
      DO N=1,N4
      BN(N)=DYBF(N+N0,Y)
      ENDDO
C
   30 KF=0
C
      DO K=K1,K2
         KF=KF+1
         DO N=1,4
            ZN(N)=0.
         ENDDO
         DO M=1,M4
            DO N=1,N4
               ZN(N)=ZN(N)+BM(M)*A(K,M+M0,N+N0)*BN(N)
            ENDDO
         ENDDO
         F(KF)=ZN(1)+ZN(2)+ZN(3)+ZN(4)
      ENDDO
C
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE OUTREC(PR,DATA)
C
      PARAMETER (KLDIM= 8)
      PARAMETER (KDTDIM=5)
C**SGIPARAMETER (KDTDIM=5)
C
      COMMON /PRES/ PLEV(KLDIM),RHANL,DATREC(KDTDIM+1),ICOOR,IDAT,IDATZ
C
      SAVE
C
      DIMENSION DATA(KDTDIM),DATAX(KDTDIM)
      EQUIVALENCE (PRX,DATREC(1)),(DATREC(2),DATAX(1))
C
C     THIS SUBROUTINE RESHUFFLES AN OUTPUT DATA RECORD THAT MAY HAVE BEE
C       REARRANGED DUE TO ANALYSIS ON OTHER THAN P-COORDINATES
C
      PRX=PR
C
      DATAX=DATA
C
      DATAZ=DATA(IDATZ)
      DATREC(ICOOR)=PR
      DATREC(IDAT)=DATAZ
      PR=PRX
C
      DATA=DATAX
C
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE SETSCL(FKMN,KP,SCLF)
C
      PARAMETER (MDIM=35,NDIM=35)
      PARAMETER (KLDIM= 8)
      PARAMETER (KVDIM=20,KDTDIM=5)
C**SGIPARAMETER (KVDIM= 7,KDTDIM=5)
      PARAMETER (KPXDIM=KVDIM*KLDIM)
C
      COMMON /S2NODE/ MXX,NXX,DXM,DYN,XM(MDIM),YN(NDIM),XMC(MDIM),
     1                 YNC(NDIM),COSYN(NDIM)
      COMMON /S2KOMP/ IDSPK(KPXDIM),IDVAR(KPXDIM),IDLEV(KPXDIM),KPX,
     1                 DMEAN(KDTDIM*KLDIM)
C
      SAVE
C
      DIMENSION FKMN(KPXDIM,MDIM,NDIM),RMNMX(2,3)
C
      CHARACTER IDSPK*40,SCLF*2
C
      DATA SCALE/10.0/,RMNMX/-99.5,999.94,-999.,9999.,-1.0,1.0/
C
C     THIS SUBROUTINE SETS A SCALING FACTOR SO THAT NUMBERS ARE GREATER
C       THAN -99.5 AND LESS THAN 999.94, OR -999 OR 9999 FOR GEOPOTENTIA
C       NUMBERS THAT HAVE ABSOLUTE VALUE LESS THAN 1 ARE SCALED TO BE GR
C       THAN 1.0 OR LESS THEN -1.0.
C     THIS VERSION IS FOR A THREE-DIMENSIONAL INPUT ARRAY.
C
      NSCLF=0
      KKSET=1
      IF(IDVAR(KP) .EQ. 3) KKSET=2
      FMAX=-1.E10
      FMIN= 1.E10
C
      DO N=1,NXX
      DO M=1,MXX
      FMIN=MIN(FMIN,FKMN(KP,M,N))
      FMAX=MAX(FMAX,FKMN(KP,M,N))
      ENDDO
      ENDDO
      IF(FMIN .EQ. 0.0 .AND. FMAX .EQ. 0.0)  GO TO 100
C
   15 IF(FMIN .GT. RMNMX(1,KKSET))  GO TO 20
      NSCLF=NSCLF+1
      FMIN=FMIN/SCALE
      GO TO 15
C
   20 FMAX=FMAX/SCALE**NSCLF
   25 IF(FMAX .LT. RMNMX(2,KKSET))  GO TO 40
      NSCLF=NSCLF+1
      FMAX=FMAX/SCALE
      GO TO 25
C
   40 IF(ABS(FMAX) .GT. RMNMX(2,3) .OR. ABS(FMIN) .GT. RMNMX(2,3))
     1      GO TO 100
      NSCLF=NSCLF-1
      FMIN=FMIN*SCALE
      FMAX=FMAX*SCALE
      GO TO 40
C
  100 WRITE(SCLF,'(I2)') -NSCLF
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE HEDCHK(MSKDAZ)
      PARAMETER (LDXDIM=8000)
      PARAMETER (NFXDIM=20)
      COMMON/XYT/IDAYOB(LDXDIM),UTCOB(LDXDIM),XSTM(NFXDIM),YSTM(NFXDIM),
     1            WSTM(NFXDIM),IDAYST(NFXDIM),UTCSTM(NFXDIM),
     2            ELORG,GLORG,XSTM0,YSTM0,JDAY0,UTC0,NFIX0,IDAYMN
CIBM  COMMON /S2PRIC/ IDSPC,ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,
CIBM 1                 YNB,YNT,XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4)
      COMMON /S2PRIC/ ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,YNB,YNT,
     1                 XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4),IDSPC
      DIMENSION KBCTYZ(4),XYDCWZ(2),XYBCWZ(4)
      CHARACTER IDSPC*125,IDSPCZ*125
C
      SAVE

C     THIS SUBROUTINE CHECKS THE STANDARD HEAD RECORD AND COMPARES IT
C       WITH CURRENT VALUES IN COMMON /S2PRIC/.   MISMATCH CAUSES
C       PROGRAM TO CROAK GRACEFULLY.  MODIFICATION FOR OLD VERSUS
C       NEW STYLE HEAD RECORDS 10/17/88.
C
      READ(MSKDAZ,ERR=100) IDSPCZ,MXZ,NXZ,KDCTYZ,KBCTYZ,ISRCDZ,
     1                     XMLZ,XMRZ,YNBZ,YNTZ,ELORGZ,GLORGZ,
     2                     JPDZ,XYDCWZ,XYBCWZ
      XMLZ=-XMLZ
      XMRZ=-XMRZ
      ELORGZ=-ELORGZ
      IF(ISRCDZ .NE. ISRCD .OR. XMLZ .NE. XML .OR. XMRZ .NE. XMR .OR.
     1   YNBZ .NE. YNB .OR. YNTZ .NE. YNT .OR. ELORG .NE. ELORGZ .OR.
     2   GLORGZ .NE. GLORG)  GO TO 10
      RETURN
C
   10 WRITE(6,11) ISRCDZ,XMLZ,XMRZ,YNBZ,YNTZ,ELORGZ,GLORGZ,
     1            ISRCD ,XML ,XMRZ,YNB ,YNT ,ELORG ,GLORG
   11 FORMAT(/'*****HEAD RECORDS (NEW STYLE) DO NOT MATCH.',
     1       '  PROBABLE MISMATCH OF GEOMETRY',/,
     2       ' ...ISRCDZ,XMLZ,XMRZ,YNBZ,YNTZ,ELORGZ,GLORGZ=',
     3       I3,6F10.3,/,' ...ISRCD,XML,XMR,YNB,YNT,ELORG,GLORG=',
     4       I3,6F10.3)
      CALL ABRT1(' HEDCHK',11)
C
C     FOR OLD STYLE HEAD RECORDS THAT DO NOT CONTAIN ELORG,GLORG
C
  100 REWIND MSKDAZ
      READ(MSKDAZ) IDSPCZ,MXZ,NXZ,KDCTYZ,KBCTYZ,ISRCDZ,XMLZ,XMXXZ,
     1             YNBZ,YNXXZ,YNTZ
      XMLZ=-XMLZ
      IF(ISRCDZ .NE. ISRCD .OR. XMLZ .NE. XML .OR. XMXXZ .NE. XMXX .OR.
     1   YNBZ .NE. YNB .OR. YNXXZ .NE. YNXX .OR.
     2   YNTZ .NE. YNT)  GO TO 110
      RETURN
C
  110 WRITE(6,111) ISRCDZ,XMLZ,XMXXZ,YNBZ,YNXXZ,YNTZ,
     1             ISRCD ,XML ,XMXX ,YNB ,YNXX ,YNT
  111 FORMAT(/'*****HEAD RECORDS (OLD STYLE) DO NOT MATCH.',
     1       ' PROBABLE MISMATCH OF GEOMETRY',/,
     2       ' ...ISRCDZ,XMLZ,XMXXZ,YNBZ,YNXXZ,YNTZ=',
     2       I3,5F10.3,/,' ...ISRCD,XML,XMXX,YNB,YNXX,YNT=',
     2       I3,5F10.3)
      CALL ABRT1(' HEDCHK',111)

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE CSGNLN(NFIX)
C
      PARAMETER (LDXDIM=8000)
      PARAMETER (NFXDIM=20)
C
      COMMON/S2DTPT/IDSPD1,IDSPD2,LDX,XD(LDXDIM),YD(LDXDIM),WD(LDXDIM),
     1               ID(LDXDIM),LXSORT(LDXDIM)
      COMMON/XYT/IDAYOB(LDXDIM),UTCOB(LDXDIM),XSTM(NFXDIM),YSTM(NFXDIM),
     1            WSTM(NFXDIM),IDAYST(NFXDIM),UTCSTM(NFXDIM),
     2            ELORG,GLORG,XSTM0,YSTM0,JDAY0,UTC0,NFIX0,IDAYMN
C
      CHARACTER*8 IDSPD1,IDSPD2*72
C
C     TRANSFORMATION FOR DATA POINTS
C
      DO 10 LD=1,LDX
      XD(LD)=-XD(LD)
   10 CONTINUE
C
C     TRANSFORMATION FOR STORM FIXES
C
      DO 20 N=1,NFIX
      XSTM(N)=-XSTM(N)
   20 CONTINUE
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE SIMCON(SECVAR,MAXFND,XCTR,YCTR,RAD,A,KDX1,KDX2,VALMN,
     1                  IOPT,MWAVES)
C
      PARAMETER (MDIM=35,NDIM=35)
      PARAMETER (KLDIM= 8)
      PARAMETER (KDTDIM=5)
      PARAMETER (KDXDIM=KDTDIM*KLDIM)
C
      SAVE
C
      DIMENSION A(KDXDIM,MDIM,NDIM)
      COMPLEX(8) VERT(3),RVERT,XVERT,CVERT,SVERT(3)
      REAL LEGAR(3),RLEG,XLEG,CLEG,RCOEF,XCOEF,CCOEF,SCOEF
      LOGICAL DONE,DOIT,MAXFND,SECVAR
      CHARACTER*3 CMXN
      DATA RCOEF,XCOEF,CCOEF,SCOEF/-1.0,-2.0,0.5,0.5/
C
      WRITE(6,11)  MAXFND,IOPT,MWAVES
   11 FORMAT(/'...ENTERING SIMCON WITH MAXFND,IOPT,MWAVES=',L2,2I4)
      CALL SETSIM(SECVAR,MAXFND,XCTR,YCTR,RAD,A,KDX1,KDX2,IOPT,MWAVES,
     1            VERT,LEGAR,DONE,IBST,IWST,KOUNT,CMXN)
CIBM  DO WHILE (.NOT. DONE)
      DO 1000 IZZZ=1,99
      IF(DONE)  GO TO 1100
        KOUNT = KOUNT + 1
        CALL SIZE(VERT,RVERT,RCOEF,IBST,IWST)
        CALL ALSAND(SECVAR,A,KDX1,KDX2,IOPT,MWAVES,RVERT,RLEG)
        IF (DOIT(RLEG,LEGAR(IBST))) THEN
          CALL SIZE(VERT,XVERT,XCOEF,IBST,IWST)
          CALL ALSAND(SECVAR,A,KDX1,KDX2,IOPT,MWAVES,XVERT,XLEG)
        IF (DOIT(XLEG,LEGAR(IBST))) THEN
          CALL STASH(VERT,LEGAR,XVERT,XLEG,IWST)
        ELSE
        CALL STASH(VERT,LEGAR,RVERT,RLEG,IWST)
        ENDIF
        ELSE IF(DOIT(RLEG,LEGAR(2)))THEN
          CALL STASH(VERT,LEGAR,RVERT,RLEG,IWST)
        ELSE
          IF (DOIT(RLEG,LEGAR(IWST))) THEN
       CALL STASH(VERT,LEGAR,RVERT,RLEG,IWST)
       ENDIF
       CALL SIZE(VERT,CVERT,CCOEF,IBST,IWST)
       CALL ALSAND(SECVAR,A,KDX1,KDX2,IOPT,MWAVES,CVERT,CLEG)
       IF(DOIT(CLEG,LEGAR(IWST)))THEN
         CALL STASH(VERT,LEGAR,CVERT,CLEG,IWST)
       ELSE
         CALL SHRINK(VERT,SVERT,SCOEF,IBST,IWST)
         CALL ALSAND(SECVAR,A,KDX1,KDX2,IOPT,MWAVES,SVERT(2),LEGAR(2))
         VERT(2) = SVERT(2)
         CALL ALSAND(SECVAR,A,KDX1,KDX2,IOPT,MWAVES,SVERT(IWST),
     1               LEGAR(IWST))
         VERT(IWST) = SVERT(IWST)
        ENDIF
      ENDIF
      CALL RNKVRT(VERT,LEGAR)
      CALL CONTST(KOUNT,DONE,VERT)
c && 2 comments
CC      WRITE(6,21) KOUNT,LEGAR(IBST),VERT(IBST)
CC21    FORMAT(' ITER:',I4,'; MIN/MAX VALUE: ',F12.5,' AT ', 2F12.7)
        VALMN=LEGAR(IBST)
        XCTR=REAL(VERT(IBST))
        YCTR=AIMAG(VERT(IBST))
 1000 CONTINUE
      WRITE(6,1001)
 1001 FORMAT('**** SIMPLEX DID NOT CONVERGE AFTER 99 ITERATIONS')
CIBM  ENDDO
 1100 CONTINUE
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE SETSIM(SECVAR,MAXFND,XCTR,YCTR,RAD,A,KDX1,KDX2,IOPT,
     1                  MWAVES,VERT,LEGAR,DONE,IBST,IWST,KOUNT,CMXN)
C
      SAVE
C
      PARAMETER (MDIM=35,NDIM=35)
      PARAMETER (KLDIM= 8)
      PARAMETER (KDTDIM=5)
      PARAMETER (KDXDIM=KDTDIM*KLDIM)
      DIMENSION A(KDXDIM,MDIM,NDIM)
C
      COMMON/CRITR/EPS,ITMAX
      COMMON /MAXMIN/PMAX
C
      COMPLEX(8) VERT(3),AI
      CHARACTER*3 CMXN
      REAL LEGAR(3),SQR32,XCTR,YCTR,RAD
      LOGICAL DONE,PMAX,MAXFND,SECVAR
      DATA SQR32/0.866025/
C
      DONE = .FALSE.
      PMAX = .FALSE.
      IF(MAXFND)  PMAX = .TRUE.
      IF (PMAX)THEN
        IBST = 3
        IWST = 1
        CMXN = 'MAX'
      ELSE
        IBST = 1
        IWST = 3
        CMXN = 'MIN'
      ENDIF
      KOUNT = 0
C
C     INITIAL VERTICES ARE AT THE POINTS OF AN EQUILATERAL TRIANGLE
C
      AI=(0,1.0)
      VERT(1) = XCTR+AI*(YCTR+RAD)
      VERT(2) = XCTR+SQR32*RAD+AI*(YCTR-0.5*RAD)
      VERT(3) = XCTR-SQR32*RAD+AI*(YCTR-0.5*RAD)
C
      IF(IOPT .LT. 0)  THEN
      IOPTZ=IABS(IOPT)
      IMFLTP=IOPTZ/10
C
C     WARNING:  HARDWIRED ASSUMPTIONS ABOUT FILE TYPES ARE GIVEN HERE
C               IMFLTP=1: COEFFICIENTS OF U,V WIND
C               IMFLTP=2: COEFFICIENTS OF VORT, DIV.
C
      IF(IMFLTP .EQ. 1)  THEN
      IPLUS=1
      ITRNC=1
      ELSE IF(IMFLTP .EQ. 2)  THEN
      IPLUS=0
      ITRNC=0
      ENDIF
      CALL SETTRN(KDX2,KDX1,MWAVES,IPLUS,ITRNC)
      ENDIF
C
      EPS = 0.045
      ITMAX = 40
      DO 99 I = 1,3
        CALL ALSAND(SECVAR,A,KDX1,KDX2,IOPT,MWAVES,VERT(I),LEGAR(I))
c && 3 comments
CC    WRITE(6,9981) I,KDX1,KDX2,IOPT,MWAVES,VERT(I),LEGAR(I)
C9981 FORMAT('...IN SETSIM, I,KDX1,KDX2,IOPT,MWAVES,VERT,LEGAR=',
CC   1       5I5,/,4X,4F10.3)
CIBM  ENDDO
   99 CONTINUE
      CALL RNKVRT(VERT,LEGAR)
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE RNKVRT(VERT,LEGAR)
      COMPLEX(8) VERT(3),TVERT
      REAL LEGAR(3),TLEG
C
      SAVE
C
      DO 199 I = 1,3
        DO 99 J= 1,2
          IF (LEGAR(J) .GT. LEGAR(J+1)) THEN
            TVERT = VERT(J)
            TLEG = LEGAR(J)
            VERT(J) = VERT(J+1)
            LEGAR(J) = LEGAR(J+1)
            VERT(J+1) = TVERT
            LEGAR(J+1) = TLEG
          ENDIF
CIBMNDDO
CIBM  ENDDO
  99  CONTINUE
 199  CONTINUE
C
c && 4 comments
CC    DO I = 1,3
CC       WRITE(6,10)I,VERT(I),LEGAR(I)
CC    ENDDO
CC10  FORMAT(' RNKVRT: VERTEX# ',I2,' VERT = ',2F10.5,' LEGAR = ',G12.5)
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE STASH(VERT,LEGAR,NVERT,NLEG,IWST)
      COMPLEX(8) VERT(3),NVERT
      REAL LEGAR(3),NLEG
C
      SAVE
C
c && 1 comment
CC    WRITE(6,9)VERT(IWST),LEGAR(IWST)
C
      VERT(IWST) = NVERT
      LEGAR(IWST) = NLEG
C
c && 3 comments
CC    WRITE(6,10)VERT(IWST),LEGAR(IWST)
CC  9 FORMAT(' STASH: OLD VERT(IWST) AND LEGAR(IWST) ',2F10.5,G12.5)
CC 10 FORMAT(' STASH: NEW VERT(IWST) AND LEGAR(IWST) ',2F10.5,G12.5)
C
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE SIZE(VERT,NVERT,COEF,IBST,IWST)
      COMPLEX(8) VERT(3),NVERT,BVERT
C
      SAVE
C
      BVERT = 0.5 * (VERT(IBST) + VERT(2))
      NVERT = BVERT + COEF*(VERT(IWST)-BVERT)
C
c && 2 comments
CC    WRITE(6,10)COEF,VERT(IWST),NVERT
CC 10 FORMAT(' SIZE: COEF =',F10.5,' OLD =',2F10.5,' NEW =',2F10.5)
C
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE SHRINK(VERT,SVERT,SCOEF,IBST,IWST)
      COMPLEX(8) VERT(3),SVERT(3)
C
      SAVE
C
      SVERT(2)=VERT(IBST)+SCOEF*(VERT(2)-VERT(IBST))
C
c && 1 comment
CC    WRITE(6,10)2,VERT(2),SVERT(2)
C
      SVERT(IWST)=VERT(IBST)+SCOEF*(VERT(IWST)-VERT(IBST))
C
c && 2 comments
CC    WRITE(6,10)IWST,VERT(IWST),SVERT(IWST)
CC 10 FORMAT(' SHRINK: VERTEX#',I2,' OLD =',2F10.5,' NEW =',2F10.5)
C
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE ALSAND(SECVAR,A,KDX1,KDX2,IOPT,MWAVES,VERT,LEG)
C
      PARAMETER (MDIM=35,NDIM=35)
      PARAMETER (KLDIM= 8)
      PARAMETER (KVDIM=20,KDTDIM=5)
C**SGIPARAMETER (KVDIM= 7,KDTDIM=5)
      PARAMETER (KDXDIM=KDTDIM*KLDIM)
      PARAMETER (KPXDIM=KVDIM*KLDIM)
C
      SAVE
C
      DIMENSION A(KDXDIM,MDIM,NDIM),SPLV(KPXDIM),AVG(KDXDIM)
      LOGICAL SECVAR,PRTAZI,ANNAVG
      COMPLEX(8) VERT
      REAL LEG,X0,Y0
      DATA PRTAZI/.FALSE./,ANNAVG/.TRUE./
C
      X0 = REAL(VERT)
      Y0 = AIMAG(VERT)
C
C     POSITIVE OPTIONS ARE FOR SPLINE FUNCTIONS.
C     NEGATIVE OPTIONS ARE FOR GLOBAL SPECTRAL MODEL FUNCTIONS
C
C     GO TO (10,20),IOPT
      IF(IOPT .LT. 0)  THEN
      IOPTZ=IABS(IOPT)
      IMFLTP=IOPTZ/10
      IVAR0=IOPTZ-IMFLTP*10
C
C     WARNING:  HARDWIRED ASSUMPTIONS ABOUT FILE TYPES ARE GIVEN HERE
C               IMFLTP=1: COEFFICIENTS OF U,V WIND
C               IMFLTP=2: COEFFICIENTS OF VORT, DIV.
C
      IF(IMFLTP .EQ. 1)  THEN
      IPLUS=1
      ITRNC=1
      ELSE IF(IMFLTP .EQ. 2)  THEN
      IPLUS=0
      ITRNC=0
      ENDIF
C
C
C     SCALARS: T, RH, Z, VORTICITY(6), DIVERGENCE(7)
C
      IF(IVAR0 .LE. 3 .OR. IVAR0 .EQ. 6 .OR. IVAR0 .EQ. 7)  THEN
      IF(IMFLTP .EQ. 1)  THEN
      CALL SCASP1(X0,Y0,KDX1,KDX2,MWAVES,ITRNC,VALOUT)
      ELSE IF(IMFLTP .EQ. 2)  THEN
      CALL SCASP1(X0,Y0,KDX1,KDX2,MWAVES,ITRNC,VALOUT)
c && 3 comments
CC    WRITE(6,1293) IVAR0,KDX1,KDX2,X0,Y0,VALOUT
C1293 FORMAT('...SCASP1 CALLED, IVAR0,KDX1,KDX2,X0,Y0,VALOUT=',
CC   1       3I5,2F10.4,E12.4)
      ENDIF
      LEG=VALOUT
C
C     WIND: CALCULATE WIND SPEED FROM U,V ALL AT ONCE
C
      ELSE IF(IVAR0 .EQ. 4)  THEN
      IF(IMFLTP .EQ. 1)  THEN
c && 3 comments
CC    WRITE(6,508) KDX2,KDX1,MWAVES,IPLUS,ITRNC
CC508 FORMAT('...CALLING SETRES FOR CENTER FINDING: KL,JV,MWAVES,',
CC   1       'IPLUS,ITRNC=',5I5)
      CALL SETRES(KDX2,KDX1,MWAVES,IPLUS,ITRNC)
      CALL UVWSP1(X0,Y0,KDX1  ,KDX2,MWAVES,IPLUS,ITRNC,UWIND)
c && 1 comment
CC    WRITE(6,508) KDX2,KDX1,MWAVES,IPLUS,ITRNC
      CALL SETRES(KDX2,KDX1+1,MWAVES,IPLUS,ITRNC)
      CALL UVWSP1(X0,Y0,KDX1+1,KDX2,MWAVES,IPLUS,ITRNC,VWIND)
C
      ELSE IF(IMFLTP .EQ. 2)  THEN
c && 1 comment
CC    WRITE(6,508) KDX2,KDX1,MWAVES,IPLUS,ITRNC
      CALL SETRES(KDX2,KDX1,MWAVES,IPLUS,ITRNC)
      CALL UVRSP2(X0,Y0,KDX1  ,KDX2,MWAVES,ITRNC,UWIND,VWIND)
c && 1 comment
CC    WRITE(6,508) KDX2,KDX1,MWAVES,IPLUS,ITRNC
      CALL SETRES(KDX2,KDX1+1,MWAVES,IPLUS,ITRNC)
      CALL UVDSP2(X0,Y0,KDX1+1,KDX2,MWAVES,ITRNC,UWIND,VWIND)
      ENDIF
      LEG=SQRT(UWIND**2+VWIND**2)
      ENDIF
C
      ELSE IF(IOPT .EQ. 1)  THEN
      KVZ=KDX1
      KLZ=KDX2
      CALL SPTVAR(SECVAR,X0,Y0,A,KVZ,KLZ,SPLV)
      LEG=SPLV(KVZ)
C
      ELSE IF(IOPT .EQ. 2)  THEN
      IF(KDX2-KDX1 .GT. 1)  GO TO 900
C*CRAYCALL AZIAVG(A,KDX1,KDX2,X0,Y0,AVG,PRTAZI,ANNAVG)
      LEG=AVG(KDX2)
C
      ELSE
c && 2 comments
CC    WRITE(6,1) IOPT
CC  1 FORMAT(/'******IMPROPER OPTION IN ALSAND, IOPT=',I6)
      CALL ABRT1(' ALSAND',1)
      ENDIF
C
c && 5 comments
CC    WRITE(6,98) REAL(VERT),AIMAG(VERT),KDX1,KDX2,X0,Y0,LEG
CC98  FORMAT('...ALSAND, REAL(VERT),AIMAG(VERT),KDX1,KDX2,X0,Y0,LEG=',
CC   1       2F10.3,2I5,3F10.3)
CC    WRITE(6,99)VERT,LEG
CC99  FORMAT(' ALSAND: VERTEX AT ',2F10.5,' LEG = ',G12.5)
      RETURN
900   WRITE(6,901) KDX1,KDX2
901   FORMAT('*****TOO MANY VARIABLES IN SIMCON, KDX1,KDX2=',2I5)
      CALL ABRT1(' ALSAND',901)
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE CONTST(KOUNT,DONE,VERT)
      COMPLEX(8) VERT(3)
      LOGICAL DONE
      COMMON/CRITR/EPS,ITMAX
C
      SAVE
C
      SMAX = 0.0
      DO 99 I = 1,3
        J = I + 1
        IF (J .GT. 3) J = J - 3
cdakxxxxSS = CABS(VERT(I)-VERT(J))
        SS = ABS(VERT(I)-VERT(J))
        SMAX = MAX(SS,SMAX)
C
c && 2 comments
CC      WRITE(6,10)I,J,SS
CC 10 FORMAT(' CONTST: SIDE BETWEEN ',I2,' AND ',I2,' HAS LENGTH',F10.5)
C
CIBM  ENDDO
   99 CONTINUE
      DONE = (SMAX .LT. EPS).OR.(KOUNT.GE.ITMAX)
      IF(KOUNT .GT. ITMAX) WRITE(6,11) ITMAX
11    FORMAT('**** MAX ITERATIONS (',I4,') EXCEEDED IN SIMCON')
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      LOGICAL FUNCTION DOIT(ALN,ALO)
      COMMON /MAXMIN/PMAX
      LOGICAL PMAX
      IF(PMAX) THEN
        DOIT = ALN .GT. ALO
      ELSE
        DOIT = ALN .LT. ALO
      ENDIF
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
C       SLARGO **   06/06/84
C       SLACCO FOR CORNER CONDITIONS.   PASDSS EXPANDED.
C       AMM,AMR,AML ARE ALL SQUARE MATRICES
C       THE OLD VERSION OF SLARGO (09/05/79) BEFORE
C       SWITCHING TO SLACCO VERSION, IS IN PLIB SPLAOLD
C     ++ ASSUMED DIM PARAMETERS ... MDIM=47...NDIM=35,
C
      SUBROUTINE SLARGO
C
C     ** TWO-D VERSION OF THE EARLIER PLIB WALTZ ROUTINES **
C          PERIODIC BC IS NOT ALLOWED AT THIS TIME (03/31/79)
C
      PARAMETER (MDIM=35,NDIM=35)
C
C     ** SECONDARY PARAMETERS FOR COMPILATION
C
C
C     ** WORK SPACE IN THE BLANK COMMON **
C        AMM, AMR, AML, ARE ALL SQUARE MATRICES
C        CCD, CCF, ARE MATRIX SPACE FOR CORNER CONDITIONS
C
C     ** NODAL CONSTANTS
C
      COMMON /S2NODE/ MXX,NXX,DXM,DYN,XM(MDIM),YN(NDIM),XMC(MDIM),
     1                 YNC(NDIM),COSYN(NDIM)
C
C     ** TRICYCLE INDICES
C
      COMMON /MADCON/ MAD1,MADX,MAD,MM0,MR1,MR2,MR3,ML1,ML2,ML3,MRX,MLX
C
      SAVE
C
C     ** ** SLARGO BEGINS ** **
C
      IZERO = 0
      INSEC = ISECND(IZERO)
C
C     ** PREPARE FOR GETAMR.  SLIMAC ASSUMES /S2DTPT/ HAS BEEN DEFINED
C
      CALL SLIMAC
C
C     ** INITIALIZE TWO DISK UNITS
C        BOTH /S2PRIC/ AND /S2DTPT/ WILL BE COPIED ON UNIT MSKEF
C
      CALL SLEFW0
C
C     ** INITIALIZE THE N-MATRIX ROUTINES
C
      CALL PASDXX(NXX)
C
C     ** INITIALIZE THE TRICYCLE ROUTINES
C
      CALL CLRADE
C
C     ** INITIALIZE THE CORNERING ROUTINE
C
      CALL SLACCO
C
C     ** INITIALIZE TRICYCLE INDECES
C
      MAD1=1
      MADX=MXX
      MAD=0
      MM0=2
      MR1=3
      MR2=1
      MR3=2
C
C     ** START THE TRICYCLES
C
   10 MAD=MAD+1
      MM0=MR1
      MR1=MR2
      MR2=MR3
      MR3=MM0
      ML3=MR3
      ML2=MR1
      ML1=MR2
      MLX=MIN(MAD-MAD1,3)
      MRX=MIN(MADX-MAD,3)
      CALL CALDMM
C
C       ** SLEFW1 IS CALLED BY CALDMM
C
      CALL CALELR
C
C       ** SLEFW2 IS CALLED BY CALELR
C
      CALL AMRTOL
      IF(MAD.LT.MADX) GO TO 10
C
C     ** MERGE THE TWO DISK UNITS INTO ONE, MSKEF, BY BACK READING MSKEZ
C
      CALL SLEFED
      IDELTA = ISECND(INSEC)
      WRITE(6,880) IDELTA
  880 FORMAT(/' === SLARGO DONE ===',T91,'ELAPSED TIME=',I6)
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE SPLEFW(AML1,AML2,AML3,D,EL1,EL2,MZ,ER1,ER2,ER3)
cdak dk-check
      PARAMETER (MDIM=35,NDIM=35)
      PARAMETER (LDXDIM=8000)
C
C     ** SECONDARY PARAMETERS FOR COMPILATION
C
      PARAMETER (NSDIM=NDIM*NDIM)
C
C     ** THE FOLLOWING BASIC COMMONS ARE COPIED ON MSKEF, SO THAT,
C         IF THE DISK FILE IS SAVED, IT WILL CONTAIN ALL THE INFORMATION
C         NECESSARY FOR LATER USAGE.
C         NOTE THAT THE SAME /S2DTPT/ USED BY SLIMAC/GETAMR MUST
C         BE USED ALSO BY SLIMBO FOR CONSISTENCY
C
CIBM  COMMON /S2PRIC/ IDSPC,ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,
CIBM 1                 YNB,YNT,XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4)
      COMMON /S2PRIC/ ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,YNB,YNT,
     1                 XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4),IDSPC
      COMMON/S2DTPT/IDSPD1,IDSPD2,LDX,XD(LDXDIM),YD(LDXDIM),WD(LDXDIM),
     1               ID(LDXDIM),LXSORT(LDXDIM)
      COMMON/DSK/MSKEF,MSKEZ,MSKDA1,MSKDA2,MSKDA3,MSKDA4,MSKDA5,MSKDA6,
     1           MSKDA7,MSKDA8,MSKDA9,MSKD11,MSKD12,MSKD13,
     2           MSKD14,MSKD15,MSKD16,MSKD17,MSKD18
C
      CHARACTER*8 IDSPD1,IDSPD2*72,IDSPC*125,KENTRY*7
C
C     ** DUMMY ARGUMENTS  (FROM THE BLANK COMMON DEFINED IN SLARGO)
C
      SAVE
C
      DIMENSION AML1(NSDIM),AML2(NSDIM),AML3(NSDIM),D(NSDIM),
     1          EL1(NSDIM),EL2(NSDIM),ER1(NSDIM),ER2(NSDIM),ER3(NSDIM)
C
C     ** WORK SPACE IN THE BLANK COMMON ... TO BACK READ MSKEZ
C         SINCE THE BACK READ IS DONE ONLY AT THE END OF SLARGO,
C         THE USE OF BLANK COMMON BY SLEFED WILL NOT INTERFERE
C         WITH SLARGO EXECUTION.
C
      COMMON /MER/ MEZ,ER(NSDIM,3)
C
      CHARACTER*8 IDEF,IDZ*96,ZTIME,ZDATE*11
C
C     ** SAFETY LOCK
C
      DATA MDONE/-9/,KENTRY/' SPLEFW'/,IDEF/' MSKEF  '/
C
C     ** MSKEF FILE ID CODE ... MAY BE REDEFINED BY CALLING STEFID(IDEFZ
C
C     ** LOCAL WORK SPACE FOR ASSEMBLING MSKEF HEAD RECORD
C

C-----------------------------------------------------------------------

      ENTRY SLEFW0
      REWIND MSKEF
      REWIND MSKEZ
      CALL SPDATE(ZDATE)
      CALL SPTIME(ZTIME)
      WRITE(IDZ,805) IDEF,MDIM,NDIM,LDXDIM,LDX,ZDATE,ZTIME
  805 FORMAT(A8,' (M-,N-,LDXDIM)=',3I8,'   LDX=',I8,
     1    '  DATE=',A11,'  TIME=',A8)
C
C     ** LDXDIM IS NOT USED IN DETERMINING THE RECORD LENGTH, SO THAT
C         LDXDIM OF SPLEFW AND THAT OF SPLEFR NEED NOT BE THE SAME,
C         AS LONG AS THE BOTH VALUES OF LDXDIM ARE .GE. LDX.
C     ** WRITE THE HEAD RECORD ON MSKEF
C         THE RECORD LENGTH = 13 + 27 + 11 + 3*LDX = 51 + 3*LDX
C
      WRITE(MSKEF) IDZ,IDSPC,ISRCD,JPD,MX,NX,KDCTYP,KBCTYP,XM1,XMXX,YN1,
     1             YNXX,XYDCWL,XYBCWL,IDSPD1,IDSPD2,LDX,XD,YD,WD,ID,XML,
     2             XMR,YNB,YNT
      WRITE(6,808) MSKEF,MSKEZ,IDZ
  808 FORMAT(/' === SLEFW0 DONE ===   MSKEF=',I5,3X,'MSKEZ=',I5,/
     1   ,5X,'...',A96)
      MDONE=0
      RETURN

C-----------------------------------------------------------------------

C
C     ** ** IMPORTANT DECISION ON THE MSKEF RECORD FORMAT ** **
C        TO VECTORIZE SLIMBO CALCULATIONS ON CRAY-1, THERE IS
C        NO COMPUTATIONAL ADVANTAGE IN KEEPING   AML  AS NRDIM MATRICES
C        AS OF OCT 79, ALL ARRAYS, AMM, AMR AND AML, IN SLARGO ARE IN
C        THE FULL SQUARE FORM.  NO NEED TO CONVERT AML IN THIS ROUTINE.
C        SLEFW1 WRITES TWO RECORDS OF LENGTH ... 1+3*NSDIM ... FOR EACH
C        SLEFW2 WRITES ONE RECORD OF THE SAME LENGTH
C        THE DEFAULT VALUE OF  BS PARAMETER  IN cRAY JCL  ASSIGN  IS 4.
C        IF NDIM=41,  BS=12(OCTAL)  MAY BE ADVISABLE  FOR UNIT MSKEF
C
      ENTRY SLEFW1(AML1,AML2,AML3,D,EL1,EL2,MZ)
      MF=MZ
      IF(MF.NE.MDONE+1) GO TO 91
      WRITE(MSKEF) MF,AML1,AML2,AML3
      WRITE(MSKEF) MF,D,EL1,EL2
      RETURN

C-----------------------------------------------------------------------

C
      ENTRY SLEFW2(ER1,ER2,ER3,MZ)
      ME=-MZ
      IF(MF+ME.NE.0) GO TO 92
      WRITE(MSKEZ) ME,ER1,ER2,ER3
      MDONE=MDONE+1
      RETURN

C-----------------------------------------------------------------------

C
      ENTRY SLEFED
C
C     MERGE MSKEZ AND MSKEF
C
      IF(MDONE.NE.MX+1) GO TO 93
      ENDFILE MSKEZ
C
      DO 52 MM=1,MDONE
      BACKSPACE MSKEZ
      BACKSPACE MSKEZ
      READ(MSKEZ,ERR=95) MEZ,ER
      IF(MDONE+MEZ.NE.MM-1) GO TO 95
      WRITE(MSKEF) MEZ,ER
   52 CONTINUE
C
C     +++ WITHOUT THIS WAIT, EOF IS WRITTEN BEFORE THE LAST RECORD OUT
C
      ENDFILE (MSKEF,ERR=96)
      REWIND MSKEF
      WRITE(6,854) MSKEF,MDONE
  854 FORMAT(/' === SLEFED DONE ===   MSKEF=',I4,3X,'MDONE=',I3)
      RETURN
C
C-----------------------------------------------------------------------
C
C     ** ERROR EXIT
C
   91 KENTRY='SLEFW1'
      GO TO 94
   92 KENTRY='SLEFW2'
      GO TO 94
   93 KENTRY='SLEFED'
   94 WRITE(6,894) KENTRY,MF,ME,MDONE
  894 FORMAT(/' === ',A7,' MET WRONG M COUNTS.  (MF,ME,MDONE)=',3I6)
      GO TO 99
   95 WRITE(6,895) MM,MEZ,MDONE
  895 FORMAT(/' === SLEFED BACK READ ERROR.  (MM,ME,MDONE)=',3I6)
      GO TO 99
   96 WRITE(6,896) MSKEF
  896 FORMAT(/' ... ENDFILE ERROR ON ',A8)
   99 CALL ABRT1(KENTRY,896)
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE GAMSUB(AMM,AMR,M,AZZ)
C
C          ENTRY GETAMR (AMM,AMR,M)
C          ENTRY GTAMXX(AZZ)
C
      PARAMETER (MDIM=35,NDIM=35)
      PARAMETER (LDXDIM=8000)
C
C     ** DATA POINTS INFORMATION **
C
      COMMON/S2DTPT/IDSPD1,IDSPD2,LDX,XD(LDXDIM),YD(LDXDIM),WD(LDXDIM),
     1               ID(LDXDIM),LXSORT(LDXDIM)
C
C     OTHER CONSTANTS
C
CIBM  COMMON /S2PRIC/ IDSPC,ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,
CIBM 1                 YNB,YNT,XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4)
      COMMON /S2PRIC/ ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,YNB,YNT,
     1                 XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4),IDSPC
      COMMON /S2NODE/ MXX,NXX,DXM,DYN,XM(MDIM),YN(NDIM),XMC(MDIM),
     1                 YNC(NDIM),COSYN(NDIM)
C
C     LOCAL CONSTANTS FOR SLADDQ
C
      COMMON /S2MACQ/ MXX1,MX1,MX2,MX3,NXX1,NX1,NX2,NX3
C
C     DUMMY ARGUMENTS ... AMM,AMR ARE SQUARE MATRICES (OCT 79)
C
      SAVE
C
      DIMENSION AMM(NDIM,NDIM),AMR(NDIM,NDIM,3),AZZ(NDIM,NDIM)
C
C     LOCAL WORK SPACE
C
      DIMENSION ROWM(NDIM,4,4,4)
C
C     EQUIVALENCE (ROWM,XDZ)
C
      DIMENSION LROW(4)
C
      CHARACTER*8 IDSPD1,IDSPD2*72,IDSPC*125
C
C     INPUT TO SLIMAC VIA /S2DTPT/
C      XD      X COORDINATES DO DATA POINTS
C      YD      Y COORDINATES DO DATA POINTS
C      WD      WEIGHTS ON DATA AT INDIVIDUAL DATA POINTS
C              MUST HAVE BEEN SET BEFORE SLIMAC IS CALLED
C              ++ TO AVOID POSSIBLE HANG UP IN GETAMR, WD WILL BE
C                 SET NEGATIVE IF XD OR YD IS OFF LIMITS
C              ANY POINTS WITH ZERO OR NEGATIVE WEIGHT WILL NOT BE
C              INCLUDED IN THE ROWM ACCUMULATION BY SLIMAC/GETAMR
C      LDX     MAX NUMBER OF DATA POINTS.  MUST BE .LE. LDXDIM
C      IDSPD   ID OF THE DATA POINT SET, AND EXPLANATION (80 CHARACTERS)
C     INPUT TO GETAMR
C      M       X-NODE INDEX.   MUST START AT 1, AND END AT MXX.
C     OUT FROM GETAMR
C      AMM     (N,N) MATRIX AT (M,M) DIAGONAL
C      AMR     (N,N) MATRICES OF (M,M+MR) OFF-DIAGONAL
C              *** MR=1 IN SPLESK ROUTINES IS FOR THE FIRST OFF-DIAGONAL
C     +++ +++ NRTOS0 IS USED TO TRANSFORM REC ARRAYS TO SQUARE ARRAYS ++
C     LOCAL ARRAYS
C      ROWM    WILL BE ACTIVE DURING SLARGO EXECUTION
C      LXSORT  IS NOT DEFINED IN XDTSRT THROUGH COMMON
C      LROW    ROW CYCLING REGISTER
C      XDZ     TEMPORARY WORK SPACE  EQUIVALENCED TO ROWM
C              ITS NEED BY SORTRL ENDS BEFORE ROWM IS CLEARED BY SLIMAC
C     SAFETY LOCK ... MDONE
C
      DATA MDONE/-9/

C-----------------------------------------------------------------------

C
      ENTRY SLIMAC
C
C     ** DEFINE /S2MACQ/ FOR THE USE BY SLADDQ
C
      MXX1=MXX+1
      MX1=MX-1
      MX2=MX-2
      MX3=MX-3
      NXX1=NXX+1
      NX1=NX-1
      NX2=NX-2
      NX3=NX-3
C
C     ** INITIALIZATION FOR GETAMR **
C     CHECK DATA POINTS AND WEIGHTS
C     ONLY DATA INSIDE DOMAIN ARE ACCEPTED
C
      LDOK=0
      LDOFF=0
C
      DO 84 LD=1,LDX
C
C     IGNORE IF THE WEIGHT IS ALREADY MARKED OFF
C
      IF(WD(LD).LE.0.) GO TO 82
C
C     CHECK FOR OFF-LIMIT POINTS:  THIS CHECK HAS BEEN MOVED TO XDTSRT.
C                                  (6/13/88)
C
C      IF(XD(LD) .LT. XM1 .OR. XD(LD) .GT. XMXX)  GO TO 82
C      IF(YD(LD) .LT. YN1 .OR. YD(LD) .GT. YNXX)  GO TO 82
C
C     ACCEPTED POINTS
C
      LDOK=LDOK+1
      GO TO 84
C
C     OFF THE LIMITS.  WD SET TO NEGATIVE
C
   82 WD(LD)=-ABS(WD(LD))
C
c && 2 comments
CC    WRITE(6,830) XD(LD),YD(LD)
CC830 FORMAT(10X,'REJECTED DATA POINT...XD=',F6.2,'  YD=',F6.2)
      LDOFF=LDOFF+1
   84 CONTINUE
C
      WRITE(6,885) LDX,LDOK,LDOFF
  885 FORMAT(/' === SLIMAC DATA POINTS CHECK.    LDX=',I7,
     1    ' (INPUT TOTAL COUNT)',/,35X,'LDOK=',I6,' (ACCEPTED BY ',
     2    'SLIMAC)',/,34X,'LDOFF=',I6,' (REJECTED.  WD REDEFINED)')
C
C     QUIT, IF NO DATA POINTS WERE ACCEPTED
C
      IF(LDOK.LE.0) GO TO 91
C
C     INITIALIZE THE ROW POINTER AND ROWM
C
      DO L=1,4
      LROW(L)=L
      ENDDO
C
      ROWM=0.
C
      DY0=1./DYN
      MDONE=0
      IDD=0
      XSTOP=XM(3)
      CALL SLIQBG
      RETURN

C-----------------------------------------------------------------------

C
      ENTRY GETAMR(AMM,AMR,M)
C
C     MAKE SURE CORRECT NODE IS BEING CALCULATED
C
      IF(M.NE.MDONE+1) GO TO 92
      IF(M.GT.MXX)     GO TO 92
C
C     CHECK IF UNPROCESSED DATA STILL REMAIN
C
  110 IF(IDD.GE.LDX) GO TO 120
      IDD=IDD+1
      if(IDD .GT. LDXDIM)  THEN
         print *, 'LDXDIM limit (',LDXDIM,') exceeded - ',
     $    'IDD=',IDD,', return'
         return
      endif
      LD=LXSORT(IDD)
      X=XD(LD)
      Y=YD(LD)
      W=WD(LD)
      IF(W.LE.0.) GO TO 110
C
C     CHECK IF X IS IN THE ACCUMULATION RANGE
C
      IF(X.LE.XSTOP) GO TO 112
      IDD=IDD-1
      GO TO 120
C
C     ** ROWM ACCUMULATION **
C
  112 MA1=M
      MMAX=MIN(MA1+3,MXX)
      NA1=MAX(INT((Y-YN1)*DY0),1)
      NAX=MIN(NA1+3,NXX)
C
      DO MA=MA1,MMAX
      LR=LROW(MA-MA1+1)
      WMA =XBF(MA,X)*W
      DO MB=MA,MMAX
      MR=MB-MA+1
      WMAB=XBF(MB,X)*WMA
      DO NA=NA1,NAX
      WMABNA=YBF(NA,Y)*WMAB
      DO NB=NA,NAX
      NR=NB-NA+1
      ROWM(NA,NR,MR,LR)=ROWM(NA,NR,MR,LR)+YBF(NB,Y)*WMABNA
      ENDDO
      ENDDO
      ENDDO
      ENDDO
C
      GO TO 110
C
C     NO MORE DATA POINTS LEFT IN THE PRESENT ACCUMULATION RANGE
C     ADD Q
C
  120 LR=LROW(1)
C
C     SET UP ROWM MATRIX
C
      CALL SLADDQ(M,ROWM(:,:,:,LR))
C
C     TRANSFER THE READY RESULTS IN ROWM AT LR=LROW(1) TO AMM AND AMR
C
      CALL NRTOS0(ROWM(:,:,1,LR),AMM)
C
C     +++ MR=1 IS THE DIAGONAL IN ROWM, BUT THE FIRST OFF-DIAGONAL IN AM
C
      DO MR=2,4
      CALL NRTOS0(ROWM(:,:,MR,LR),AMR(:,:,MR-1))
      ENDDO
C
C     ** PREPARE FOR NEXT ENTRY TO GETAMR
C     CLEAR THE LR=LROW(1)
C
      ROWM(:,:,:,LR)=0.
C
C     CYCLE UP LROW FOR NEXT ENTRY
C     ++ SYSTEM (CFT) ERROR IN VECTORIZED MOD FUNC.  DO NOT USE MOD. 7/3
C
      DO L=1,4
      LZ=LROW(L)+1
      IF(LZ.GT.4) LZ=LZ-4
      LROW(L)=LZ
      ENDDO
C
C     ADVANCE THE ACCUMULATION LIMIT
C
      XSTOP=XSTOP+DXM
      MDONE=M
      RETURN

C-----------------------------------------------------------------------

C
C       ** SPECIAL ENTRY TO GET THE PREVIEW OF AMM AT MXX (CALLED BY SLA
C
      ENTRY GTAMXX(AZZ)
      IF(MDONE.NE.MX) GO TO 93
      IF(IDD.GE.LDX) GO TO 155
      LDLEFT=0
C
      DO 151 LD=IDD+1,LDX
      IF(WD(LD).GT.0.) LDLEFT=LDLEFT+1
  151 CONTINUE
C
      IF(LDLEFT.EQ.0) GO TO 155
      WRITE(6,8152) LDLEFT,MDONE
 8152 FORMAT(/' === GTAMXX WARNING...',I5,'VALID DATA POINTS ARE ',
     1    'STILL LEFT UNACCUMULATED AT MDONE=',I3)
C
C       ++ GET AMM OF MXX IN AZZ, WITHOUT DISTURBING THE SLIMAC SEQUENCE
C
  155 LRXX=LROW(1)
C
      AZZ(1:NXX,1:4)=ROWM(1:NXX,:,1,LRXX)
C
C     ADD AZZ TO PNMR AND QNMG AND RETURN IN AZZ
C
      CALL SLADDQ(MXX,AZZ)
C
C     SHIFT VALUES IN AZZ BACK TO ITSELF
C
      CALL NRTOS0(AZZ,AZZ)
      RETURN
C
C     ** ERROR EXITS **
C
   91 WRITE(6,891)
  891 FORMAT(' === SLIMAC CALLS EXIT.  NO ACCEPTED DATA POINTS.')
      GO TO 99
   92 WRITE(6,892) M,MDONE,MXX
  892 FORMAT(/' === GETAMR/SLIMAC WAS CALLED WITH A WRONG M.   M=',I3,
     1    '  MDONE=',I3,'  MXX=',I3,/,6X,'OR, SLIMAC HAS NOT BEEN ',
     2    'CALLED')
      GO TO 99
   93 WRITE(6,893) MDONE,MX
  893 FORMAT(/' === GTAMXX WAS CALLED AT A WRONG M.  MDONE=',I3,
     1    ' MUST BE EQUAL TO MX=',I3)
   99 CALL ABRT1(' SLIMAC',893)
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE SLIQBG
C
CIBM  COMMON /S2PRIC/ IDSPC,ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,
CIBM 1                 YNB,YNT,XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4)
      COMMON /S2PRIC/ ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,YNB,YNT,
     1                 XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4),IDSPC
      COMMON /S2BCDC/ DX0,DX1,DX2,DY0,DY1,DY2,CBCBF(8),XYSDCP(2)
      COMMON /S2QRBG/ QMRBG(7,4,4),QNRBG(7,4,4)
C
      SAVE
C
      CHARACTER*125 IDSPC
C
C     ** STRUCTURE OF QMRBG (I,J,K)  (FOR ANY K)
C   I   J= 1         2         3         4
C              QUADRATURE INTEGRAL TERMS               THE ORDER OF DERI
C   1     1,1       1,2       1,3       1,4                 IN QUADRATUR
C   2     2,2       2,3       2,4       2,5
C   3     3,3       3,4       3,5       3,6              K=1   0TH ORDER
C   4    MX,MX    MX1,MX    MX2,MX    MX3,MX               2   1ST ORDER
C   5   MXX,MXX    MX,MXX   MX1,MXX   MX2,MXX              3   2ND ORDER
C                                                          4   3RD ORDER
C     +++ NO BOUNDARY TERMS ARE USED IN SLACCO VERSION OF SLADDQ (OCT 79
C               BOUNDARY-POINT TERMS
C        .......(SYMMETRIC)........  (ANTI-SYM)
C   6     1,1       1,2       2,2       1,2
C   7    MX,MX     MX,MXX   MXX,MXX    MX,MXX
C     ORTHO- AND PARA-ELEMENTS ARE PARTIAL QUADRATURES OF BF AND DERIVAT
C
      DIMENSION QO11(4),QO12(4),QO22(4),QP11(4),QP12(4),QP22(4)
C
      DATA QO11/0.530357142857143, 0.63750, 2.250, 20.25/,
     1     QO12/0.057589285714286, 0.13125,-1.125, -6.75/,
     2     QO22/0.008928571428571, 0.11250, 0.750,  2.25/,
     3     QP11/0.416517857142857,-0.54375,-1.125,-20.25/,
     4     QP12/0.026785714285714,-0.22500, 0.000,  6.75/,
     5     QP22/0.000446428571429,-0.01875, 0.375, -2.25/
C
C     ** NO-PRINT
C
C     FOR INTERIOR NODES
C
      QMRBG(3,1,:)=2.*(QO11(:)+QO22(:))
      QMRBG(3,2,:)= 2.*QO12(:)+QP11(:)
      QMRBG(3,3,:)= 2.*QP12(:)
      QMRBG(3,4,:)=    QP22(:)
C
      QNRBG(3,:,:)=QMRBG(3,:,:)
C
      DO K=1,4
         DO I=2,4
            QMRBG(I,3,K)=QMRBG(3,3,K)
            QNRBG(I,3,K)=QNRBG(3,3,K)
         ENDDO
         DO I=1,5
            QMRBG(I,4,K)=QMRBG(3,4,K)
            QNRBG(I,4,K)=QNRBG(3,4,K)
         ENDDO
      ENDDO
C
C     FOR BOUNDARY NODES
C
      ZM11=4.*CBCBF(1)
      ZM12=4.*CBCBF(2)
      ZMX1=4.*CBCBF(3)
      ZMX2=4.*CBCBF(4)
      ZN11=4.*CBCBF(5)
      ZN12=4.*CBCBF(6)
      ZNX1=4.*CBCBF(7)
      ZNX2=4.*CBCBF(8)
C
      DO 22 K=1,4
      QMRBG(1,1,K)=QO11(K)+QO22(K)+ZM11*(2.*QO12(K)+ZM11*QO22(K))
      QNRBG(1,1,K)=QO11(K)+QO22(K)+ZN11*(2.*QO12(K)+ZN11*QO22(K))
      QMRBG(1,2,K)=QP11(K)+QO12(K)+ZM12*(QO12(K)+ZM11*QO22(K))
     1             +ZM11*QP12(K)
      QNRBG(1,2,K)=QP11(K)+QO12(K)+ZN12*(QO12(K)+ZN11*QO22(K))
     1             +ZN11*QP12(K)
      QMRBG(1,3,K)=2.*QP12(K)+ZM11*QP22(K)
      QNRBG(1,3,K)=2.*QP12(K)+ZN11*QP22(K)
      QMRBG(2,1,K)=2.*QO11(K)+QO22(K)+ZM12*(2.*QP12(K)+ZM12*QO22(K))
      QNRBG(2,1,K)=2.*QO11(K)+QO22(K)+ZN12*(2.*QP12(K)+ZN12*QO22(K))
      QMRBG(2,2,K)=2.*QO12(K)+QP11(K)+ZM12*QP22(K)
      QNRBG(2,2,K)=2.*QO12(K)+QP11(K)+ZN12*QP22(K)
      QMRBG(4,1,K)=2.*QO11(K)+QO22(K)+ZMX2*(2.*QP12(K)+ZMX2*QO22(K))
      QNRBG(4,1,K)=2.*QO11(K)+QO22(K)+ZNX2*(2.*QP12(K)+ZNX2*QO22(K))
      QMRBG(4,2,K)=2.*QO12(K)+QP11(K)+ZMX2*QP22(K)
      QNRBG(4,2,K)=2.*QO12(K)+QP11(K)+ZNX2*QP22(K)
      QMRBG(5,1,K)=QO11(K)+QO22(K)+ZMX1*(2.*QO12(K)+ZMX1*QO22(K))
      QNRBG(5,1,K)=QO11(K)+QO22(K)+ZNX1*(2.*QO12(K)+ZNX1*QO22(K))
      QMRBG(5,2,K)=QP11(K)+QO12(K)+ZMX2*(QO12(K)+ZMX1*QO22(K))
     1             +ZMX1*QP12(K)
      QNRBG(5,2,K)=QP11(K)+QO12(K)+ZNX2*(QO12(K)+ZNX1*QO22(K))
     1             +ZNX1*QP12(K)
      QMRBG(5,3,K)= 2.*QP12(K)+ZMX1*QP22(K)
      QNRBG(5,3,K)= 2.*QP12(K)+ZNX1*QP22(K)
   22 CONTINUE
C
C     +++ BOUNDARY LINE AND CORNER TERMS ARE NOT USED ANY MORE (OCT 79)
C
      QMRBG(6:7,:,:)=0.
      QNRBG(6:7,:,:)=0.
C
C     ** PRINT OUTPUT, UNCOMMENT THESE
C
CCCC  WRITE(6,880) KBCTYP(1),KBCTYP(2),ZM11,ZM12,ZMX1,ZMX2
CCCC  WRITE(6,881) (((QMRBG(I,J,K),J=1,4),I=1,7),K=1,4)
CCCC  WRITE(6,880) KBCTYP(3),KBCTYP(4),ZN11,ZN12,ZNX1,ZNX2
CCCC  WRITE(6,881) (((QNRBG(I,J,K),J=1,4),I=1,7),K=1,4)
CC880 FORMAT(/'.../S2QRBG/... BEFORE DC FACTOR MULTIPLICATION ...',//,
CCCC 1    11X,I3,13X,I3,/,(7X,2F7.3,2X,2F7.3))
CC881 FORMAT(//,(5(5X,4F16.10,/),/,2(5X,4F16.10,/)))
C
C     ** MULTIPLY DC-FACTORS **
C
      DO K=2,4
         KK=2*(K-1)
         Z1=XYSDCP(1)**KK
         Z2=XYSDCP(2)**KK
         DO J=1,4
            DO I=1,7
               QMRBG(I,J,K)=Z1*QMRBG(I,J,K)
               QNRBG(I,J,K)=Z2*QNRBG(I,J,K)
            ENDDO
         ENDDO
      ENDDO
C
      RETURN

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE SLADDQ(M,PNMR)
C
C     +++ NO BOUNDARY LINE AND CORNER TERMS OF QMRBG,QNRBG ARE USED
C         IN THE SLACCO VERSION OF SLADDQ (OCT 79)
C
      PARAMETER (MDIM=35,NDIM=35)
CIBM  COMMON /S2PRIC/ IDSPC,ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,
CIBM 1                 YNB,YNT,XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4)
      COMMON /S2PRIC/ ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,YNB,YNT,
     1                 XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4),IDSPC
      COMMON /S2NODE/ MXX,NXX,DXM,DYN,XM(MDIM),YN(NDIM),XMC(MDIM),
     1                 YNC(NDIM),COSYN(NDIM)
      COMMON /S2MACQ/ MXX1,MX1,MX2,MX3,NXX1,NX1,NX2,NX3
      COMMON /S2QRBG/ QMRBG(7,4,4),QNRBG(7,4,4)
C
      CHARACTER*125 IDSPC
C
      SAVE
C
      DIMENSION PNMR(NDIM,4,4)
      DIMENSION QNMG(5,4,4),QAS1(4),QASX(4),MG(4)
C
      QAS1=0.
      QASX=0.
      QNMG=0.
C
C     SET UP INDEXING PARAMETERS FOR OMRBG
C
      IF(M-MX1.EQ.0) THEN
         GO TO 18
      ELSE  IF(M-MX1.GT.0)  THEN
         GO TO 15
      END IF
      IF(M-2.EQ.0)  THEN
         GO TO 12
      ELSE  IF(M-2.GT.0)  THEN
         GO TO 13
      END IF
C
C     FOR M=1
C
      GO TO 13
C
C     FOR M=2
C
   12 CONTINUE
C
C     FOR ALL M THAT IS .LT. MX1
C
   13 CONTINUE
      MRX=4
C
      DO MR=1,MRX
      MG(MR)=MIN(M,3)
      ENDDO
C
      GO TO 20
   15 CONTINUE
      IF(M-MX.LT.0) THEN
         GO TO 18
      ELSE  IF(M-MX.GT.0)  THEN
         GO TO 17
      END IF
C
C     FOR M=MX
C
      GO TO 18
C
C     FOR M=MXX
C
   17 CONTINUE
C
C     FOR M=MX1,MX,MXX
C
   18 CONTINUE
      MRX=MXX1-M
C
      DO MR=1,MRX
      MG(MR)=MR+M-MX3
      ENDDO
C
C     ** TEST KDCTYP (ORDER OF FILTER)
C     === TYPE 2 AND 3 ARE PRESENTLY ALLOWED ===
C
   20 CONTINUE
      IF(KDCTYP-2.LT.0)  THEN
         GO TO 90
      ELSE  IF(KDCTYP-2.EQ.0) THEN
         GO TO 50
      END IF
C
C     THIRD ORDER CONSTRAINT ... KDCTYP=3
C
      DO 34 MR=1,MRX
      MGZ=MG(MR)
C
C     SYMMETRIC BODY TERMS
C
      DO NR=1,4
      DO NG=1,5
      QNMG(NG,NR,MR)=    QMRBG(MGZ,MR,4)*QNRBG(NG,NR,1)
     1               +3.*QMRBG(MGZ,MR,3)*QNRBG(NG,NR,2)
     2               +3.*QMRBG(MGZ,MR,2)*QNRBG(NG,NR,3)
     3                  +QMRBG(MGZ,MR,1)*QNRBG(NG,NR,4)
      ENDDO
      ENDDO
   34 CONTINUE
C
C     ** ADD QNMG TO PNMR
C
   40 CONTINUE
      DO MR=1,MRX
         DO NR=1,4
            DO N=1,2
               PNMR(N,NR,MR)=PNMR(N,NR,MR)+QNMG(N,NR,MR)
            ENDDO
            DO N=3,NX2
               PNMR(N,NR,MR)=PNMR(N,NR,MR)+QNMG(3,NR,MR)
            ENDDO
         ENDDO
         DO N=NX1,NXX
            NRX=NXX1-N
            DO NR=1,NRX
               PNMR(N,NR,MR)=PNMR(N,NR,MR)+QNMG(NR+5-NRX,NR,MR)
            ENDDO
         ENDDO
C
C     PLACE THE ANTISYMMETRIC TERMS IN THE LOWER CORNER OF PNMR
C       ** NO FLAG IS SET AS WAS IN THE EARLIER PRACTICE IN VALSE AND AN
C
         PNMR(NXX,3,MR)=QAS1(MR)
         PNMR(NX ,4,MR)=QASX(MR)
      ENDDO
C
      RETURN
C
C     SECOND ORDER CONSTRAINT ... KDCTYP=2
C
   50 CONTINUE
      DO 54 MR=1,MRX
      MGZ=MG(MR)
      QNMG(:,:,MR)=    QMRBG(MGZ,MR,3)*QNRBG(1:5,:,1)
     1             +2.*QMRBG(MGZ,MR,2)*QNRBG(1:5,:,2)
     2                +QMRBG(MGZ,MR,1)*QNRBG(1:5,:,3)
   54 CONTINUE
C
      GO TO 40
   90 CONTINUE
      WRITE(6,890) KDCTYP
  890 FORMAT(/' === SLADDQ DOES NOT ACCEPT   KDCTYP=',I2)
      CALL ABRT1(' SLADDQ',890)
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE ADEXXX
      PARAMETER (NDIM=35)
C
C     ** SECONDARY PARAMETERS FOR COMPILATION
C
      PARAMETER (NSDIM=NDIM*NDIM)
C
C     DUMMY ARGUMENTS ARE NOW IN BLANK COMMON FOR VAX-11
C
      COMMON/AAA/AMM(NDIM,NDIM),AMR(NSDIM,3),AML(NSDIM,3,3),DMM(NSDIM),
     1          E(NSDIM,3,3),ANS(NSDIM),CCD(NDIM,NDIM),CCF(NDIM,NDIM)
      COMMON /MADCON/ MAD1,MADX,MAD,MM0,MR1,MR2,MR3,ML1,ML2,ML3,MRX,MLX
C
      SAVE

C-----------------------------------------------------------------------

C
      ENTRY CLRADE
      CALL CLRANS(AMM)
      CALL CLRANS(DMM)
      CALL CLRANS(ANS)
C
      DO J=1,3
         CALL CLRANS(AMR(:,J))
         DO I=1,3
            CALL CLRANS(AML(:,I,J))
            CALL CLRANS(E(:,I,J))
         ENDDO
      ENDDO
C
      RETURN

C-----------------------------------------------------------------------

C
      ENTRY AMRTOL
      CALL NSTPS0(AMR(:,1),AML(:,MR1,MM0))
      CALL NSTPS0(AMR(:,2),AML(:,MR2,MM0))
      CALL NSTPS0(AMR(:,3),AML(:,MR3,MM0))
      RETURN

C-----------------------------------------------------------------------

C
      ENTRY CALDMM
C
C     GET MATRICES AMM AND AMR
C
      CALL GETAMR(AMM,AMR,MAD)
C
C     DO MATRIX MANIPULATION OF TRICYCLING
C
      CALL CCOAMR(MAD)
C
C     PUT ANS INTO AMM
C
      CALL NSTOS0(AMM,ANS)
C
C     ANS=AML*E+ANS
C
      CALL MLXN9A(AML,E,ANS,MM0)
C
C     DMM=INV(ANS)
C
      CALL NEGINV(ANS,DMM)
C
C     WRITE AML,DMM, AND E TO MSKEF
C
      CALL SLEFW1(AML(:,MM0,ML1),AML(:,MM0,ML2),AML(:,MM0,ML3),DMM,
     1            E(:,ML1,MM0),E(:,ML2,MM0),MAD)
      RETURN

C-----------------------------------------------------------------------

C
      ENTRY CALELR
C
C     ** E MUST HAVE BEEN INITIALIZED TO ZERO, TO GET E ZEROED AT FRONT
C        E AT THE TAIL END WILL BE ZEROED BY NON-PERIODIC GETAMR
C        ** SPECIAL CLEARING OF E FOR PERIODIC BC IS OMITTED IN THIS VER
C     ** IT IS OK TO CALCULATE E(1,MM0,MR) IN THE ORDER OF MR3,MR2,MR1.
C        BUT MR3 MUST BE THE LAST, FOR E(1,ML1,MR) AND E(1,ML2,MR)
C
      GO TO (14,13,12,11),MRX+1
   11 CALL NSXNS0(DMM,AMR(:,3),E(:,MM0,MR3))
   12 CALL NSTOS0(AMR(:,2),ANS)
      CALL MLXN9A(AML,E,ANS,MR2)
      CALL NSXNS0(DMM,ANS,E(:,MM0,MR2))
   13 CALL NSTOS0(AMR(:,1),ANS)
      CALL MLXN9A(AML,E,ANS,MR1)
      CALL NSXNS0(DMM,ANS,E(:,MM0,MR1))
   14 GO TO (15,16,17,18),MRX+1
C
C     ** CLEARING E(1,MM0,MR) AT THE TAIL END
C     ** CORRESPONDING E(1,ML1,MR) AND E(1,ML2,MR) ARE CLEARED BELOW 20
C
   15 CALL CLRANS (E(:,MM0,MR1))
   16 CALL CLRANS (E(:,MM0,MR2))
   17 CALL CLRANS (E(:,MM0,MR3))
   18 CONTINUE
C
C     WRITE E TO MSKEZ
C
      CALL SLEFW2(E(:,MM0,MR1),E(:,MM0,MR2),E(:,MM0,MR3),MAD)
C
C     ** MR3 MUST BE THE LAST
C        USE NS0XNS(BS,AS,CS) AT MR3, BECAUSE
C        E(1,MLZ,MM0) AND E(1,MLZ,MR3) SHARE THE SAME ADDRESS
C
C  20 CONTINUE
      IF(MLX.LE.0) GO TO 28
      MLZ=ML1
C
      DO L=1,2
      CALL NSXNSA(E(:,MLZ,MM0),E(:,MM0,MR1),E(:,MLZ,MR1))
      CALL NSXNSA(E(:,MLZ,MM0),E(:,MM0,MR2),E(:,MLZ,MR2))
      CALL NS0XNS(E(:,MLZ,MM0),E(:,MM0,MR3),E(:,MLZ,MR3))
      IF(MLX.LE.L) GO TO 28
      MLZ=ML2
      ENDDO
C
   28 CONTINUE
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE CCOSUB(MAD)
C
C     ENTRY CCOAMR (MAD)
C     ** MODIFY AMM AND AMR ACCORDING TO CORNER CONDITIONS SET BY SLOCCO
C        CCOAMR MUST FOLLOW GETAMR IN CALDMM OF ADEXXX
C
      PARAMETER (MDIM=35,NDIM=35)
      PARAMETER (NSDIM=NDIM*NDIM)
C
      COMMON/AAA/AMM(NDIM,NDIM),AMR(NSDIM,3),AML(NSDIM,3,3),DMM(NSDIM),
     1          E(NSDIM,3,3),ANS(NSDIM),CCD(NDIM,NDIM),CCF(NDIM,NDIM)
C
      SAVE
C
      DIMENSION AR1(NSDIM),AR2(NSDIM),AR3(NSDIM)
      EQUIVALENCE (AR1(1),AMR(1,1)),(AR2(1),AMR(1,2)),(AR3(1),AMR(1,3))
C
      COMMON /S2NODE/ MXX,NXX,DXM,DYN,XM(MDIM),YN(NDIM),XMC(MDIM),
     1                 YNC(NDIM),COSYN(NDIM)
C
      COMMON /S2CORN/ CORN(4,4)
      DIMENSION CCMM(32),CCR1(32),CCR2(32)

C-----------------------------------------------------------------------

C
      ENTRY SLACCO
C
C       ++ SET CONSTANTS AND ROUTES
C
      MX3=MXX-4
      NX=NXX-1
      mgo1 = 20
      mgo2 = 30
      mgox2 = 40
      mgox1 = 50
      mgox = 60
      mgoxx = 70
      IF(CORN(1,1).GT.0. .OR. CORN(1,2).GT.0.) GO TO 5
      mgo1 = 13
      mgo2 = 13
    5 IF(CORN(1,3).GT.0. .OR. CORN(1,4).GT.0.) GO TO 8
      mgox2 = 13
      mgox1 = 13
      mgox = 13
      mgoxx = 13
    8 RETURN

C-----------------------------------------------------------------------

C
      ENTRY CCOAMR(MAD)
      MCCO=MIN(MAD,3)+IDIM(MAD,MX3)
      GO TO (11,12,13,14,15,16,17),MCCO
   11 CONTINUE
      if(mgo1.eq.20)  then
         go to 20
      else if(mgo1.eq.13)  then
         return
      else
         call ABRT1(' CCOMAR',11)
      endif
   12 CONTINUE
      if(mgo2.eq.30)  then
         go to 30
      else if(mgo2.eq.13)  then
         return
      else
         call ABRT1(' CCOMAR',12)
      endif
   13 CONTINUE
      RETURN
   14 CONTINUE
      if(mgox2.eq.40)  then
         go to 40
      else if(mgox2.eq.13)  then
         return
      else
         call ABRT1(' CCOMAR',14)
      endif
   15 CONTINUE
      if(mgox1.eq.50)  then
         go to 50
      else if(mgox1.eq.13)  then
         return
      else
         call ABRT1(' CCOMAR',15)
      endif
   16 CONTINUE
      if(mgox.eq.60)  then
         go to 60
      else if(mgox.eq.13)  then
         return
      else
         call ABRT1(' CCOMAR',16)
      endif
   17 CONTINUE
      if(mgoxx.eq.70)  then
         go to 70
      else if(mgoxx.eq.13)  then
         return
      else
         call ABRT1(' CCOMAR',17)
      endif
C
C     ** M=1 **
C       ++ SET CORNER CONDITION MATRICES, CCD AND CCF,FOR CORNER 1 AND 2
C       ++ FIRST CLEAR CCD AND CCF
C
   20 CALL CLRANS(CCD)
      CALL CLRANS(CCF)
C
      DO  N=1,NXX
         CCD(N,N)=1.0
      ENDDO
C
      CCD(1,1)=1.-CORN(1,1)
      CCD(1,2)=CORN(2,1)
      CCF(1,1)=CORN(3,1)
      CCF(1,2)=CORN(4,1)
      CCD(NXX,NXX)=1.-CORN(1,2)
      CCD(NXX,NX )=CORN(2,2)
      CCF(NXX,NXX)=CORN(3,2)
      CCF(NXX,NX )=CORN(4,2)
C
C     ++ CALCULATE AND SAVE ADDITIVE TERMS FOR M=2,
C        BEFORE AMM,AMR AT M=1 ARE MODIFIED
C        ANS=TRANSPOSE(CCF)*AR3
C
      CALL NTXNS0(CCF,AR3,ANS)
C
C     PUT 2-D ANS INTO 3-D CCR2
C
      CALL CC2SAV(ANS,CCR2)
C
C     ANS=TRANSPOSE(CCF)*AR2
C
      CALL NTXNS0(CCF,AR2,ANS)
C
C     PUT 2-D ANS INTO 3-D CCR1
C
      CALL CC2SAV(ANS,CCR1)
C
C     ANS=AMM*CCF
C
      CALL NSXNS0(AMM,CCF,ANS)
C
C     ANS=TRANSPOSE(CCF)*ANS
C
      CALL NTXNS0(CCF,ANS,ANS)
C
C     ANS=TRANSPOSE(AR1)*CCF+ANS
C
      CALL NTXNSA(AR1,CCF,ANS)
C
C     ANS=TRANSPOSE(CCF)*AR1+ANS
C
      CALL NTXNSA(CCF,AR1,ANS)
C
C     PUT 2-D ANS INTO 3-D CCMM
C
      CALL CC2SAV(ANS,CCMM)
C
C       ++ MODIFY AMM AND AMR OF M=1.  MUST BE DONE BACKWARD IN MR
C     AR3=TRANSPOSE(CCD)*AR3
C
      CALL NTXNS0(CCD,AR3,AR3)
C
C     AR2=TRANSPOSE(CCD)*AR2
C
      CALL NTXNS0(CCD,AR2,AR2)
C
C     AR1=TRANSPOSE(CCD)*AR1
C
      CALL NTXNS0(CCD,AR1,AR1)
C
C     ANS=AMM*CCF
C
      CALL NSXNS0(AMM,CCF,ANS)
C
C     AR1=TRANSPOSE(CCD)*ANS+AR1
C
      CALL NTXNSA(CCD,ANS,AR1)
C
C     ANS=AMM*CCD
C
      CALL NSXNS0(AMM,CCD,ANS)
C
C     AMM=TRANSPOSE(CCD)*ANS+AMM
C
      CALL NTXNS0(CCD,ANS,AMM)
C
C       ++ FOR LITTLE JOSEPH ++
C
      AMM(1,1)    =CORN(1,1)+AMM(1,1)
      AMM(NXX,NXX)=CORN(1,2)+AMM(NXX,NXX)
      RETURN
C
C     ** M=2 **
C     ++ ADD THE SAVED TERMS
C
   30 CALL CC2ADD(AR2,CCR2)
      CALL CC2ADD(AR1,CCR1)
      CALL CC2ADD(AMM,CCMM)
      RETURN
C
C     ** M=MX2 **
C       ++ SET CORNER CONDITION MATRICES, CCD AND CCF,FOR CORNER 3 AND 4
C
   40 CALL CLRANS(CCD)
      CALL CLRANS(CCF)
C
      DO  N=1,NXX
         CCD(N,N)=1.0
      ENDDO
C
      CCD(1,1)=1.-CORN(1,3)
      CCD(1,2)=CORN(2,3)
      CCF(1,1)=CORN(3,3)
      CCF(1,2)=CORN(4,3)
      CCD(NXX,NXX)=1.-CORN(1,4)
      CCD(NXX,NX )=CORN(2,4)
      CCF(NXX,NXX)=CORN(3,4)
      CCF(NXX,NX )=CORN(4,4)
C
C     ++ MODIFY AMR FOR M=MX2.  MUST BE DOE FORWARD IN MR
C     AR2=AR3*CCF+AR2
C
      CALL NSXNSA(AR3,CCF,AR2)
C
C     AR3=CCD*AR3
C
      CALL NS0XNS(AR3,CCD,AR3)
      RETURN
C
C     ** M=MX1 **
C     AR1=AR2*CCF+AR1
C
   50 CALL NSXNSA(AR2,CCF,AR1)
C
C     AR2=CCD*AR2
C
      CALL NS0XNS(AR2,CCD,AR2)
      RETURN
C
C     ** M=MX **
C     ++ GTAMXX GETS AMM OF MXX, AHEAD OF THE NORMAL M-SEQUENCE
C        CALCULATIONS MUST PROCEED FORWARD IN MR
C     AMM=AR1*CCF*AMM
C
   60 CALL NSXNSA(AR1,CCF,AMM)
C
C     ANS=TRANSPOSE(AMM)
C
      CALL NSTPS0(AMM,ANS)
C
C     ANS=TRANSPOSE(AR1)*CFF+ANS
C
      CALL NTXNSA(AR1,CCF,ANS)
C
C     AMM=TRANSPOSE(ANS)
C
      CALL NSTPS0(ANS,AMM)
C
C     ADD ROWM TO NEW PNMR AND QNMG AND RETURN NEW MATRIX
C
      CALL GTAMXX(ANS)
C
C     ANS=CCF*ANS
C
      CALL NS0XNS(ANS,CCF,ANS)
C
C     AMM=TRANSPOSE(CCF)*ANS*AMM
C
      CALL NTXNSA(CCF,ANS,AMM)
C
C     AR1=CCD*AR1
C
      CALL NS0XNS(AR1,CCD,AR1)
C
C     ADD ROWM, NEW PNMR, AND NEW QNMG AND PUT BACK INTO ANS
C
      CALL GTAMXX(ANS)
C
C     ANS=TRANSPOSE(CCF)*ANS
C
      CALL NTXNS0(CCF,ANS,ANS)
C
C     AR1=ANS*CCD+AR1
C
      CALL NSXNSA(ANS,CCD,AR1)
      RETURN
C
C     ** M=MXX **
C     ANS=TRANSPOSE(CCD)*AMM
C
   70 CALL NTXNS0(CCD,AMM,ANS)
C
C     AMM=ANS*CCD
C
      CALL NSXNS0(ANS,CCD,AMM)
C
C     ++ FOR LITTLE JOSEPH ++
C
      AMM(1,1)    =CORN(1,3)+AMM(1,1)
      AMM(NXX,NXX)=CORN(1,4)+AMM(NXX,NXX)
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE CC2SUB(ANZ,CCZ)
C
C          ENTRY CC2ADD (ANZ,CCZ)
C
      PARAMETER (MDIM=35,NDIM=35)
C
      DIMENSION ANZ(NDIM,NDIM),CCZ(4,4,2)
C
      COMMON /S2NODE/ MXX,NXX,DXM,DYN,XM(MDIM),YN(NDIM),XMC(MDIM),
     1                 YNC(NDIM),COSYN(NDIM)
C
      SAVE

C-----------------------------------------------------------------------

C
      ENTRY CC2SAV(ANZ,CCZ)
C
C     PUT 2 DIMENSIONED ANZ INTO 3 DIMENSIONED CCZ
C
      N0=NXX-4
C
      CCZ(:,:,1)=ANZ(1:4,1:4)
      CCZ(:,:,2)=ANZ(N0+1:N0+4,N0+1:N0+4)
C
      RETURN

C-----------------------------------------------------------------------

C
      ENTRY CC2ADD(ANZ,CCZ)
C
C     ANZ=ANZ=CCZ
C
      DO I=1,4
      DO J=1,4
      ANZ(I,J)=ANZ(I,J)+CCZ(I,J,1)
      ANZ(I+N0,J+N0)=ANZ(I+N0,J+N0)+CCZ(I,J,2)
      ENDDO
      ENDDO
C
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE MLXN9A(AML,AN9,ANS,MRZ)
C
C     ANS=AML*AN9*ANS, THE PARTS OF WHICH DEPEND ON MRZ
C
      PARAMETER (NDIM=35)
C
C     ** SECONDARY PARAMETERS FOR COMPILATION
C
      PARAMETER (NSDIM=NDIM*NDIM)
      COMMON /MADCON/ MAD1,MADX,MAD,MM0,MR1,MR2,MR3,ML1,ML2,ML3,MRX,MLX
C
      SAVE
C
C     DUMMY ARGUMENTS
C
      DIMENSION AML(NSDIM,3,3),AN9(NSDIM,3,3),ANS(NSDIM)
C
C     ** THE OUTPUT WILL BE IN ANS
C
      GO TO (14,13,12,11),MLX+1
   11 CALL NSXNSA(AML(:,MM0,ML3),AN9(:,ML3,MRZ),ANS)
   12 CALL NSXNSA(AML(:,MM0,ML2),AN9(:,ML2,MRZ),ANS)
   13 CALL NSXNSA(AML(:,MM0,ML1),AN9(:,ML1,MRZ),ANS)
   14 RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE PASSUB(NXX,BR,BS,CS)
C
C     ** COLLECTION OF N-MATRIX ROUTINES FOR SPLEFSK
C     ** PASDXX MUST BE CALLED, ONCE FOR ALL,
C        BEFORE ANY ENTRIES, BELOW, ARE CALLED.
C  ++++++++ THE LIST OF N-MATRIX ROUTINES ++++++++
C    SUB NAMES   ENTRY NAMES            OPERATIONS
C     PASDXX     NRTOS0(BR,CS)          CS=   BR
C                NEGINV(BS,CS)          CS=-INV(BS)
C     PASDSS     NSXNSA(AS,BS,CS)       CS=AS*BS+CS
C                NSXNS0(AS,BS,CS)       CS=AS*BS
C                NTXNSA(AS,BS,CS)       CS=TP(AS)*BS+CS
C                NTXNS0(AS,BS,CS)       CS=TP(AS)*BS
C                NSTOS0(BS,CS)          CS=   BS
C                NSTPS0(AS,CS)          CS=TP(AS)
C                CLRANS (CS)            CS=0.
C                 .. VARIANTS IN ADDRESS SHARING ..
C                NS0XNS(BS,AS,CS)       CS=BS*AS
C     PASDRR     ANRTOD (BR,CD)         CD=   BR
C         AS,BS,CS  NDIM*NDIM SQUARE MATRICES
C            BR,CR  NDIM*4 RECTANGLE MATRICES
C               CD  NDIM*7 RECTANGLE MATRICES (DOUBLE R)
C         CS,CR,CD  ARE ALWAYS THE OUTPUT
C         BS OR BR  MAY SHARE THE SAME ADDRESS WITH CS OR CR, RESPECTIVE
C               AS  MUST HAVE ITS OWN ADDRESS DIFFERENT FROM BS,BR,CS,OR
C     ** WORK SPACE IS PROVIDED LOCALLY FOR
C         ZS(NDIM,NDIM) AND ZD(NDIM,7) IN PASDXX
C         ZV(NDIM)                     IN PASDSS
C     ** DO INDEX CONSTANTS ARE GENERATED IN /PASDCC/ BY PASDXX
C
      PARAMETER (NDIM=35)
C
      SAVE
C
C     DUMMY ARGUMENTS
C
      DIMENSION BS(NDIM,NDIM),CS(NDIM,NDIM),BSD(NDIM,NDIM)
      DIMENSION BR(NDIM,4)   ,CSD(NDIM,NDIM)
C
      DOUBLE PRECISION BSD,CSD,DET
C
C     LOCAL WORK SPACE
C
      DIMENSION ZD(NDIM,7)
C
      COMMON /PASDCC/ IXX,IX,IX1,IX2
C
C-----------------------------------------------------------------------

C
C     ENTRY PASDXX(NXX)    ... MUST BE CALLED TO DEFINE DO INDEX CONSTAN
C     NXX IS THE NUMBER OF NODAL INTERVALS IN THE Y-DIRECTION
C
      ENTRY PASDXX(NXX)
      IXX=NXX
      IX =IXX-1
      IX1=IX-1
      IX2=IX-2
      IF(NXX.LE.NDIM) RETURN
      WRITE(6,800) NXX,NDIM
  800 FORMAT(/' === PASDXX FOUND NXX .GT. NDIM ===',3X,2I6)
      CALL ABRT1(' PASDXX',800)

C-----------------------------------------------------------------------

C
      ENTRY NRTOS0(BR,CS)
C
C     CS=BR
C
      CALL ANRTOD (BR,ZD)
C
      DO I=1,IXX
         CS(I,1:IXX)=0.
         DO J=MAX(I-3,1),MIN(I+3,IXX)
            CS(I,J)=ZD(I,J+4-I)
         ENDDO
      ENDDO
C
      RETURN

C-----------------------------------------------------------------------

C
      ENTRY NEGINV(BS,CS)
C
C     COPY BS INTO DOUBLE PRECISION ARRAY
C
      BSD(1:IXX,1:IXX)=BS(1:IXX,1:IXX)
C
C     CSD=INV(BSD)
C
      CALL INVMTX(BSD,NDIM,CSD,NDIM,IXX,DET,ZD,IER)
      IF(IER.GT.1) GO TO 54
C
      CS(1:IXX,1:IXX)=-CSD(1:IXX,1:IXX)
C
      RETURN
   54 WRITE(6,854) IER,DET
  854 FORMAT(/' === NEGINV/INVMTX FOUND BS TO BE SINGULAR.   IER=',I2,
     1    3X,D12.3)
      CALL ABRT1(' NEGINV',854)
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE PASDSS(AS,BS,CS)
      PARAMETER (NDIM=35)
C
      SAVE
C
C     DUMMY ARGUMENTS
C
      DIMENSION AS(NDIM,NDIM),BS(NDIM,NDIM),CS(NDIM,NDIM)
C
C     LOCAL WORK SPACE
C
      DIMENSION ZV(NDIM)
C
      COMMON /PASDCC/ IXX,IX,IX1,IX2

C-----------------------------------------------------------------------

C
      ENTRY NSXNSA(AS,BS,CS)
C
C     CS=AS*BS+CS
C
      DO J=1,IXX
         ZV(1:IXX)=CS(1:IXX,J)
         DO K=1,IXX
            DO I=1,IXX
               ZV(I)=AS(I,K)*BS(K,J)+ZV(I)
            ENDDO
         ENDDO
         CS(1:IXX,J)=ZV(1:IXX)
      ENDDO
C
      RETURN

C-----------------------------------------------------------------------

C
      ENTRY NSXNS0(AS,BS,CS)
C
C     CS=AS*BS
C
      DO J=1,IXX
         ZV(1:IXX)=0.
         DO K=1,IXX
            DO I=1,IXX
               ZV(I)=AS(I,K)*BS(K,J)+ZV(I)
            ENDDO
         ENDDO
         CS(1:IXX,J)=ZV(1:IXX)
      ENDDO
C
      RETURN

C-----------------------------------------------------------------------

C
      ENTRY NTXNSA(AS,BS,CS)
C
C     CS=TRANSPOSE(AS)*BS+CS
C
      DO J=1,IXX
         ZV(1:IXX)=CS(1:IXX,J)
         DO K=1,IXX
            DO I=1,IXX
               ZV(I)=AS(K,I)*BS(K,J)+ZV(I)
            ENDDO
         ENDDO
         CS(1:IXX,J)=ZV(1:IXX)
      ENDDO
C
      RETURN

C-----------------------------------------------------------------------

C
      ENTRY NTXNS0(AS,BS,CS)
C
C     CS=TRANSPOSE(AS)*BS
C
      DO J=1,IXX
         ZV(1:IXX)=0.
         DO K=1,IXX
            DO I=1,IXX
               ZV(I)=AS(K,I)*BS(K,J)+ZV(I)
            ENDDO
         ENDDO
         CS(1:IXX,J)=ZV(1:IXX)
      ENDDO
C
      RETURN

C-----------------------------------------------------------------------

C
      ENTRY NSTOS0(BS,CS)
C
C     PUT BS INTO CS
C
      CS(1:IXX,1:IXX)=BS(1:IXX,1:IXX)
C
      RETURN

C-----------------------------------------------------------------------

C
      ENTRY NSTPS0(AS,CS)
C
C     CS=TRANSPOSE(AS)
C
      DO J=1,IXX
         CS(1:IXX,J)=AS(J,1:IXX)
      ENDDO
C
      RETURN

C-----------------------------------------------------------------------

C
      ENTRY CLRANS (CS)
C
      CS(1:IXX,1:IXX)=0.
C
      RETURN

C-----------------------------------------------------------------------

C
      ENTRY NS0XNS(BS,AS,CS)
C
C     CS=AS*BS
C
      DO I=1,IXX
         ZV(1:IXX)=0.
         DO K=1,IXX
            DO J=1,IXX
               ZV(J)=BS(I,K)*AS(K,J)+ZV(J)
            ENDDO
         ENDDO
         CS(I,1:IXX)=ZV(1:IXX)
      ENDDO
C
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE ANRTOD (BR,CD)
      PARAMETER (NDIM=35)
C
      SAVE
C
C
      DIMENSION BR(NDIM,4),CD(NDIM,7)
      COMMON /PASDCC/ IXX,IX,IX1,IX2
C
C
C      EXPAND BR TO DOUBLE RECTANGLE ARRAY, CD(NDIM,7)
C     ** THE UN-USED CORNERS OF CD ARE NOT CLEARED.
C
      CD(1:IXX,4:7)=BR(1:IXX,:)
C
      DO J=1,3
         DO I=5-J,IXX
            CD(I,J)=BR(I+J-4,5-J)
         ENDDO
      ENDDO
C
C
C     ADD OR SUBTRACT ANTISYMMETRIC TERMS
C
      CD(1,5)=CD(1,5)+CD(IXX,6)
      CD(2,3)=CD(2,3)-CD(IXX,6)
      CD(IXX-1,5)=CD(IXX-1,5)+CD(IXX-1,7)
      CD(IXX  ,3)=CD(IXX  ,3)-CD(IXX-1,7)
      RETURN

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
C                 SLIMBO **   06/11/84
C                             SLICCO ADDED FOR CORNER CONDITIONS
C                             SPTIKA ADDED.   TESTING ROUTINES REMOVED
C                             PAST REV. 04/04,09,17,20/79
C                             PAST REV. 05/01,08/,06/01/,07/31/79
C     ++ ASSUMED DIM PARAMETERS ... MDIM=47...NDIM=35, LDXDIM=8000,
C                               ... KDXDIM=KDTDIM*KLDIM KDTDIM=5
C
      SUBROUTINE SLIMBO(FD,KP1,KP2,A)
C
C     ** NODAL SPLINE AMPLITUDES A(K,M,N) FROM DATA FD(K,L)**
C     ** MODIFIED FOR CORNER CONDITIONS (OCT 79)
C
      PARAMETER (MDIM=35,NDIM=35)
      PARAMETER (LDXDIM=8000)
      PARAMETER (KLDIM= 8)
      PARAMETER (KDTDIM=5)
      PARAMETER (KDXDIM=KDTDIM*KLDIM)
C
C     ** SECONDARY PARAMETERS FOR COMPILATION
C
      PARAMETER (NSDIM=NDIM*NDIM)
C
C     ** DUMMY ARGUMENTS
C
      SAVE
C
      DIMENSION FD(KDXDIM,LDXDIM),A(KDXDIM,MDIM,NDIM)
C
C     INPUT    MSKEF     DISK UNIT FROM WHICH MATRIX COEFFICIENTS ARE RE
C              FD(K,L)   K-TH COMPONENT OF FIELD DATA AT LOCATION L
C              KP1       FIRST COMPONENT K TO BE PROCESSED
C              KP2       LAST  COMPONENT K TO BE PROCESSED
C     OUTPUT   A(K,M,N)  NODAL AMPLITUDE OF K-TH COMPONENT AT NODE (M,N)
C     ** PREREQUISITES ... MAY BE SATISFIED BY CALLING SLEFCD(MSKEF)
C                          BEFORE ENTERING SLIMBO
C        $$ DISK UNIT MSKEF, PREVIOUSLY WRITTEN BY SLARGO
C             THE COMPATIBILITY AND IDENTITY MAY BE TESTED BY
C             CALLING SLEFCD
C        $$ SLOVER WAS CALLED TO DEFINE CONSTANTS IN SEVERAL COMMONS
C        $$ DATA POINTS WERE DEFINED IN /S2DTPT/ INCLUDING WEIGHTS
C     ** EXPLICITLY REQUIRED COMMONS
C
      COMMON /S2NODE/ MXX,NXX,DXM,DYN,XM(MDIM),YN(NDIM),XMC(MDIM),
     1                 YNC(NDIM),COSYN(NDIM)
      COMMON/S2DTPT/IDSPD1,IDSPD2,LDX,XD(LDXDIM),YD(LDXDIM),WD(LDXDIM),
     1               ID(LDXDIM),LXSORT(LDXDIM)
      COMMON /S2EFRM/ MEF,ANS(NSDIM,3)
C
      CHARACTER*8 IDSPD1,IDSPD2*72
C
C     ** EQUIVALENT ARRAYS FOR EASE OF INDEXING AND INTERPRETATION
C
      DIMENSION AML(NDIM,NDIM,3),D(NDIM,NDIM),EML(NDIM,NDIM,2),
     1          EMR(NDIM,NDIM,3)
C
      EQUIVALENCE (ANS(1,1),AML(1,1,1),D(1,1),EMR(1,1,1)),
     1            (ANS(1,2),EML(1,1,1))
C
C     +++ ALL MATRICES, INCLUDING AML, ARE NSDIM SQUARE MATRICES +++
C     ** LOCAL WORK SPACE
C
      DIMENSION ZV(NDIM,KDXDIM),B1(NDIM),B2(NDIM),B3(NDIM),
     1          BV(NDIM,3,KDXDIM)
C
      IZERO = 0
      INSEC = ISECND(IZERO)
c && 2 comments
CC    WRITE(6,800) INSEC
CC800 FORMAT(/' === SLIMBO BEGINS ===',T91,'SECOND=',I6)
C
C     ** INITIALIZATION
C
      CALL SLEFR0
      KA=MIN(KP1,KP2)
      KB=MAX(KP1,KP2)
      IF(KB.GT.KDXDIM) GO TO 90
C
      A(KA:KB,1:MXX,1:NXX)=0.
C
      CALL SLICCO(KA,KB,MXX,NXX)
C
C     ** CONSTANTS FOR CONVENIENCE
C
      XM1=XM(1)
      YN1=YN(1)
      DX0=1./DXM
      DY0=1./DYN
C
C     ** CONVERSION OF DISCRETE FIELD DATA TO NODAL FORCING **
C
      DO 18 L=1,LDX
      IF(WD(L) .LE. 0.0) GO TO 18
      MA=MAX(INT((XD(L)-XM1)*DX0),1)
      NA=MAX(INT((YD(L)-YN1)*DY0),1)
      MB=MIN(MA+3,MXX)
      NB=MIN(NA+3,NXX)
      DO M=MA,MB
         WM=WD(L)
         WM=WM*XBF(M,XD(L))
         DO N=NA,NB
            WMN=WM*YBF(N,YD(L))
            DO K=KA,KB
               A(K,M,N)=A(K,M,N)+WMN*FD(K,L)
            ENDDO
         ENDDO
      ENDDO
   18 CONTINUE
C
C
C     ** ADJUST THE NODAL FORCING FOR CORNERING
C
      CALL SLICCB(A)
C
C     ** CONVERSION OF NODAL FORCING TO NODAL AMPLITUDES **
C       +++ WE RETURN TO THE RIGHT-HANDED FORCING +++
C       +++ THE LEFT-HANDED CONVENTION IN PLIB SPLEND IS NOT USED +++
C     ** FORWARD TRICYCLING **
C
      BV(1:NXX,:,KA:KB)=0.
C
      DO M=1,MXX
         CALL SLEFRA(M)
         DO 22 K=KA,KB
         ZV(1:NXX,K)=-A(K,M,1:NXX)
         DO ML=1,MIN(M-1,3)
            DO NN=1,NXX
               DO  N=1,NXX
                  ZV(N,K)=AML(N,NN,ML)*BV(NN,ML,K)+ZV(N,K)
               ENDDO
            ENDDO
         ENDDO
   22    CONTINUE
         CALL SLEFRF(M)
         DO K=KA,KB
            B1(1:NXX)=0.
            DO NN=1,NXX
               DO N=1,NXX
                  B1(N)=D(N,NN)*ZV(NN,K)+B1(N)
               ENDDO
            ENDDO
            B2(1:NXX)=BV(1:NXX,1,K)
            B3(1:NXX)=BV(1:NXX,2,K)
            DO NN=1,NXX
               DO N=1,NXX
                  B2(N)=EML(N,NN,1)*B1(NN)+B2(N)
                  B3(N)=EML(N,NN,2)*B1(NN)+B3(N)
               ENDDO
            ENDDO
            BV(1:NXX,3,K)=B3(1:NXX)
            BV(1:NXX,2,K)=B2(1:NXX)
            BV(1:NXX,1,K)=B1(1:NXX)
            A(K,M,1:NXX)=B1(1:NXX)
         ENDDO
      ENDDO
C
C     ** BACKTRACKING **
C        +++ UNBROKEN MULTIPLE DO DID NOT VECTORIZE +++
C
      DO M=MXX,1,-1
         CALL SLEFRE(M)
         DO K=KA,KB
            B1(1:NXX)=A(K,M,1:NXX)
            DO MR=1,MIN(MXX-M,3)
               DO NN=1,NXX
                  DO N=1,NXX
                     B1(N)=EMR(N,NN,MR)*A(K,M+MR,NN)+B1(N)
                  ENDDO
               ENDDO
            ENDDO
            A(K,M,1:NXX)=B1(1:NXX)
         ENDDO
      ENDDO
C
C     ** FIX THE FLOATED CORNER AMPLITUDES
C
      CALL SLICCA(A)
      IDELTA = ISECND(INSEC)
      WRITE(6,880) IDELTA
  880 FORMAT(' === SLIMBO DONE ===',T91,'ELAPSED TIME=',I6)
      RETURN
C
C     ** ERROR EXIT
C
   90 WRITE(6,890) KP1,KP2,KDXDIM
  890 FORMAT(/' === SLIMBO FOUND THE COMPONENT RANGE  K=',I2,',',I2,
     1    '  EXCEEDED KDXDIM=',I2)
      CALL ABRT1(' SLIMBO',890)
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE SLISUB(KP1,KP2,MXXZ,NXXZ,A,B)
C
C          ENTRY SLICCO(KP1,KP2,MXXZ,NXXZ)
C          ENTRY SLICCB(B)
C          ENTRY SLICCA(A)
C
      PARAMETER (MDIM=35,NDIM=35)
      PARAMETER (KLDIM= 8)
      PARAMETER (KDTDIM=5)
      PARAMETER (KDXDIM=KDTDIM*KLDIM)
C
      SAVE
C
      DIMENSION A(KDXDIM,MDIM,NDIM),B(KDXDIM,MDIM,NDIM)
      COMMON /S2CORN/ CORN(4,4)

C-----------------------------------------------------------------------

C
      ENTRY SLICCO(KP1,KP2,MXXZ,NXXZ)
C     ++ INITIALIZE CONSTANTS FOR SLICCB AND SLICCA ENTRIES
C        /S2CORN/ MUST HAVE BEEN DEFINED BY SLOVER, OR BY SLEFCD
C
      KA=KP1
      KB=KP2
      MXX=MXXZ
      NXX=NXXZ
      RETURN

C-----------------------------------------------------------------------

C
C     ** ADJUST NODAL FORCING, B, FOR CORNERING
C
      ENTRY SLICCB(B)
C
      DO 19 KORN=1,4
      IF(CORN(1,KORN).EQ.0.) GO TO 19
      GO TO (11,11,12,12),KORN
   11 MA=1
      MB=2
      GO TO 13
   12 MA=MXX
      MB=MXX-1
   13 GO TO (14,15,14,15),KORN
   14 NA=1
      NB=2
      GO TO 16
   15 NA=NXX
      NB=NXX-1
   16 CONTINUE
      DO K=KA,KB
         B(K,MA,NB)=CORN(2,KORN)*B(K,MA,NA)+B(K,MA,NB)
         B(K,MB,NA)=CORN(3,KORN)*B(K,MA,NA)+B(K,MB,NA)
         B(K,MB,NB)=CORN(4,KORN)*B(K,MA,NA)+B(K,MB,NB)
      ENDDO
      B(KA:KB,MA,NA)=0.
   19 CONTINUE
C
      RETURN

C-----------------------------------------------------------------------

C
C     ** FIX THE FLOATED CORNER AMPLITUDES
C
      ENTRY SLICCA(A)
C
      DO 38 KORN=1,4
      IF(CORN(1,KORN).EQ.0.) GO TO 38
      GO TO (31,31,32,32),KORN
   31 MA=1
      MB=2
      GO TO 33
   32 MA=MXX
      MB=MXX-1
   33 GO TO (34,35,34,35),KORN
   34 NA=1
      NB=2
      GO TO 36
   35 NA=NXX
      NB=NXX-1
   36 DO 37 K=KA,KB
      A(K,MA,NA)=CORN(2,KORN)*A(K,MA,NB)+CORN(3,KORN)*A(K,MB,NA)
     1                                  +CORN(4,KORN)*A(K,MB,NB)
   37 CONTINUE
   38 CONTINUE
C
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE SPLEFR(M)
      PARAMETER (NDIM=35)
      PARAMETER (LDXDIM=8000)
C
C     ** SECONDARY PARAMETERS FOR COMPILATION
C
      PARAMETER (NSDIM=NDIM*NDIM)
C
C     ** OUT FROM SLEFCD(MSKEF).../S2PRIC/ AND S2DTPT/ ARE DEFINED,
C                                  SLOVER IS CALLED, AND MSKEF IS READIE
C
CIBM  COMMON /S2PRIC/ IDSPC,ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,
CIBM 1                 YNB,YNT,XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4)
      COMMON /S2PRIC/ ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,YNB,YNT,
     1                 XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4),IDSPC
      COMMON/S2DTPT/IDSPD1,IDSPD2,LDX,XD(LDXDIM),YD(LDXDIM),WD(LDXDIM),
     1               ID(LDXDIM),LXSORT(LDXDIM)
      COMMON /DSK/MSKEF,MSKEZ,MSKDA1,MSKDA2,MSKDA3,MSKDA4,MSKDA5,MSKDA6,
     1            MSKDA7,MSKDA8,MSKDA9,MSKD11,MSKD12,MSKD13,
     2            MSKD14,MSKD15,MSKD16,MSKD17,MSKD18
C
      CHARACTER*8 IDSPD1,IDSPD2*72,IDSPC*125,IDSPCZ*125,KENTRY*7
C
C     ** OUT FROM SLEFR0(MSKEF)...NONE BUT MSKEF IS READIED
C     ** OUT FORM SLEFRA(M)     ...AML MATRICES TO /S2EFRM/
C     $$ OUT FROM SLEFRF(M)     ...D AND EML MATRICES TO /S2EFRM/
C     ** OUT FROM SLEFRE(M)     ...EMR MATRICES TO /S2EFRM/
C
      COMMON /S2EFRM/ MEF,ANS(NSDIM,3)
C
C     ** LOCAL SPACE
C
      CHARACTER*8 IDZ
C
      SAVE
C
      DIMENSION IDZ(12)
C
      DATA KENTRY/' SPLEFR'/

C-----------------------------------------------------------------------

C
      ENTRY SLEFCD
      REWIND MSKEF
      READ(MSKEF) IDZ,IDSPCZ,ISRCD,JPD,MX,NX,KDCTYP,KBCTYP,XM1,XMXX,
     1            YN1,YNXX,XYDCWL,XYBCWL,IDSPD1,IDSPD2,LDX
      IF(LDX.LE.0 .OR. LDX.GT.LDXDIM) GO TO 91
C      DECODE(8,812,IDZ(5)) NDIMEF
      READ(IDZ(5),812)  NDIMEF
      READ(IDZ(6),812)  LDXDEF
  812 FORMAT(I8)
      IF(IDSPCZ .NE. IDSPC)  THEN
      WRITE(6,813)  IDSPC,IDSPCZ
  813 FORMAT('....WARNING: IDSPC AND IDSPCZ ARE NOT THE SAME, ERRORS',
     1       ' RELATED TO STORM POSITION MAY OCCUR',/,
     2       '  ...IDSPC=',A125,/,'  ...IDSPCZ=',A125)
      ENDIF
      IF(NDIMEF.NE.NDIM) GO TO 92
      IF(LDXDEF .NE. LDXDIM)  GO TO 93
      BACKSPACE (MSKEF,ERR=96)
      READ(MSKEF) IDZ,IDSPCZ,ISRCD,JPD,MX,NX,KDCTYP,KBCTYP,XM1,XMXX,YN1,
     1            YNXX,XYDCWL,XYBCWL,IDSPD1,IDSPD2,LDX,XD,YD,WD,ID,XML,
     1            XMR,YNB,YNT
      WRITE(6,815) MSKEF,IDZ
  815 FORMAT(/' ===  SLEFCD (MSKEF=',I4,') HAS DEFINED /S2PRIC/ AND '
     1   ,'/S2DTPT/.',/,5X,'...',12A8,/,6X,'SLOVER WILL BE CALLED')
      CALL SLOVER
      RETURN

C-----------------------------------------------------------------------

C
      ENTRY SLEFR0
      REWIND MSKEF
      READ(MSKEF) IDZ
c && 3 comments
CC    WRITE(6,825) MSKEF
CC825 FORMAT(/' === SLEFR0(MSKEF=',I4,') DONE.  NO CHANGES IN '
CC   1   ,'/S2PRIC/ OR /S2DTPT/.  NO CHECKS ON LDX OR NDIM.')
      RETURN

C-----------------------------------------------------------------------

C
      ENTRY SLEFRA(M)
      KENTRY='SLEFRA'
      GO TO 40

C-----------------------------------------------------------------------

C
      ENTRY SLEFRF(M)
      KENTRY='SLEFRF'
   40 CONTINUE
      READ(MSKEF) MEF,ANS
      IF(M.NE.MEF) GO TO 95
      RETURN

C-----------------------------------------------------------------------

C
      ENTRY SLEFRE(M)
      KENTRY='SLEFRE'
      READ(MSKEF) MEF,ANS
      IF(M+MEF.NE.0) GO TO 95
      RETURN
C
C     ** ERROR EXITS
C
   91 WRITE(6,891) MSKEF,LDX,LDXDIM,IDZ
  891 FORMAT(/' === SLEFCD FOUND LDX FROM MSKEF=',I4,' IS .LE. ZERO, ',
     1    'OR, .GT. THE CURRENT LDXDIM.',2I6,/,5X,I7,'...',12A8)
      GO TO 99
   92 WRITE(6,892) MSKEF,NDIMEF,NDIM,IDZ
  892 FORMAT(/' === SLEFCD FOUND NDIM FROM MSKEF=',I4,' DOES NOT',
     1       ' AGREE WITH THE CURRENT NDIM.  FATAL.',5X,2I4,/,5X,12A8)
      GO TO 99
   93 WRITE(6,893) MSKEF,LDXDEF,LDXDIM,IDZ
  893 FORMAT(/' === SLEFCD FOUND LDXDIM FROM MSKEF=',I4,' DOES NOT',
     1       ' AGREE WITH THE CURRENT NDIM.  FATAL.',5X,2I4,/,5X,12A8)
      GO TO 99
   95 WRITE(6,895) KENTRY,M,MEF,MSKEF
  895 FORMAT(' === ',A7,' FOR M=',I3,' MET  MEF=',I4,
     1    '  IN READING MSKEF=',A8)
      CALL MSKDMP(MSKEF)
      GO TO 99
   96 WRITE(6,896) MSKEF
  896 FORMAT(/' ... BACKSPACE ERROR ON ',Z8)
   99 CALL ABRT1(KENTRY,896)
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE SPLINT (A,KPA,F,KPFDIM,MFDIM,NFDIM,KPF,M1,M2,M3,N1,N2,
     1                   N3,ZXBF,ZYBF,ISFIN,ISFAC)
      PARAMETER (MDIM=35,NDIM=35)
      PARAMETER (KLDIM= 8)
      PARAMETER (KDTDIM=5)
      PARAMETER (KDXDIM=KDTDIM*KLDIM)
C
      SAVE
C
C     ** DUMMY ARGUMENTS
C     ** INPUT ... SPLINE AMPLITUDE
C
      DIMENSION A(KDXDIM,MDIM,NDIM)
C
C     ** OUTPUT ..
C
      DIMENSION F(KPFDIM,MFDIM,NFDIM)
C
C     ** PARAMETER FOR THE LOCAL USE ... MAXIMUM DIVISIONS ALLOWED
C
      PARAMETER (IXBFDM=8,JXBFDM=8)
C
C     ** LOCAL ARRAYS ... BF TABLES
C
      DIMENSION XB1(4,IXBFDM),XBM(4,IXBFDM),XBX(4,IXBFDM),XBXX(4)
      DIMENSION YB1(4,JXBFDM),YBN(4,JXBFDM),YBX(4,JXBFDM),YBXX(4)
C
C     ** LOCAL WORK SPACE
C
      DIMENSION ZAB(MDIM,NDIM)
C
      CHARACTER*7 KENTRY
      COMMON /S2NODE/ MXX,NXX,DXM,DYN,XM(MDIM),YN(NDIM),XMC(MDIM),
     1                 YNC(NDIM),COSYN(NDIM)
C
      DATA KENTRY/' SPLINT'/
C
C-----------------------------------------------------------------------

C
      ENTRY SLINTA(A,M1,M2,M3,N1,N2,N3)
      KENTRY = 'SLINTA'
C
C     LOCALLY DEFINED
C
      MX=MXX-1
      MX1=MX-1
      NX=NXX-1
      NX1=NX-1
      IF(MXX.GT.MDIM) GO TO 900
      IF(NXX.GT.NDIM) GO TO 900
C
C     ** SET CONSTANTS FOR DEFINING THE AREA AND SUBDIVISIONS
C
      MA=MIN(M1,M2)
      MB=MAX(M1,M2)
      IX=MAX(M3,1)
      NA=MIN(N1,N2)
      NB=MAX(N1,N2)
      JX=MAX(N3,1)
      IF(MA.LT.1)   GO TO 901
      IF(MB.GT.MXX) GO TO 901
      IF(NA.LT.1)   GO TO 901
      IF(NB.GT.NXX) GO TO 901
      IF(IX.GT.IXBFDM) GO TO 905
      IF(JX.GT.JXBFDM) GO TO 905
      MAOL=MAX(MA-1,1)
      MBOL=MIN(MB+1,MXX)
      MAIL=MAX(MA,2)
      NAIL=MAX(NA,2)
      MBIL1=MIN(MB,MX1)
      MBIL2=MIN(MB-1,MX1)
      NBIL1=MIN(NB,NX1)
      NBIL2=MIN(NB-1,NX1)
C
C     ** MINIMUM DIMENSIONS REQUIRED OF THE OUTPUT FIELD
C
      MFDIM0=IX*(MB-MA)+1
      NFDIM0=JX*(NB-NA)+1
C
C     ** SET THE IN AND OUT SWITCHES TO THE NORMAL POSITIONS
C
      lsfin = 83
      lsfout = 320
C
C     ** ROUTING DECISIONS
C
      lgon1 = 120
      lgonx = 150
      lgom1 = 220
      lgomx = 250
      IF(NA.EQ.1)   lgon1 = 110
      IF(NB.EQ.NXX) then
         lgonx = 126
      else  IF(NB.EQ.NX)  then
         lgonx = 128
      endif
      IF(MA.EQ.1)   lgom1 = 210
      IF(MB.EQ.MXX)  then
         lgomx = 226
      else  IF(MB.EQ.MX)  then
         lgomx = 228
      end if
      RETURN

C-----------------------------------------------------------------------

C
C     ** INPUT ... THE SPLINE BASIS FUNCTIONS
C     ZXBF     XBF,DXBF, OR DDXBF
C     ZYBF     YBF,DYBF, OR DDYBF
C     ** ** ** WARNING ** ** **
C     THERE IS NO DEFAULT SETTING OF ZXBF OR ZYBF.
C     SLINTD MUST BE CALLED, AT LEAST ONCE, TO DEFINE THE BF TABLES
C     ** WARNING **
C       DO NOT SHORTCUT SLINTD WITHIN THIS SUBROUTINE ALTHOUGH IT MAY
C       SEEM TO BE UNNECESSARY WHEN M3,N3 ARE UNCHANGED.
C       SINCE ZXBF OR ZYBF MAY BE CHANGED, ONLY THE CALLING ROUTINE
C       CAN DETERMINE THE NEED OF CALLING SLINTD ANEW.
C       SIMILARLY, THE TEST OF M3,N3 BY SLINTO IS NO GUARANTEE FOR
C       CORRECT BF TABLES, IF THERE WERE OMISSION OF CALLING SLINTD.
C
      ENTRY SLINTD(ZXBF,ZYBF)
C
C     ** SAVE THE CURRENT IX(=M3) AND JX(=N3)
C
      IXBF0=IX
      JXBF0=JX
      DXMI=DXM/REAL(IX)
      DYNJ=DYN/REAL(JX)
C
      DO I=1,IX
      XMI=(I-1)*DXMI
      DO MD=0,2
         XB1(2+MD,I)=ZXBF(1+MD,XM(1)+XMI)
      ENDDO
      DO MD=-1,2
         XBM(2+MD,I)=ZXBF(3+MD,XM(3)+XMI)
      ENDDO
      DO MD=-1,1
         XBX(2+MD,I)=ZXBF(MX+MD,XM(MX)+XMI)
      ENDDO
      ENDDO
C
      DO MD=-1,0
         XBXX(2+MD)=ZXBF(MXX+MD,XM(MXX))
      ENDDO
C
      DO J=1,JX
      YNJ=(J-1)*DYNJ
      DO ND=0,2
         YB1(2+ND,J)=ZYBF(1+ND,YN(1)+YNJ)
      ENDDO
      DO ND=-1,2
         YBN(2+ND,J)=ZYBF(3+ND,YN(3)+YNJ)
      ENDDO
      DO ND=-1,1
         YBX(2+ND,J)=ZYBF(NX+ND,YN(NX)+YNJ)
      ENDDO
      ENDDO
C
      DO ND=-1,0
         YBXX(2+ND)=ZYBF(NXX+ND,YN(NXX))
      ENDDO
C
      RETURN
C
C     ** INPUT ARGUMENTS
C     ISFIN=-1   SIGN OF INPUT F IS REVERSED (NOT CLEARED)
C          = 0   INPUT F IS CLEARED TO ZERO
C          = 1   INPUT F IS PASSED AS IS, TO BE ACCUMULATED UPON
C     ISFAC= 1   POSITIVE ACCUMULATION OF THE NEW F ON THE INPUT F
C          =-1   NEGATIVE ACCUMULATION OF THE NEW F ON THE INPUT F
C     NOTE ... LSFIN,LSFOUT DO NOT CORRESPOND TO ISFIN,ISFAC, INDIVIDUAL
C              SINCE LSFOUT FLIPS THE SIGN OF THE FINAL OUTPUT FIELD,
C              LSFIN MUST BE SET KNOWING WHAT LSFOUT WILL DO AT THE END
C     ++ SLINTO, WHEN EXECUTED, ALWAYS RESETS THE INTERNAL SWITCHES
C        TO  ISFIN=0 AND ISFAC=1.  SLINTS MUST BE CALLED EVERYTIME
C        WHEN DIFFERENT SETTINGS ARE DESIRED
C

C-----------------------------------------------------------------------

      ENTRY SLINTS(ISFIN,ISFAC)
      IF(ISFAC.LT.0) THEN
         GO TO 71
      ELSE
         GO TO 72
      ENDIF
C
C       FLIP THE SIGN OF THE OUTPUT FIELD
C
   71 CONTINUE
      lsfout = 310
C
      IF(ISFIN.LT.0) THEN
         GO TO 75
      ELSE  IF(ISFIN.EQ.0)  THEN
         GO TO 74
      ELSE
         GO TO 73
      ENDIF
C
C       PASS THE OUTPUT FIELD AS IS (THE NORMAL OUT SWITCH POSITION)
C
   72 CONTINUE
      lsfout = 320
      IF(ISFIN.LT.0) THEN
         GO TO 73
      ELSE  IF(ISFIN.EQ.0)  THEN
         GO TO 74
      ELSE
         GO TO 75
      ENDIF
C
C       FLIP THE SIGN OF THE INPUT FIELD
C
   73 CONTINUE
      lsfin = 81
      GO TO 78
C
C       CLEAR THE INPUT FIELD (THE NORMAL IN SWITCH POSITION)
C
   74 CONTINUE
      lsfin = 83
      GO TO 78
C
C       PASS THE INPUT FIELD AS IS
C
   75 CONTINUE
      lsfin = 85
   78 RETURN

C-----------------------------------------------------------------------

C
      ENTRY SLINTO(A,KPA,F,KPFDIM,MFDIM,NFDIM,KPF)
      KENTRY = 'SLINTO'
      KA=KPA
      KF=KPF
C
C     ** CHECK THE INPUT ARGUMENTS
C
      IF(KPA.GT.KDXDIM) GO TO 902
      IF(KPF.GT.KPFDIM) GO TO 910
      IF(MFDIM.LT.MFDIM0) GO TO 910
      IF(NFDIM.LT.NFDIM0) GO TO 910
      IF(IX.NE.IXBF0) GO TO 920
      IF(JX.NE.JXBF0) GO TO 920
C
C     ** THE IN SWITCH
C
      if(lsfin.eq.81)  then
         go to 81
      else if(lsfin.eq.83)  then
         go to 83
      else if(lsfin.eq.85)  then
         go to 85
      else
         call ABRT1(' SLINTO',81)
      endif
C
   81 CONTINUE
      DO M=1,MFDIM
         DO N=1,NFDIM
            F(KF,M,N)=-F(KF,M,N)
         ENDDO
      ENDDO
C
      GO TO 85
C
   83 CONTINUE

      F(KF,:,:)=0.
C
C     RESET THE IN SWITCH TO THE NORMAL POSITION ... CLEAR
C
   85 CONTINUE
      lsfin = 83
C
      DO J=1,JX
      IF((J-2).LT.0)  THEN
         GO TO 101
      ELSE  IF((J-2).EQ.0)  THEN
         GO TO 102
      ELSE
         GO TO 103
      ENDIF
C
C     ON THE N-NODES (J=1)
C
  101 NDX=1
      NBIL=NBIL1
      NBJ=NB
      GO TO 103
C
C     OFF-NODE FINE MESH POINTS
C
  102 NDX=2
      NBIL=NBIL2
      NBJ=NB-1
  103 CONTINUE
C
C     CLEAR THE ACCUMULATION WORK SPACE
C
      ZAB(MAOL:MBOL,NA:NB)=0.

      if(lgon1.eq.110)  then
         go to 110
      else  if(lgon1.eq.120)  then
         go to 120
      else
         call ABRT1(' SLINTO',110)
      endif
C
C     AT N=1. (FOR NA=1 ONLY)
C
  110 CONTINUE
      DO ND=0,NDX
         DO M=MAOL,MBOL
            ZAB(M,1)=A(KA,M,1+ND)*YB1(2+ND,J)+ZAB(M,1)
         ENDDO
      ENDDO
C
C     AT ALL N BETWEEN NAIL AND NBIL, BUT NBIL IS.LE. NX1
C     NOTE ... THE SECOND DO WILL NOT EXECUTE IF NAIL .GT. NBIL
C
  120 CONTINUE
      DO ND=-1,NDX
         DO N=NAIL,NBIL
            DO M=MAOL,MBOL
               ZAB(M,N)=A(KA,M,N+ND)*YBN(2+ND,J)+ZAB(M,N)
            ENDDO
         ENDDO
      ENDDO
C
C     CHECK THE LEFT LIMIT OF ACCUMULATION
C
      if(lgonx.eq.126)  then
         go to 126
      else  if(lgonx.eq.128)  then
         go to 128
      else  if(lgonx.eq.150)  then
         go to 150
      else
         call ABRT1(' SLINTO',126)
      endif

  126 IF(J.EQ.1) GO TO 130
      GO TO 140
  128 IF(J.EQ.1) GO TO 140
      GO TO 150
C
C     ONLY FOR J=1 AND NB=NXX
C
  130 CONTINUE
      DO ND=-1,0
         DO M=MAOL,MBOL
            ZAB(M,NXX)=A(KA,M,NXX+ND)*YBXX(2+ND)+ZAB(M,NXX)
         ENDDO
      ENDDO
C
C     FOR ALL J IF NB=NXX(ENTERS FROM 132)
C     ONLY FOR J=1 IF NB=NX
C
  140 CONTINUE
      DO ND=-1,1
         DO M=MAOL,MBOL
            ZAB(M,NX)=A(KA,M,NX+ND)*YBX(2+ND,J)+ZAB(M,NX)
         ENDDO
      ENDDO
  150 CONTINUE
      DO I=1,IX
      IF((I-2).LT.0)  THEN
         GO TO 201
      ELSE  IF((I-2).EQ.0)  THEN
         GO TO 202
      ELSE
         GO TO 203
      ENDIF
  201 MDX=1
      MBIL=MBIL1
      GO TO 203
  202 MDX=2
      MBIL=MBIL2
  203 CONTINUE
C
C     FOR SHORTHAND WRITING
C
      JZ=JX-J
      IZ=IX-I
      IMXXZ=IX*MXX-IZ
      IMXZ =IX*MX -IZ
C
C     ++ NBJ, BELOW, IS CORRECTION OF NB IN EARLIER VERSIONS (07/30/79)
C
      if(lgom1.eq.210)  then
         go to 210
      else  if(lgom1.eq.220)  then
         go to 220
      else
         call ABRT1(' SLINTO',210)
      endif
  210 CONTINUE
      DO MD=0,MDX
         DO N=NA,NBJ
            F(KF,I,JX*N-JZ)=ZAB(1+MD,N)*XB1(2+MD,I)+F(KF,I,JX*N-JZ)
         ENDDO
      ENDDO
  220 CONTINUE
      DO MD=-1,MDX
         DO M=MAIL,MBIL
            DO N=NA,NBJ
               F(KF,IX*M-IZ,JX*N-JZ)=ZAB(M+MD,N)*XBM(2+MD,I)
     1                                          +F(KF,IX*M-IZ,JX*N-JZ)
            ENDDO
         ENDDO
      ENDDO
      if(lgomx.eq.226)  then
         go to 226
      else  if(lgomx.eq.228)  then
         go to 228
      else  if(lgomx.eq.250)  then
         go to 250
      else
         call ABRT1(' SLINTO',226)
      endif
  226 IF(I.EQ.1) GO TO 230
      GO TO 240
  228 IF(I.EQ.1) GO TO 240
      GO TO 250
  230 CONTINUE
      DO MD=-1,0
         DO N=NA,NBJ
            F(KF,IMXXZ,JX*N-JZ)=ZAB(MXX+MD,N)*XBXX(2+MD)+
     1                                              F(KF,IMXXZ,JX*N-JZ)
         ENDDO
      ENDDO
  240 CONTINUE
      DO MD=-1,1
         DO N=NA,NBJ
            F(KF,IMXZ,JX*N-JZ)=ZAB(MX+MD,N)*XBX(2+MD,I)+
     1                                               F(KF,IMXZ,JX*N-JZ)
         ENDDO
      ENDDO
  250 CONTINUE
      ENDDO
      ENDDO
  300 CONTINUE
C
C     ** THE OUT SWITCH
C
      if(lsfout.eq.310)  then
         go to 310
      else if(lsfout.eq.320)  then
         go to 320
      else
         call ABRT1(' SLINTO',310)
      endif
C
  310 CONTINUE
      DO M=1,MFDIM
         DO N=1,NFDIM
            F(KF,M,N)=-F(KF,M,N)
         ENDDO
      ENDDO
C
C     RESET THE OUT SWITCH TO THE NORMAL POSITION (PASS AS IS)
C
      lsfout = 320
  320 CONTINUE
      RETURN
C
C     ** ERROR EXITS
C
  900 WRITE(6,8900) MXX,NXX,MDIM,NDIM
 8900 FORMAT(/' === SLINTA FOUND MXX,NXX TOO LARGE FOR MDIM,NDIM'
     1   ,5X,2I5,5X,2I5)
      GO TO 990
  901 WRITE(6,8901) M1,M2,N1,N2,MXX,NXX
 8901 FORMAT(/' === SLINTA INPUT ARGUMENTS M1,M2,N1,N2 ARE IN ERROR'
     1    ,5X,2I5,3X,2I5,5X,'MXX,NXX ARE',3X,2I5)
      GO TO 990
  902 WRITE(6,8902) KPA,KDXDIM
 8902 FORMAT(/' === SLINTO ARGUMENT KPA IS TOO LARGE FOR KDXDIM',5X,2I3
     1)
      GO TO 990
  905 WRITE(6,8905) M3,N3,IXBFDM,JXBFDM
 8905 FORMAT(/' === SLINTA INPUT ARGUMENTS M3,N3 ARE TOO LARGE FOR '
     1    ,'THE LOCAL PARAMETERS IXBFDM,JXBFDM',5X,2I3,5X,2I3)
      GO TO 990
  910 WRITE(6,8910) KPFDIM,MFDIM,NFDIM,MFDIM0,NFDIM0
 8910 FORMAT(/' === SLINTO ARGUMENTS KPFDIM,MFDIM,NFDIM ARE TOO SMALL '
     1   ,'FOR THE REQUIRED KPF,MFDIM0,NFDIM0', 5X,I3,2I5,5X,I3,2I5)
      GO TO 990
  920 WRITE(6,8920) IX,JX,IXBF0,JXBF0
 8920 FORMAT(/' === SLINTO FOUND M3,N3 HAVE BEEN CHANGED SINCE THE '
     1   ,'LAST CALL TO SLINTD WAS MADE',5X,2I3,5X,2I3)
      GO TO 990
  990 CALL ABRT1(KENTRY,8920)
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE SPTINO(X,Y,A,K1,K2,F)
C
      PARAMETER (MDIM=35,NDIM=35)
      PARAMETER (KLDIM= 8)
      PARAMETER (KDTDIM=5)
      PARAMETER (KDXDIM=KDTDIM*KLDIM)
C
      SAVE
C
C     ** ** SPOT INVERSE TRANSFORMATION OF SPLINE AMPLITUDES TO F AT X,Y
C       X,Y        THE SPOT COORDINATES AT WHICH OUTPUT F IS DESIRED
C       A(K,M,N)   KTH COMPONENT OF NODAL AMPLITUDE AT M,N
C       K1,K2      THE  RANGE OF COMPONENTS K OF THE AMPLITUDE (NOT OF O
C       F(KF)      THE SPOT OUTPUT F.  KF=1 FOR K=K1
C                                      KF=2 FOR K=K1+1,  TILL
C                                      KF=K2-K1+1 FOR K=K2
C     ** DUMMY ARGUMENTS
C
      DIMENSION A(KDXDIM,MDIM,NDIM)
cc dak 07/03/05      DIMENSION F(1)
      dimension f(*) ! dak 7/3/05: fix bounds-check error
      DIMENSION BM(4),BN(4),ZN(4)
C
      COMMON /S2NODE/ MXX,NXX,DXM,DYN,XM(MDIM),YN(NDIM),XMC(MDIM),
     1                 YNC(NDIM),COSYN(NDIM)
      EQUIVALENCE (XM(1),X1),(YN(1),Y1)
C
C     ** LOCAL WORK SPACE
C
      M0=MAX(INT((X-X1)/DXM),1)-1
      N0=MAX(INT((Y-Y1)/DYN),1)-1
      M4=MIN(MXX-M0,4)
      N4=MIN(NXX-N0,4)
C
      DO M=1,M4
         BM(M)=XBF(M+M0,X)
      ENDDO
C
      DO N=1,N4
         BN(N)=YBF(N+N0,Y)
      ENDDO
C
      KF=0
C
      DO K=K1,K2
         KF=KF+1
         ZN=0.
         DO M=1,M4
            DO N=1,N4
               ZN(N)=ZN(N)+BM(M)*A(K,M+M0,N+N0)*BN(N)
            ENDDO
         ENDDO
         F(KF)=ZN(1)+ZN(2)+ZN(3)+ZN(4)
      ENDDO
C
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE MSKDMP(MSK)
C
      REWIND MSK
      WRITE(6,810) MSK,MSK
  810 FORMAT(/' === MSKDMP WAS CALLED ON UNIT=',A8,2X,I3,//,3X,'CNT'
     1    ,'  UNT  LNGTH    WRD1 INT   WRD1 OCTAL',T59,'WRD2 OCTAL'
     2    ,T84,'WRD3 OCTAL',/)
      WRITE(6,10)
   10 FORMAT(/' .... DUMMY MSKDMP ROUTINE')
      CALL ABRT1(' MSKDMP',10)
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE SPTIKA(X,Y,A,K1,K2,F)
C
      PARAMETER (MDIM=35,NDIM=35)
      PARAMETER (KLDIM= 8)
      PARAMETER (KDTDIM=5)
      PARAMETER (KDXDIM=KDTDIM*KLDIM)
C
      SAVE
C
C     ** ** SPOT INVERSE TRANSFORMATION OF SPLINE AMPLITUDES TO F AT X,Y
C     ++ ++ THIS VERSION, SPTIKA, IS DIFFERENT FROM SPTINO IN SLIMBO,
C           IN THAT EXECUTION IS VECTORIZED WITH RESPECT TO KP.
C       X,Y        THE SPOT COORDINATES AT WHICH OUTPUT F IS DESIRED
C       A(K,M,N)   KTH COMPONET OF NODAL AMPLITUDE AT M,N
C       K1,K2      THE  RANGE OF COMPONENTS K OF THE AMPLITUDE (NOT OF O
C       F(KF)      THE SPOT OUTPUT F.  KF=1 FOR K=K1
C                                      KF=2 FOR K=K1+1,  TILL
C                                      KF=K2-K1+1 FOR K=K2
C     ** DUMMY ARGUMENTS
C
      DIMENSION A(KDXDIM,MDIM,NDIM)
cc dak 07/03/05      F(1)
      dimension f(*) ! dak 7/3/05: fix bounds-check error
      COMMON /S2NODE/ MXX,NXX,DXM,DYN,XM(MDIM),YN(NDIM),XMC(MDIM),
     1                 YNC(NDIM),COSYN(NDIM)
      EQUIVALENCE (XM(1),X1),(YN(1),Y1)
C
C     ** LOCAL WORK SPACE
C
      DIMENSION BM(4),BN(4),ZN(4,KDXDIM)
C
      M0=MAX(INT((X-X1)/DXM),1)-1
      N0=MAX(INT((Y-Y1)/DYN),1)-1
      M4=MIN(MXX-M0,4)
      N4=MIN(NXX-N0,4)
C
      DO M=1,M4
         BM(M)=XBF(M+M0,X)
      ENDDO
C
      DO N=1,N4
         BN(N)=YBF(N+N0,Y)
      ENDDO
C
      K0=K1-1
      KFX=K2-K0
C
      ZN(:,1:KFX)=0.
C
      DO M=1,M4
      DO N=1,N4
      DO KF=1,KFX
         ZN(N,KF)=ZN(N,KF)+BM(M)*A(KF+K0,M+M0,N+N0)*BN(N)
      ENDDO
      ENDDO
      ENDDO
C
      F(1:KFX)=ZN(1,1:KFX)+ZN(2,1:KFX)+ZN(3,1:KFX)+ZN(4,1:KFX)
C
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE INVMTX (A,NA,V,NV,N,D,ZD,IER)
C
C DIMENSION OF           A(NA,N),V(NV,N),ZD(2*N)
C ARGUMENTS
C LATEST REVISION        AUGUST 1977
C PURPOSE                INVMTX CALCULATES THE INVERSE OF THE MATRIX A,
C                        OF ORDER N, USING GAUSSIAN ELIMINATION WITH
C                        FULL PIVOTING.
C ACCESS CARD            *FORTRAN,S=ULIB,N=INVMTX
C USAGE                  CALL INVMTX (A,NA,V,NV,N,D,ZD,IER)
C ARGUMENTS
C ON INPUT               A
C                          A TWO-DIMENSIONAL VARIABLE WITH ROW, (FIRST)
C                          DIMENSION NA AND COLUMN (SECOND) DIMENSION
C                          .GE. N.  ON INPUT, A CONTAINS THE ELEMENTS OF
C                          THE N BY N MATRIX TO BE INVERTED.
C                        NA
C                          AN INTEGER INPUT VARIABLE SET EQUAL TO THE
C                          ROW (FIRST) DIMENSION OF A AS DECLARED IN THE
C                          CALLING PROGRAM.  NA MUST BE .GE. N.
C                        NV
C                          AN INTEGER INPUT VARIABLE SET EQUAL TO THE
C                          ROW (FIRST) DIMENSION OF V AS DECLARED IN THE
C                          CALLING PROGRAM.  NV MUST BE .GE. N.
C                        N
C                          AN INTEGER INPUT VARIABLE SET EQUAL TO THE
C                          ORDER OF THE MATRIX TO BE INVERTED.
C                        ZD
C                          A REAL ARRAY USED INTERNALLY FOR WORKING
C                          STORAGE.  IT MUST HAVE DIMENSION AT LEAST
C                          2*N.
C ON OUTPUT              V
C                          A TWO-DIMENSIONAL VARIABLE WITH ROW (FIRST)
C                          DIMENSION NV AND COLUMN (SECOND) DIMENSION
C                          .GE. N.  ON OUTPUT, V CONTAINS THE INVERSE OF
C                          A.
C                          IF THE MATRIX A NEED NOT BE SAVED, THEN THE
C                          MATRIX A MAY BE USED AS THE INVERSE V IN THE
C                          CALL; I.E.,
C                            CALL INVMTX(A,NA,A,NA,N,D,ZD,IER)
C                          THEN, ON OUTPUT, A WILL CONTAIN THE INVERSE
C                          MATRIX AND THE ORIGINAL A WILL HAVE BEEN
C                          DESTROYED.
C                        D
C                          A REAL VARIABLE WHICH, ON OUTPUT, CONTAINS
C                          THE DETERMINANT OF A.  IF, DURING THE
C                          COMPUTATION OF THE INVERSE, THE DETERMINANT
C                          BECOMES LARGER THAN THE LARGEST FLOATING
C                          POINT NUMBER THE MACHINE CAN REPRESENT, THE
C                          DETERMINANT CALCULATION IS ABANDONED, A
C                          MESSAGE IS PRINTED, AND A MEANINGLESS NUMBER
C                          IS RETURNED IN D.
C                        IER
C                          AN INTEGER ERROR FLAG
C                            =  1  IF THE DETERMINANT IS LARGER THAN THE
C                                  LARGEST FLOATING POINT NUMBER THAT
C                                  THE MACHINE CAN REPRESENT.
C                            = 33  IF THE MATRIX IS NUMERICALLY
C                                  SINGULAR.
C                            = 34  IF N .LT. 1.
C                            = 35  IF NA .LT. N.
C                            = 36  IF NV .LT. N.
C ENTRY POINTS           INVMTX, IERINV
C COMMON BLOCKS          NONE
C I/O                    AN NCAR RESIDENT ROUTINE, ULIBER, IS USED TO
C                        PRINT ERROR MESSAGES.
C PRECISION              DOUBLE (6/22/84 FOR VAX-11 USAGE)
C REQUIRED ULIB          NONE
C ROUTINES
C SPECIALISTS            JO WALSH AND BEN DOMENICO, NCAR,
C                        BOULDER, COLORADO 80307
C LANGUAGE               FORTRAN
C HISTORY                REVISED AND STANDARDIZED FOR NSSL BY JO WALSH,
C                        APRIL 1974; CERTIFIED BY BEN DOMENICO,
C                        APRIL 1976.
C ALGORITHM              THE  UBROUTINE INVMTX SOLVES THE MATRIX
C                        EQUATION
C                            A*V = I
C                        FOR THE MATRIX V (I.E., A**(-1)), WHERE I IS
C                        THE IDENTITY MATRIX.  THE METHOD USED IS
C                        GAUSSIAN ELIMINATION WITH FULL PIVOTING.  THE
C                        MATRIX A IS DECOMPOSED INTO THE PRODUCT OF A
C                        LOWER TRIANGULAR MATRIX AND AN UPPER TRIANGULAR
C                        MATRIX
C                            A = L*U
C                        THUS
C                                A*V = I
C                            (L*U)*V = I
C                                U*V = L**(-1)
C                        THIS UPPER TRIANGULAR MATRIX EQUATION IS SOLVED
C                        FOR THE COLUMNS OF V USING BACK SUBSTITUTION.
C                        IF AT ANY POINT, AFTER PIVOTING IS DONE, A
C                        PIVOT ELEMENT IS NUMERICALLY ZERO RELATIVE TO
C                        THE LARGEST ELEMENT OF THE MATRIX, THE MATRIX A
C                        IS DECLARED SINGULAR AND THE SUBROUTINE
C                        TERMINATES.
C SPACE REQUIRED         535 (OCTAL) = 349 (DECIMAL)
C ACCURACY               FOR ANY INPUT MATRIX, A,
C                          MAX((NORM(A*V(I)-E(I))/(NORM(A)*NORM(V(I)))
C                              .LE. TOL*N*EPS
C                        WHERE V(I) IS THE ITH COLUMN OF THE MATRIX V,
C                        E(I) IS THE ITH COLUMN OF THE IDENTITY MATRIX,
C                        EPS IS THE LARGEST FLOATING POINT NUMBER SUCH
C                        THAT 1.+EPS = 1., AND ALL THE NORMS ARE
C                        L-INFINITY NORMS.  TOL IS A TOLERANCE FACTOR
C                        SET TO 100 FOR TESTING PURPOSES.
C                        FOR A SPECIFIC INPUT MATRIX A, AN UPPER BOUND
C                        ON THE RELATIVE ERROR IN THE COMPUTED INVERSE V
C                        CAN BE CALCULATED IN TERMS OF THE RESIDUALS
C                        MATRIX R AS FOLLOWS:
C                            ((NORM(E))/(NORM(A**(-1)))) .LE. NORM(R)
C                        WHERE V = A**(-1)+E (THE EXACT INVERSE,
C                        A**(-1), PLUS AN ERROR MATRIX, E).  THUS, THE
C                        RELATIVE ERROR IN V, AS MEASURED BY NORM
C                        (E)/NORM (A**(-1)), IS BOUNDED BY THE NORM OF
C                        THE RESIDUAL MATRIX WHICH CAN BE COMPUTED AS
C                        R = A*V**(-1).
C TIMING                 THE TIME REQUIRED BY INVMTX IS PROPORTIONAL TO
C                        THE QUANTITY N**3 .   ON THE NCAR
C                        CONTROL DATA 7600 WITH N = 100, INVMTX TAKES
C                        ABOUT 1.6 TO 1.7 SECONDS DEPENDING ON THE TIME
C                        REQUIRED TO FIND THE PIVOT ELEMENTS.
C PORTABILITY            THE NCAR ROUTINE, ULIBER, IS CALLED.  THERE IS
C                        A FORTRAN VERSION OF ULIBER ON ULIB.  THERE IS
C                        A MACHINE-DEPENDENT CONSTANT IN A DATA
C                        STATEMENT IN INVMTX.  THIS CONSTANT SHOULD BE
C                        SET TO THE APPROPRIATE VALUE FOR THE MACHINE
C                        BEING USED, OR THE CODE WHICH USES THE CONSTANT
C                        CAN BE DELETED AS INDICATED IN THE COMMENT
C                        CARDS.
C REQUIRED RESIDENT      ULIBER
C ROUTINES
C NOTE                   IN ALMOST ALL APPLICATIONS (E.G., SOLVING
C                        LINEAR SYSTEMS OR DETERMINING PARTICULAR
C                        ELEMENTS OF THE INVERSE), THE NSSL PACKAGE,
C                        LINEQSV, CAN PROVIDE THE SAME CAPABILITIES AS
C                        INVMTX APPROXIMATELY THREE TIMES AS FAST.
C                        HOWEVER, INVMTX PERFORMS FULL PIVOTING AND
C                        REQUIRES LESS STORAGE SINCE IT CAN INVERT THE
C                        MATRIX IN PLACE.
C
      INTEGER NA,NV,N,IER
cc dak 07/3/05      REAL  ZD(1)
      real  zd(*)  ! dak 7/3/05: fix bounds-check error
      DIMENSION            A(NA,N)    ,V(NV,N)
      DOUBLE PRECISION A,V,D,HOLD,PVT,VH,VMAX
C
C FLTMAX IS SET TO THE LARGEST FLOATING POINT NUMBER REPRESENTABLE IN
C THE MACHINE
C
      CHARACTER *34 ERMESS
      DATA IEXMAX/38/
C
C CALL INVMTA TO CHECK VALIDITY OF ARGUMENT RANGES
C
      IER = IERINV(N,NA,NV)
      IF (IER .NE. 0) RETURN
C
C STORE A IN V
C
      ZD(1:N) = 0.
      V(1:N,:) = A(1:N,:)
      D = 1.
      IEX = 0
      DO 110 M=1,N
         VMAX = 0.
         DO 104 J=1,N
            IF (NINT(ZD(J)) .NE. 0) GO TO 104
C
C FIND MAXIMUM PIVOT ELEMENT
C
            DO 103 I=1,N
               IF(NINT(ZD(I)) .NE. 0) GO TO 103
               VH = ABS(V(I,J))
               IF (VMAX .GE. VH) GO TO 103
               VMAX = VH
               K = I
               L = J
  103       CONTINUE
  104    CONTINUE
         ZD(L) = K
         NPM = N+M
         ZD(NPM) = L
         D = D*V(K,L)
  105    CONTINUE
         IF (ABS(D) .LE. 1.0) GO TO 106
         D = D*0.1
         IEX = IEX+1
         GO TO 105
  106    CONTINUE
         PVT = V(K,L)
C
C CHECK FOR NUMERCALLY SINGULAR MATRIX
C
         IF (M .EQ. 1) PVTMX = ABS(PVT)
         IF (ABS(PVT/REAL(M))+PVTMX .EQ. PVTMX) GO TO 113
C
C INTERCHANGE ROWS, PLACING PIVOT ELEMENT ON THE DIAGONAL.
C THEN PROCEDE WITH PIVOTING.
C
         V(K,L) = 1.
         DO 107 J=1,N
            HOLD = V(K,J)
            V(K,J) = V(L,J)
            V(L,J) = HOLD/PVT
  107    CONTINUE
         DO 109 I=1,N
            IF (I .EQ. L) GO TO 109
            HOLD = V(I,L)
            V(I,L) = 0.
            DO 108 J=1,N
               V(I,J) = V(I,J)-V(L,J)*HOLD
  108       CONTINUE
  109    CONTINUE
  110 CONTINUE
C
C PERMUTE FINAL INVERSE MATRIX
C
      M = N+N+1
      DO 112 J=1,N
         M = M-1
         L = NINT(ZD(M))
         K = NINT(ZD(L))
         IF (K .EQ. L) GO TO 112
         D = -D
         DO 111 I=1,N
            HOLD = V(I,L)
            V(I,L) = V(I,K)
            V(I,K) = HOLD
  111    CONTINUE
  112 CONTINUE
C
C CHECK FOR OVERFLOW IN DETERMINANT CALCULATION.
C
      IF (IEX .GT. IEXMAX) GO TO 114
      D = D*10.**IEX
      RETURN
  113 IER = 33
      ERMESS = 'MATRIX SINGULAR IN INVMTX'
      GO TO 115
  114 IER = 1
      D = REAL(IEX)
      ERMESS = 'DETERMINANT TOO LARGE IN INVMTX'
      RETURN
  115 WRITE(6,116) IER,ERMESS
  116 FORMAT(/'  ....  ERROR NO. ',I4,' IN INVMTX',4X,A34)
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      FUNCTION IERINV (N,NA,NV)
C
C THIS FUNCTION TESTS THE INPUT ARGUMENTS N, NA, AND NV TO INSURE
C THAT THEY ARE IN THE PROPER RANGES.  THE INPUT ARGUMENTS HAVE THE
C SAME MEANING AS IN INVMTX.
C IF ONE OR MORE OF THE FOLLOWING CONDITIONS OCCURS, A FATAL ERROR
C MESSAGE IS WRITTEN TO UNIT 6 AND THE FUNCTION RETURNS WITH IERINV
C EQUAL TO THE VALUE INDICATED.
C        FOR N .LT. 1, IERINV = 34.
C        FOR NA .LT. N, IERINV = 35.
C        FOR NV .LT. N, IERINV = 36.
C IF NO ERROR CONDITION IS DETECTED, THE FUNCTION RETURNS WITH
C IERINV = 0.
C
      CHARACTER*24 ERMESS
      IERINV = 0
      IF (N .GE. 1) GO TO 101
      IERINV = 34
      ERMESS = ' N .LT. 1 IN INVMTX '
      GO TO 103
  101 IF (NA .GE. N) GO TO 102
      IERINV = 35
      ERMESS ='NA .LT. N IN INVMTX '
      GO TO 103
  102 IF (NV .GE. N) RETURN
      IERINV = 36
      ERMESS = ' NV .LT. N IN INVMTX '
  103 WRITE(6,104) IERINV,ERMESS
  104 FORMAT(/' ....  ERROR IN IERINV NO. ',I3,4X,A24)
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE XSPLCM(NX,YNB,YNT,YDCWL,KYBC1,KYBC2,YBCWL1,YBCWL2,DATA,
     1                  YDZ,WDZ,LDXX,FITNOD,YNOD,IVARZ,IPLVL,RLAT0,
     2                  RLON0,IHR0,IDAY0,STMNMZ)
C
C                    1-D SPLINE  **  03/19/90
C
C     MODIFICATION OF XSPLINEX FOR 1 DIMENSIONAL INTERPOLATION OF
C           DATA FOR COMPOSITING
C
C
C
C         ++ THIS SUBROUTINE CALLS ALL NECESSARY ROUTINES.  INPUTS
C              ARE BOUNDARY CONDITIONS, DATA, FILTER WAVELENGTHS
C                  FROM ARGUMENTS    ++
C
C
      PARAMETER (NDIM=71)
ccccc PARAMETER (LDXDIM=2500)
      PARAMETER (LDXDIM=8000)
      PARAMETER (KDTDIM=5)
C
      COMMON / / A(KDTDIM,NDIM),FD(KDTDIM,LDXDIM),FKMN(KDTDIM,NDIM),
     1           AMM(NDIM,NDIM),DMM(NDIM,NDIM)
      COMMON/S1DTPT/IDSPD1,IDSPD2,LDX,YD(LDXDIM),WD(LDXDIM),
     1               LXSORT(LDXDIM)
      COMMON/S1KOMP/IDSPK(KDTDIM),IDVAR(KDTDIM),KPX
C
      CHARACTER IDSPD1*8,IDSPD2*72,IDSPK*40,IDXVAR*32
      CHARACTER IDSPC*125,IOK*1,STMNMZ*(*)
      LOGICAL FIRST
C
      DIMENSION YDZ(LDXX),LDSORT(LDXDIM),DATA(LDXX),WDZ(LDXX),
     1          YNOD(NX+1),FITNOD(NX+1),YDZZ(LDXDIM),IDXVAR(KDTDIM)
C
      DATA IDXVAR/'SURFACE PRESSURE                ',
     D            'TANGENTIAL COMP. OF WIND (M/S)  ',
     D            'RADIAL COMP. OF WIND (M/S)      ',
     D            'VORTICITY (10**-5 S**-1)        ',
     D            'DIVERGENCE (10**-5 S**-1)       '/
C    D            'TOTAL WIND SPEED     (M/S)      ',
C    D            'GEOPOTENTIAL HEIGHT  (M)        '/
C    D            'TEMPERATURE  (DEG C)            ',
C    D            'MIXING RATIO (G/KG)             '/
C
C
C     DATA NX/10/,YNB/1050./,YNT/200./
C     DATA KDC/3/,YDCWL/6./,KDAT/1/
C     DATA KYBC1/21/,KYBC2/21/,YBCWL1/10./,YBCWL2/10./
      DATA FIRST/.TRUE./
C
C     DATA DEFINITION
C     DOMAIN PARAMETERS:
C                  NX   - NUMBER OF NODAL POINTS
C                  YNB  - LEFT BOUNDARY
C                  YNT  - RIGHT BOUNDARY
C
      IF(FIRST)  CALL RDTITL(2)
      FIRST=.FALSE.
      CALL PRTITL(2)
C
C
      IF(IPLVL .GT. 0)  WRITE(6,11)
   11 FORMAT(///11X,'DATA TYPES ARE:',/,16X,
     1       ' 1: OBS. SURFACE PRESSURE DATA',/,16X,
     2       ' 2: OBS. TANGENTIAL WIND DATA',/,16X,
     3       ' 3: OBS. RADIAL WIND DATA DATA',/,16X,
     4       ' 4: SHAPIRO VORTEX MODEL VORTICITY',/,16X,
     5       ' 5: SHAPIRO VORTEX MODEL DIVERGENCE')
C
      WRITE(IDSPC,18) STMNMZ,IVARZ,RLAT0,RLON0,IDAY0,IHR0
   18 FORMAT(A,' DATA TYPE=',I4,'  LAT.=',
     1       F6.1,'  LONG.=',
     2       F6.1,' DAY=',I8,'  HOUR=',I6,18X)
C
C     CONVERT INPUT DOMAIN PARAMETERS TO SPLINE NOTATION
C
      YN1  = YNB
      YNXX = YNT
      DYN=(YNXX-YN1)/NX
      NODINT=NX
C
      CALL STSND1(NX,YN1,YNXX)
C
C     SET INPUTL BC & FILTER
C
      KYBC1Z=KYBC1
      KYBC2Z=KYBC2
      YBCL1Z=YBCWL1
      YBCL2Z=YBCWL2
      YDCWLZ=YDCWL
C
C     DEFAULT UNIT IS NORMAL PRINTOUT
C
      IUNIT=6
      IOK='Y'
      KDATS=1
      KDATF=1
      KDAT=1
      KDC=3
C
C     CONVERT FILTER WAVELENGTHS AND B.C. WAVELENGTHS TO INTERNAL UNITS
C         ******   INTERNAL UNITS ARE DELTAY (KM)   ******
C
      YDCWLZ=YDCWLZ*DYN
      YBCL1Z=YBCL1Z*DYN
      YBCL2Z=YBCL2Z*DYN
C
      CALL STSID1(IDSPC)
      CALL STSBC1(KYBC1Z,KYBC2Z,YBCL1Z,YBCL2Z)
      CALL STSDC1(KDC,YDCWLZ)
      CALL SL1OVR(NODINT,YNOD)
C
      FD(1:KDAT,:)=-99.0
      WD=-99.0
      YD=-99.0
C
C
      IDSPK(KDAT)=IDXVAR(IVARZ)
      IDVAR(KDAT)=IVARZ
      LDX=LDXX
      DO 20 LD=1,LDX
      WD(LD)=WDZ(LD)
      YD(LD)=YDZ(LD)
      YDZZ(LD)=YDZ(LD)
      FD(KDAT,LD)=DATA(LD)
c && 3 comments
CC    WRITE(6,13) LD,YDZ(LD),WDZ(LD),DATA(LD)
CC 13 FORMAT('...DATA INPUT BEFORE SORTING: LD,YDZ,WDZ,DATA=',I4,
CC   1       3F12.2)
   20 CONTINUE
C
      CALL SORTRL(YDZZ,LDSORT,LDX)
C
      DO 40 LD=1,LDX
      LXSORT(LD)=LDSORT(LD)
c && 3 comments
CC    WRITE(6,39) LD,LXSORT(LD),YD(LD),WD(LD),FD(KDAT,LD)
CC 39 FORMAT('...DATA INPUT AFTER SORTING: LD,LDSORT,YD,WD,FD=',2I4,
CC   1       3F12.2)
   40 CONTINUE
C
      WRITE(6,51)  LDX
   51 FORMAT(/'....XSPLCM HAS READ DATA ....',I5,' POINTS...')
C
C
C     ***** CALCULATE MATRIX COEFFICIENTS *****
C
      CALL SL1RGO
C
      KDX=KDAT
      CALL ST1KPX(KDX)
      CALL SL1MBO(KDATS,KDATF)
      CALL PR1FKM(A,FKMN,KDATS,KDATF)
      IF(IPLVL .GE. 1)
     1   CALL OUTPUTT(FD,A,FKMN,KDATS,KDATF,IUNIT,IPLVL,IOK)
C
      FITNOD=FKMN(KDAT,1:NX+1)
C
      WRITE(6,111)
  111 FORMAT(/'...END 1-D SPLINE FITTING...')
C
      RETURN
C
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE OUTPUTT(FD,A,FKMN,KDATS,KDATF,IUNIT,IPLVL,IOK)
C
      PARAMETER (NDIM=71)
ccccc PARAMETER (LDXDIM=2500)
      PARAMETER (LDXDIM=8000)
      PARAMETER (KDTDIM=5)
      PARAMETER (NLXDIM=NDIM+LDXDIM)
C
      COMMON/S1DTPT/IDSPD1,IDSPD2,LDX,YD(LDXDIM),WD(LDXDIM),
     1               LXSORT(LDXDIM)
      COMMON /S1KOMP/ IDSPK(KDTDIM),IDVAR(KDTDIM),KPX
      COMMON /S1NODE/ NXX,DYN,YN(NDIM)
C
      DIMENSION FD(KDTDIM,LDXDIM),A(KDTDIM,NDIM),FKMN(KDTDIM,NDIM),
     1          ORD(NLXDIM),UVDATA(NLXDIM,3,2),ADATA(3,NLXDIM),
     2          ABSMX(KDTDIM),HEADR(KDTDIM)
C
      CHARACTER IDSPD1*8,IDSPD2*72,IDSPK*40,HEADR*14,IOK*1
      LOGICAL PDATA,GSET
C
      DATA ABSMX/1020.,80.,80.,2*1.E-2/,
     1                                     HEADR/'SURFACE PRESS.',
     2                                           'TANGENTIAL WND',
     3                                           'RADIAL WIND   ',
     4                                           'VORTICITY     ',
     4                                           'DIVERGENCE    '/
C    3                                           'TOTAL WIND SPD',
C    4                                           'GEOPOT. HEIGHT'/
C      DATA ABSMX/360.,25./,HEADR/'WIND DIRECTION',
C     1                                        'WIND SPEED    '/
C
    1 DO 300 KD=KDATS,KDATF
      IF(IOK .EQ. 'Y')  CALL PR1VRC
      WRITE(IUNIT,3)  KD,IDSPK(KD)
    3 FORMAT(/4X,'KD=',I4,2X,A40,/,5X,'D/N',2X,
     1       'DIST',7X,'SPLINE',7X,'DATA',7X,'TYPE',7X,'DEVIATION')
C
      ID=1
      LN=1
      LG=1
      NG=3
      PDATA=.TRUE.
C
    5 LD=LXSORT(ID)
      IF(ABS(YN(LN)-YD(LD)) .LT. 0.1)  GO TO 10
      IF(YN(LN) .LT. YD(LD) .OR. .NOT. PDATA)  GO TO 20
C
C     PRINT DATA POINT ONLY
C
      CALL SP1TNO(YD(LD),A,KD,SPLZ)
      WRITE(IUNIT,6)  YD(LD),SPLZ,FD(KD,LD),WD(LD),FD(KD,LD)-SPLZ
    6 FORMAT(5X,'D ',F6.1,2F12.3,F10.2,F12.3)
C
C     STORE FOR GRAPHING
C
      ORD(LG)=YD(LD)
      UVDATA(LG,1,KD)=SPLZ
      UVDATA(LG,2,KD)=FD(KD,LD)
      UVDATA(LG,3,KD)=FD(KD,LD)-SPLZ
      LG=LG+1
C
      ID=ID+1
      GO TO 200
C
C     PRINT DATA POINT AND NODAL VALUE
C
   10 WRITE(IUNIT,11)  YN(LN),FKMN(KD,LN),FD(KD,LD),WD(LD),
     1             FD(KD,LD)-FKMN(KD,LN)
   11 FORMAT(5X,'* ',F6.1,2F12.3,F10.2,F12.3)
C
C     STORE FOR GRAPHING
C
      ORD(LG)=YN(LN)
      UVDATA(LG,1,KD)=FKMN(KD,LN)
      UVDATA(LG,2,KD)=FD(KD,LD)
      UVDATA(LG,3,KD)=FD(KD,LD)-FKMN(KD,LN)
      LG=LG+1
C
      ID=ID+1
      LN=LN+1
      GO TO 200
C
C     PRINT NODAL VALUE ONLY
C
   20 WRITE(IUNIT,21)  YN(LN),FKMN(KD,LN)
   21 FORMAT(5X,'N ',F6.1,F12.3)
C
C     STORE FOR GRAPHING
C
      ORD(LG)=YN(LN)
      UVDATA(LG,1,KD)=FKMN(KD,LN)
      UVDATA(LG,2,KD)=0.0
      UVDATA(LG,3,KD)=0.0
      LG=LG+1
C
      LN=LN+1
C
  200 IF(LN .GT. NXX)  GO TO 300
      IF(ID .LE. LDX .AND. PDATA)  GO TO 5
      PDATA=.FALSE.
      ID=LDX
      GO TO 5
C
  300 CONTINUE
C
C     OPTION FOR INTERACTIVE USAGE IF IUNIT .NE. 6
C
      IF(IUNIT .EQ. 6)  GO TO 350
C
      WRITE(6,310)
  310 FORMAT(' PROFILE OK? (Y/N)')
      READ(IUNIT,311) IOK
  311 FORMAT(A1)
C
      IF(IOK .EQ. 'Y') GO TO 330
      RETURN
C
  330 IUNIT=6
      GO TO 1
C
C     OUTPUT COSMETICS
C
  350 IF(KDATF .LT. KPX)  RETURN
      print *, ' '
      print *, ' '
C
      LG=LG-1
C
      DO 500 K=1,KDATF
C
      XMIN=1.E10
      DO L=1,LG
      DO N=1,NG
      IF(N .LE. 2 .AND. UVDATA(L,N,K) .NE. 0.0 )
     1                   XMIN=MIN(UVDATA(L,N,K),XMIN)
      ADATA(N,L)=UVDATA(L,N,K)
      ENDDO
      ENDDO
C
C     XMIN=10.*(NINT(XMIN*0.1))-10.
C
C     SKIP GRAPHS IS PRINT LEVEL (IPLVL) IS LESS THAN 2.
C
      IF(IPLVL .NE. 2)  GO TO 500
      WRITE(6,451) HEADR(IDVAR(K))
  451 FORMAT(///30X,A14)
      GSET=.FALSE.
      MAXAB=100
      CALL DSGRPH(NG,ORD,ADATA,ABSMX(IDVAR(K)),XMIN,MAXAB,LG,GSET,0)
  500 CONTINUE
C
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE DSGRPH(NGRAPH,ORDNAT,ADATA,ABSMAX,ABSMIN,DIMABS,DIMORD,
     1                  GSET,ISPC)
      CHARACTER*1  IBEGIN,IEND,LINE(101),NDATA(11)
      COMMON/CPRINT/IBEGIN,IEND
      INTEGER DIMORD,DIMABS
      DIMENSION ADATA(NGRAPH,DIMORD),ABSISA(11),ORDNAT(DIMORD)
      LOGICAL GSET
      DATA NDATA/' ','1','2','3','4','5','6','7','8','9','.'/
C
C
C     NGRAPH = NUMBER OF 1-DIMENSIONAL ARRAYS TO BE PLOTTED
C     ORDNAT = DATA PLOTTED ON ORDINATE
C     ADATA  = 2-DIMENSIONAL DATA ARRAY CONTAINING ALL PLOTTED ARRAYS
C     ABSMAX = MAXIMUM VALUE ON ABSCISSA
C     ABSMIN = MINIMUM VALUE ON ABSCISSA
C     DIMABS = WIDTH OF ABSCISSA
C     DIMORD = NUMBER OF ORDINATE VALUES TO BE PLOTTED
C     GSET   = FALSE IF GRAPH ROUTINE IS TO FIND THE MAXIMUM AND
C              MINIMUM ABSCISSAE
C
C
      ABSMX=ABSMAX
      ABSMN=ABSMIN
      IBEGIN = '.'
      IEND = '.'
C
C     OPTIONALLY FIND MAXIMUM AND MINIMUM ABSCISSAE
C
      IF(GSET) GO TO 5
      ABSMX = -1.0
      ABSMN = 1.E15
      DO J=1,DIMORD
      DO I=1,NGRAPH
         IF(ADATA(I,J) .GT. ABSMX) ABSMX = ADATA(I,J)
         IF(ADATA(I,J) .LE. ABSMN) ABSMN = ADATA(I,J)
      ENDDO
      ENDDO
    5 TEM = ABSMX-ABSMN
      DELABS = TEM/(DIMABS-1)
      DPRNT = TEM/10.
      ABSISA(1) = ABSMN
      DO I=2,11
         ABSISA(I) = ABSISA(I-1)+DPRNT
      ENDDO
C
C     FIND ZERO IF ANY
C
      NZERO = MAX(1.0,-ABSMN/DELABS+1.0)
C
C     PRINT GRAPH
C
      WRITE(6,5555)
 5555 FORMAT(//,3X,'PR',4X,'SPL',4X,'DATA',2X,'DEV')
      WRITE(6,55) (ABSISA(J),J=1,11)
   55 FORMAT(23X,11F10.2)
      DO J=1,DIMABS
      LINE(J) = '.'
      IF(MOD(J-NZERO,5) .EQ. 0) LINE(J) = '^'
      ENDDO
      LINE(NZERO) = '^'
      CALL PRNT(DIMABS,LINE)
      LINE(1:DIMABS) = ' '
      LINE(NZERO) = '^'
C
      DO 1000 K=1,DIMORD
C
      GO TO (100,200,300),NGRAPH
C
  100 CONTINUE
      NABS1 = MIN(INT(MAX(1.0,(ADATA(1,K)-ABSMN)/DELABS+1.0)),DIMABS)
      LINE(NABS1) = NDATA(NGRAPH+1)
      WRITE(6,101) ORDNAT(K),ADATA(1,K),IBEGIN,(LINE(J),J=1,DIMABS),IEND
  101 FORMAT(F6.1,1X,F7.2,14X,102A1)
      LINE(NABS1) = ' '
      LINE(NZERO) = '^'
      GO TO 400
  200 CONTINUE
      NABS1 = MIN(INT(MAX(1.0,(ADATA(1,K)-ABSMN)/DELABS+1.0)),DIMABS)
      LINE(NABS1) = '1'
      NABS2 = MIN(INT(MAX(1.0,(ADATA(2,K)-ABSMN)/DELABS+1.0)),DIMABS)
      LINE(NABS2) = '2'
      IF(NABS1 .EQ. NABS2) LINE(NABS2) = '+'
      WRITE(6,201) ORDNAT(K),(ADATA(N,K),N=1,NGRAPH),IBEGIN
     1,(LINE(J),J=1,DIMABS),IEND
  201 FORMAT(F6.1,1X,2(F7.2,1X),5X,102A1)
      LINE(NABS1) = ' '
      LINE(NABS2) = ' '
      LINE(NZERO) = '^'
      GO TO 400
  300 CONTINUE
      NABS1 = MIN(INT(MAX(1.0,(ADATA(1,K)-ABSMN)/DELABS+1.0)),DIMABS)
      LINE(NABS1) = '1'
      NABS2 = MIN(INT(MAX(1.0,(ADATA(2,K)-ABSMN)/DELABS+1.0)),DIMABS)
      LINE(NABS2) = '2'
      NABS3 = MIN(INT(MAX(1.0,(ADATA(3,K)-ABSMN)/DELABS+1.0)),DIMABS)
      LINE(NABS3) = '3'
      IF(NABS1 .EQ. NABS2 .OR. NABS2 .EQ. NABS3) LINE(NABS2) = '+'
      IF(NABS1 .EQ. NABS3) LINE(NABS1) = '+'
      IF(NABS1 .EQ. NABS2 .AND. NABS2 .EQ. NABS3) LINE(NABS1) = 'X'
      WRITE(6,301) ORDNAT(K),(ADATA(N,K),N=1,NGRAPH),IBEGIN
     1,(LINE(J),J=1,DIMABS),IEND
  301 FORMAT(F6.1,1X,2(F7.2,1X),F5.1,102A1)
      LINE(NABS1) = ' '
      LINE(NABS2) = ' '
      LINE(NABS3) = ' '
      LINE(NZERO) = '^'
  400 CONTINUE
      IF(ISPC .LE. 1 .OR. K .EQ. DIMORD) GO TO 1000
      DO I=1,ISPC
         CALL PRNT(DIMABS,LINE)
      ENDDO
 1000 CONTINUE
      DO J=1,DIMABS
         LINE(J) = '.'
         IF(MOD(J-NZERO,5) .EQ. 0) LINE(J) = '^'
      ENDDO
      LINE(NZERO) = '^'
      CALL PRNT(DIMABS,LINE)
C
      WRITE(6,55) (ABSISA(J),J=1,11)
C
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE PRNT(NDIM,L)
      CHARACTER*1  IBEGIN,IEND,L(NDIM)
      COMMON/CPRINT/IBEGIN,IEND
      WRITE(6,10) IBEGIN,L,IEND
   10 FORMAT(28X,102A1)
C
      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
C
C
      SUBROUTINE OVRSUB(IDSPCZ,NXZ,YN1Z,YNXXZ,KDCTYZ,YDCWLZ)
C
C     ++ ASSUMED DIM PARAMETERS ...NDIM=71,
C
C     ** COMPILATION PARAMETERS **
C
      PARAMETER (NDIM=71)
C
C     NDIM     ARRAY DIMENSION FOR NODAL INDEX N IN THE Y DIRECTION
C
C     ** PRIMARY CONSTANTS FOR SPLINE ANALYSIS PACKAGE
C
      COMMON /S1PRIC/ NX,KDCTYP,KBCTYP(2),YN1,YNXX,YDCWL,
     1        YBCWL(2),IDSPC
C
C     ** SECONDARY CONSTANTS FOR CONVENIENCE
C
      COMMON /S1NODE/ NXX,DYN,YN(NDIM)
C
C     ** DUMMY ARGUMENT
      CHARACTER*125 IDSPCZ,IDSPC

C
C     ** OVERHEAD CHORES FOR TWO-D SPLINE ANALYSIS AND INVERSE TRANSFORM
C
C     INPUT    ALL THE PRIMARY CONSTANTS IN /S1PRIC/
C              IDSPC .. CODE AND EXPLANATION (80 CHARACTERS)
C
C     OUTPUT   ALL THE SECONDARY CONSTANTS IN /S1NODE/ AND /S1BCDC/
C
C     ENTRIES FOR DEFINING THE PRIMARY CONSTANTS
C              STSID1(IDSPCZ)
C              STSND1(NXZ,YN1Z,YNXXZ)
C              STSDC1(KDCTYZ,YDCWLZ)
C
C     ENTRIES FOR PRINT OUTPUT
C              PR1VRC ... TO PRINT /S1PRIC/
C
C
C
C
C-----------------------------------------------------------------------

C
C
      ENTRY STSID1(IDSPCZ)
      IDSPC=IDSPCZ
      RETURN

C-----------------------------------------------------------------------

C
      ENTRY STSND1(NXZ,YN1Z,YNXXZ)
      NX=NXZ
      YN1 =YN1Z
      YNXX=YNXXZ
      RETURN

C-----------------------------------------------------------------------

C
      ENTRY STSDC1(KDCTYZ,YDCWLZ)
      KDCTYP=KDCTYZ
      YDCWL=YDCWLZ
      RETURN

C-----------------------------------------------------------------------

C
C
      ENTRY PR1VRC
C
C  80 CONTINUE
      WRITE(6,880) IDSPC,NX,KDCTYP,(KBCTYP(I),I=1,2),
     1    YN1,YNXX,DYN,YDCWL/DYN,
     2    (YBCWL(I)/DYN,I=1,2)
C
  880 FORMAT('.../S1PRIC/...',/,9X,A125,/,'  NX=',
     1       I3,', (DC)',I2,', (BC)',2I3,',   (Y LIMITS)',2F10.3,/,
     2       9X,'DELTAY=',F7.3,' KM,  (DCWL (DELTAY UNITS))',F8.1,
     3       ',  (BCWL (DELTAY UNITS))',2F8.1)
      RETURN

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE STSBC1(KBCTY1,KBCTY2,YBCWL1,YBCWL2)

      COMMON /S1PRIC/ NX,KDCTYP,KBCTYP(2),YN1,YNXX,YDCWL,YBCWL(2),IDSPC

      INTEGER NX,KDCTYP,KBCTYP,IDSPC
      REAL YN1,YNXX,YDCWL,YBCWL

      KBCTYP(1)=KBCTY1
      KBCTYP(2)=KBCTY2
      YBCWL(1)=YBCWL1
      YBCWL(2)=YBCWL2

      RETURN

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE SL1OVR(NYNOD,YNOD)

      IMPLICIT NONE

      INTEGER NDIM,NXX,NX,KDCTYP,KBCTYP
C
C     ** COMPILATION PARAMETERS **
C
      PARAMETER (NDIM=71)

C
C     NDIM     ARRAY DIMENSION FOR NODAL INDEX N IN THE Y DIRECTION
C
C     ** PRIMARY CONSTANTS FOR SPLINE ANALYSIS PACKAGE
C
      COMMON /S1PRIC/ NX,KDCTYP,KBCTYP(2),YN1,YNXX,YDCWL,YBCWL(2),IDSPC

C
C     ** SECONDARY CONSTANTS FOR CONVENIENCE
C
      COMMON /S1NODE/ NXX,DYN,YN(NDIM)
      COMMON /S1BCDC/ DY0,DY1,DY2,CBCBF(4),YSDCPI

      REAL    YN1,YNXX,YDCWL,YBCWL,DYN,YN
      REAL    DY0,DY1,DY2,CBCBF,YSDCPI

C     ** DUMMY ARGUMENT
      CHARACTER*125 IDSPCZ,IDSPC
C
C     ** LOCAL WORK SPACE
      INTEGER NYNOD
      REAL YSBCPI(2),YNOD(NYNOD+1)
C
C     ** NUMERICAL CONSTANTS
      REAL PI2/6.283185307180/

      INTEGER N,K,KK
      REAL(4) Z,ZC 

      NXX=NX+1
      DYN=(YNXX-YN1)/REAL(NX)
      YN(1)=YN1
      YNOD(1)=YN1

C     ** CHECK NDIM **
C
      IF(NXX.GT.NDIM) GO TO 90

      DO N=2,NXX
         YN(N)=YN1+(N-1)*DYN
         YNOD(N)=YN(N)
      ENDDO
C
C     CONSTANTS FOR BASIS FUNCTION CALCULATION
C
      DY0=1./DYN
      DY1=3.*DY0
      DY2=6.*DY0**2
C
C
C     ** DC AND BC CONSTANTS ARE NONDIMENSIONALIZED
C
C     YDCWL AND YBCWL MUST BE GIVEN IN INTERNAL LENGTH UNITS ... METERS
C
      Z=1./PI2
      ZC=Z/DYN
      YSDCPI   =ZC*YDCWL
      YSBCPI(1)=ZC*YBCWL(1)
      YSBCPI(2)=ZC*YBCWL(2)
C
C     ** BOUNDARY LINES ... K=1 AT YN1, =2 AT YNXX
C
C     ** BOUNDARY CONDITION TYPES (PERIODIC CONDITION IS NOT INCLUDED, 0
C
C     KBCTYP= 0 ... YSBF=0
C             1 ... DYSBF=0
C             2 ... DDYSBF=0
C            10 ... (-/+)YSBCPI*DYSBF+YSBF=0     (- AT YN1, + AT YNXX)
C            20 ... (YSBCPI**2)*DDYSBF+YSBF=0
C            21 ... (-/+)YSBCPI*DDYSBF+DYSBF=0
C
C     ** COEFFICIENTS DEFINING Y1BF AT THE BOUNDARY
C
      DO 38 K=1,2
      KK=K+K-1
      IF(KBCTYP(K).EQ. 0) GO TO 31
      IF(KBCTYP(K).EQ. 1) GO TO 32
      IF(KBCTYP(K).EQ. 2) GO TO 33
      IF(KBCTYP(K).EQ.10) GO TO 34
      IF(KBCTYP(K).EQ.20) GO TO 35
      IF(KBCTYP(K).EQ.21) GO TO 36
      GO TO 91

C     TYPE 0
   31 CBCBF(KK)  =-1.
      CBCBF(KK+1)=-0.25
        GO TO 38
C     TYPE 1
   32 CBCBF(KK)  = 0.
      CBCBF(KK+1)= 0.25
        GO TO 38
C     TYPE 2
   33 CBCBF(KK)  = 0.5
      CBCBF(KK+1)=-0.25
        GO TO 38
C     TYPE 10
   34 CBCBF(KK)  =-1./(3.*YSBCPI(K)+1.)
      CBCBF(KK+1)= 0.25+0.5*CBCBF(KK)
      GO TO 38
C     TYPE 20
   35 Z=3.*YSBCPI(K)**2
      CBCBF(KK)  = 0.5*(Z-1.)/(Z+0.5)
      CBCBF(KK+1)=-0.25
        GO TO 38
C     TYPE 21
   36 CBCBF(KK)  = 0.5*YSBCPI(K)/(0.5+YSBCPI(K))
      CBCBF(KK+1)= 0.25-CBCBF(KK)
   38 CONTINUE

      RETURN

C-----------------------------------------------------------------------
C
C     ** ERROR EXITS **
   90 WRITE(6,890) NXX,NDIM
  890 FORMAT(/' === SL1OVR FOUND NXX.GT. NDIM) ===',3X,2I6)
      GO TO 99
C
   91 WRITE(6,891) KBCTYP,YBCWL
  891 FORMAT(/' === SL1OVR MET UNDEFINED KBCTYP ===',2I12,/,41X,2F12.3)
   99 CALL ABRT1(' SL1OVR',891)

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE ST1KPX(KPXZ)

      PARAMETER (KDTDIM=5)
C
      COMMON /S1KOMP/ IDSPK(KDTDIM),IDVAR(KDTDIM),KPX
      CHARACTER*8 IDSPK*40

      KPX=KPXZ
      RETURN

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      FUNCTION YBF(N,Y)
C
C        ENTRY DYBF, DDYBF
C
      PARAMETER (MDIM=35,NDIM=35)
CIBM  COMMON /S2PRIC/ IDSPC,ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,
CIBM 1                 YNB,YNT,XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4)
      COMMON /S2PRIC/ ISRCD,JPD,MX,NX,KDCTYP,KBCTYP(4),XML,XMR,YNB,YNT,
     1                 XM1,XMXX,YN1,YNXX,XYDCWL(2),XYBCWL(4),IDSPC
      COMMON /S2NODE/ MXX,NXX,DXM,DYN,XM(MDIM),YN(NDIM),XMC(MDIM),
     1                 YNC(NDIM),COSYN(NDIM)
      COMMON /S2BCDC/ DX0,DX1,DX2,DY0,DY1,DY2,CBCBF(8),XYSDCP(2)
      CHARACTER*125 IDSPC
      EQUIVALENCE (NX,LX),(CBCBF(5),CBC11),(CBCBF(6),CBC12),
     1                    (CBCBF(7),CBCX1),(CBCBF(8),CBCX2)

      L=N
      XS=(Y-YN(L))*DY0
      Z=2.-ABS(XS)
      IF(Z.GT.0)  GO TO 15
      YBF=0.
      RETURN
   15 CONTINUE
      F=0.25*Z**3
      Z=Z-1.
      IF(Z.LE.0)  GO TO 23
      F=F-Z**3
   23 CONTINUE
      IF(L-2.LT.0)  THEN
         GO TO 30
      ELSE  IF(L-2.EQ.0)  THEN
         GO TO 35
      END IF
      IF(LX-L.LT.0)  THEN
         GO TO 40
      ELSE  IF(LX-L.EQ.0)  THEN
         GO TO 45
      END IF
   25 CONTINUE
      YBF=F
      RETURN
C
C     BOUNDARY ADJUSTMENTS
C
   30 CONTINUE
      IF(Z.LE.0)  GO TO 25
      F=F+CBC11*(1.-XS)**3
      GO TO 25
   35 CONTINUE
      IF(XS.GE.0)  GO TO 25
      F=F-CBC12*XS**3
      GO TO  25
   40 CONTINUE
      IF(Z.LE.0)  GO TO 25
      F=F+CBCX1*(1.+XS)**3
      GO TO 25
   45 CONTINUE
      IF(XS.LE.0)  GO TO 25
      F=F+CBCX2*XS**3
      GO TO  25
C

C-----------------------------------------------------------------------

      ENTRY DYBF(N,Y)
      D1=DY1
      L=N
      XS=(Y-YN(L))*DY0
      D1=-SIGN(D1,XS)
      Z=2.-ABS(XS)
      IF(Z.GT.0) GO TO 115
      YBF=0.
      RETURN
  115 CONTINUE
      F=0.25*Z**2
      Z=Z-1.
      IF(Z.LE.0) GO TO 123
      F=F-Z**2
  123 CONTINUE
      IF(L-2.LT.0) THEN
         GO TO 130
      ELSE  IF(L-2.EQ.0)  THEN
         GO TO 135
      END IF
      IF(LX-L.LT.0) THEN
         GO TO 140
      ELSE  IF(LX-L.EQ.0)  THEN
         GO TO 145
      END IF
  125 CONTINUE
      YBF=F*D1
      RETURN
  130 CONTINUE
      IF(Z.LE.0) GO TO 125
      F=F+CBC11*SIGN((1.-XS)**2,XS)
      GO TO 125
  135 CONTINUE
      IF(XS.GE.0) GO TO 125
      F=F-CBC12*XS**2
      GO TO 125
  140 CONTINUE
      IF(Z.LE.0) GO TO 125
      F=F-CBCX1*SIGN((1.+XS)**2,XS)
      GO TO 125
  145 CONTINUE
      IF(XS.LE.0) GO TO 125
      F=F-CBCX2*XS**2
      GO TO 125
C

C-----------------------------------------------------------------------

      ENTRY DDYBF(N,Y)
      D2=DY2
      L=N
      XS=(Y-YN(L))*DY0
      Z=2.-ABS(XS)
      IF(Z.GT.0) GO TO 215
      YBF=0.
      RETURN
  215 CONTINUE
      F=0.25*Z
      Z=Z-1.
      IF(Z.LE.0) GO TO 223
      F=F-Z
  223 CONTINUE
      IF(L-2.LT.0) THEN
         GO TO 230
      ELSE  IF(L-2.EQ.0)  THEN
         GO TO 235
      END IF
      IF(LX-L.LT.0) THEN
         GO TO 240
      ELSE  IF(LX-L.EQ.0)  THEN
         GO TO 245
      END IF
  225 CONTINUE
      YBF=F*D2
      RETURN
  230 CONTINUE
      IF(Z.LE.0) GO TO 225
      F=F+CBC11*(1.-XS)
      GO TO 225
  235 CONTINUE
      IF(XS.GE.0) GO TO 225
      F=F-CBC12*XS
      GO TO 225
  240 CONTINUE
      IF(Z.LE.0) GO TO 225
      F=F+CBCX1*(1.+XS)
      GO TO 225
  245 CONTINUE
      IF(XS.LE.0) GO TO 225
      F=F+CBCX2*XS
      GO TO 225
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE PR1FKM(A,FKMN,KP1,KP2)
C
      PARAMETER (NDIM=71)
      PARAMETER (KDTDIM=5)
C
C     ** ** EXTERNALS MUST BE DECLARED ** **
C
      EXTERNAL Y1BF,D1YBF,DD1YBF
C
      COMMON /S1KOMP/ IDSPK(KDTDIM),IDVAR(KDTDIM),KPX
      COMMON /S1NODE/ NXX,DYN,YN(NDIM)
C
      DIMENSION A(KDTDIM,NDIM),FKMN(KDTDIM,NDIM)
C
      CHARACTER*40 IDSPK
C
      CALL SL1NTA(A,1,NXX,1)
      CALL SL1NTD(Y1BF)
C
      DO KP=KP1,KP2
         CALL SL1NTO(A,KP,FKMN,KDTDIM,NDIM,KP)
      ENDDO
C
c && 4 comments
CC    DO KP=KP1,KP2
CC       WRITE(6,21) KP,IDSPK(KP),(YN(N),FKMN(KP,N),N=1,NDIM)
CC    ENDDO
CC 21 FORMAT(//15X,'KP=',I3,5X,A40,/,(25X,F6.1,F13.8,/))
C
      RETURN
C
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      BLOCK DATA IBM4
      PARAMETER (KDTDIM=5)
      COMMON /S1PRIC/ NX,KDCTYP,KBCTYP(2),YN1,YNXX,YDCWL,
     1        YBCWL(2),IDSPC
      COMMON /S1KOMP/ IDSPK(KDTDIM),IDVAR(KDTDIM),KPX
      COMMON /ZETAC/ CPA,CPB,CSTR,CPSTR0,CZ0,CZ1,CZ2,CZ3,CP00
C
      CHARACTER*125 IDSPC
      CHARACTER*40 IDSPK
      DATA  IDSPC/' '/
      DATA KPX/KDTDIM/
      DATA CPA/1012./,CPB/70./,CSTR/5./,CPSTR0/700./,CP00/0.001/
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
C.                SL1RGO **   11/20/84
C
C     ++ ASSUMED DIM PARAMETERS ... NDIM=71
C
C
      SUBROUTINE SL1RGO
C
C     ** ONE-D VERSION OF THE EARLIER TWO-D SPLINE ROUTINES **
C          PERIODIC BC IS NOT ALLOWED AT THIS TIME (03/31/79)
C
      PARAMETER (NDIM=71)
C
C     ** NODAL CONSTANTS
      COMMON /S1NODE/ NXX,DYN,YN(NDIM)
C
C
C
C     ** ** SL1RGO BEGINS ** **
C
c && 2 comments
CC    IZERO = 0
CC    INSEC = ISECND(IZERO)
C
C     ** PREPARE FOR GT1AMR.  SL1MAC ASSUMES /S1DTPT/ HAS BEEN DEFINED.
      CALL SL1MAC
C
C     ** INITIALIZE THE N-MATRIX ROUTINES
      CALL PASD1X(NXX)
C
C     ** ZERO MATRICES
      CALL CL1ADE
C
C     ** MATRIX INVERSION
      CALL CA1DMM
C
c && 3 comments
CC    IDELTA = ISECND(INSEC)
CC    WRITE(6,880) IDELTA
CC880 FORMAT(/' === SL1RGO DONE ===',T91,'ELAPSED TIME=',I6)
      RETURN
C
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
C                             AMM IS SQUARE MATRIX
      SUBROUTINE SL1GET(AMM)
C          ENTRY GT1AMR (AMM)
C
      PARAMETER (NDIM=71)
ccccc PARAMETER (LDXDIM=2500)
      PARAMETER (LDXDIM=8000)
C
C     ** DATA POINTS INFORMATION **
C
      COMMON/S1DTPT/IDSPD1,IDSPD2,LDX,YD(LDXDIM),WD(LDXDIM),
     1               LXSORT(LDXDIM)
C
C     DUMMY ARGUMENTS ... AMM,IS SQUARE MATRIX  (OCT 79)
      DIMENSION AMM(NDIM,NDIM)
C
C     LOCAL WORK SPACE
      DIMENSION ROWM(NDIM,4)
C
C     OTHER CONSTANTS
      COMMON /S1PRIC/ NX,KDCTYP,KBCTYP(2),YN1,YNXX,YDCWL,
     1        YBCWL(2),IDSPC
      COMMON /S1NODE/ NXX,DYN,YN(NDIM)
C     LOCAL CONSTANTS FOR SL1ADQ
      COMMON /S1MACQ/ NXX1,NX1,NX2,NX3
      CHARACTER*8 IDSPD1,IDSPD2*72,IDSPC*125
C
C     INPUT TO SL1MAC VIA /S1DTPT/
C      YD      Y COORDINATES OF DATA POINTS
C      WD      WEIGHTS ON DATA AT INDIVIDUAL DATA POINTS
C              MUST HAVE BEEN SET BEFORE SL1MAC IS CALLED
C              ++ TO AVOID POSSIBLE HANG UP IN GT1AMR, WD WILL BE
C                 SET NEGATIVE IF XD OR YD IS OFF LIMITS.
C              ANY POINTS WITH ZERO OR NEGATIVE WEIGHT WILL NOT BE
C              INCLUDED IN THE ROWM ACCUMULATION BY SL1MAC/GT1AMR
C      LDX     MAX NUMBER OF DATA POINTS.  MUST BE .LE. LDXDIM
C      IDSPD   ID OF THE DATA POINT SET, AND EXPLANATION (80 CHARACTERS)
C
C     INPUT TO GT1AMR
C
C     OUT FROM GT1AMR
C      AMM     (N,N) MATRIX AT (M,M) DIAGONAL
C     +++ +++ NRT1S0 IS USED TO TRANSFORM REC ARRAYS TO SQUARE ARRAYS ++
C
C     LOCAL ARRAYS
C      ROWM    WILL BE ACTIVE DURING SL1RGO EXECUTION
C
C

      SAVE

C-----------------------------------------------------------------------

C     ** DEFINE /S1MACQ/ FOR THE USE BY SL1ADQ
      ENTRY SL1MAC
      NXX1=NXX+1
      NX1=NX-1
      NX2=NX-2
      NX3=NX-3
C
C     ** INITIALIZATION FOR GT1AMR **
C
C     CHECK DATA POINTS AND WEIGHTS
C       ONLY DATA INSIDE DOMAIN ARE ACCEPTED
C
      LDOK=0
      LDOFF=0
      DO 84 LD=1,LDX
C       IGNORE IF THE WEIGHT IS ALREADY MARKED OFF
      IF(WD(LD).LE.0.) GO TO 84
C       CHECK FOR OFF-LIMIT POINTS
      IF(YD(LD) .LT. YN1 .OR. YD(LD) .GT. YNXX)  GO TO 82
C       ACCEPTED POINTS
      LDOK=LDOK+1
      GO TO 84
C       OFF THE LIMITS.  WD SET TO NEGATIVE
   82 WD(LD)=-ABS(WD(LD))
      WRITE(6,830) YD(LD)
  830 FORMAT(10X,'REJECTED DATA POINT...  YD=',F8.2)
      LDOFF=LDOFF+1
   84 CONTINUE
C
      WRITE(6,885) LDX,LDOK,LDOFF
  885 FORMAT(/' === SL1MAC DATA POINTS CHECK.      LDX=',I6,
     1    ' (INPUT TOTAL COUNT)',/,36X,'LDOK=',I6,' (ACCEPTED BY ',
     2    'SL1MAC)',/,35X,'LDOFF=',I6,' (REJECTED.  WD REDEFINED)')
C
C     QUIT, IF LDOK IS ZERO
      IF(LDOK.LE.0) GO TO 91
C
C
C
      ROWM=0.
C
      DY0=1./DYN
      ID=0
C
      CALL SL1QBG
C
      RETURN

C-----------------------------------------------------------------------

C
C
      ENTRY GT1AMR(AMM)
C
C     CHECK IF UNPROCESSED DATA STILL REMAIN
  110 IF(ID.GE.LDX) GO TO 120
      ID=ID+1
      if(ID .GT. LDXDIM)  THEN
         print *, 'LDXDIM limit (',LDXDIM,') exceeded - ',
     $    'ID=',ID,', return'
         return
      endif
      LD=LXSORT(ID)
      Y=YD(LD)
      W=MIN(WD(LD),1.0)
      IF(W.LE.0.) GO TO 110
C
C     ** ROWM ACCUMULATION **
      NA1=MAX(INT((Y-YN1)*DY0),1)
      NAX=MIN(NA1+3,NXX)
C
      DO NA=NA1,NAX
      WMABNA=Y1BF(NA,Y)*W
      DO NB=NA,NAX
      NR=NB-NA+1
      ROWM(NA,NR)=ROWM(NA,NR)+Y1BF(NB,Y)*WMABNA
      ENDDO
      ENDDO
C
      GO TO 110
C
C
C     NO MORE DATA POINTS LEFT IN THE PRESENT ACCUMULATION RANGE
C
C     ADD Q
C
  120 CALL SL1ADQ(ROWM)
C
C     TRANSFER RESULTS TO AMM
C
      CALL NRT1S0(ROWM,AMM)
C
      RETURN
C
C     ** ERROR EXITS **
C
   91 WRITE(6,891)
  891 FORMAT(' === SL1MAC CALLS EXIT.  NO ACCEPTED DATA POINTS.')
      CALL ABRT1(' SL1MAC',891)
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE SL1QBG
C
      COMMON /S1BCDC/ DY0,DY1,DY2,CBCBF(4),YSDCPI
C
      COMMON /S1QRBG/ QNRBG(5,4,4)
C
C     ** STRUCTURE OF QNRBG (I,J,K)  (FOR ANY K)
C
C   I   J= 1         2         3         4
C
C              QUADRATURE INTEGRAL TERMS               THE ORDER OF DERI
C   1     1,1       1,2       1,3       1,4                 IN QUADRATUR
C   2     2,2       2,3       2,4       2,5
C   3     3,3       3,4       3,5       3,6              K=1   0TH ORDER
C   4    NX,NX    NX1,NX    NX2,NX    NX3,NX               2   1ST ORDER
C   5   NXX,NXX    NX,NXX   NX1,NXX   NX2,NXX              3   2ND ORDER
C                                                          4   3RD ORDER
C
C     ORTHO- AND PARA-ELEMENTS ARE PARTIAL QUADRATURES OF BF AND DERIVAT
C
      DIMENSION QO11(4),QO12(4),QO22(4),QP11(4),QP12(4),QP22(4)
C
      DATA QO11/0.530357142857143, 0.63750, 2.250, 20.25/,
     1     QO12/0.057589285714286, 0.13125,-1.125, -6.75/,
     2     QO22/0.008928571428571, 0.11250, 0.750,  2.25/,
     3     QP11/0.416517857142857,-0.54375,-1.125,-20.25/,
     4     QP12/0.026785714285714,-0.22500, 0.000,  6.75/,
     5     QP22/0.000446428571429,-0.01875, 0.375, -2.25/
C
C
C     ** THE NORMAL NO-PRINT ENTRY
C
C     FOR INTERIOR NODES

      QNRBG(3,1,:)= 2.*(QO11(:)+QO22(:))
      QNRBG(3,2,:)= 2. *QO12(:)+QP11(:)
      QNRBG(3,3,:)= 2. *QP12(:)
      QNRBG(3,4,:)=     QP22(:)

      DO K=1,4
         DO I=2,4
            QNRBG(I,3,K)=QNRBG(3,3,K)
         ENDDO
         DO I=1,5
            QNRBG(I,4,K)=QNRBG(3,4,K)
         ENDDO
      ENDDO
C
C     FOR BOUNDARY NODES
      ZN11=4.*CBCBF(1)
      ZN12=4.*CBCBF(2)
      ZNX1=4.*CBCBF(3)
      ZNX2=4.*CBCBF(4)
C
      DO 22 K=1,4
      QNRBG(1,1,K)=QO11(K)+QO22(K)+ZN11*(2.*QO12(K)+ZN11*QO22(K))
      QNRBG(1,2,K)=QP11(K)+QO12(K)+ZN12*(QO12(K)+ZN11*QO22(K))
     1             +ZN11*QP12(K)
      QNRBG(1,3,K)=2.*QP12(K)+ZN11*QP22(K)
      QNRBG(2,1,K)=2.*QO11(K)+QO22(K)+ZN12*(2.*QP12(K)+ZN12*QO22(K))
      QNRBG(2,2,K)=2.*QO12(K)+QP11(K)+ZN12*QP22(K)
      QNRBG(4,1,K)=2.*QO11(K)+QO22(K)+ZNX2*(2.*QP12(K)+ZNX2*QO22(K))
      QNRBG(4,2,K)=2.*QO12(K)+QP11(K)+ZNX2*QP22(K)
      QNRBG(5,1,K)=QO11(K)+QO22(K)+ZNX1*(2.*QO12(K)+ZNX1*QO22(K))
      QNRBG(5,2,K)=QP11(K)+QO12(K)+ZNX2*(QO12(K)+ZNX1*QO22(K))
     1             +ZNX1*QP12(K)
      QNRBG(5,3,K)= 2.*QP12(K)+ZNX1*QP22(K)
   22 CONTINUE
C
C     ** MULTIPLY DC-FACTORS **
C
      DO K=2,4
      KK=2*(K-1)
      Z2=YSDCPI**KK
      DO J=1,4
      DO I=1,5
      QNRBG(I,J,K)=Z2*QNRBG(I,J,K)
      ENDDO
      ENDDO
      ENDDO
C
      RETURN

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE SL1ADQ(PNMR)
C
C
      PARAMETER (NDIM=71)
C
      COMMON /S1PRIC/ NX,KDCTYP,KBCTYP(2),YN1,YNXX,YDCWL,
     1        YBCWL(2),IDSPC
      COMMON /S1NODE/ NXX,DYN,YN(NDIM)
C
      COMMON /S1QRBG/ QNRBG(5,4,4)
      COMMON /S1MACQ/ NXX1,NX1,NX2,NX3
      CHARACTER*125 IDSPC
C
      DIMENSION PNMR(NDIM,4)
      DIMENSION QNMG(5,4)
C
      QNMG=0.
C
C
C     ** TEST KDCTYP   === TYPE 2 AND 3 ARE PRESENTLY ALLOWED ===
C
      IF(KDCTYP-2.LT.0) THEN
         GO TO 90
      ELSE  IF(KDCTYP-2.EQ.0) THEN
         GO TO 50
      END IF
C
C     THIRD ORDER CONSTRAINT ... KDCTYP=3
C
C     SYMMETRIC BODY TERMS

      QNMG=QNRBG(:,:,4)
C
C
C     ** ADD QNMG TO PNMR
C
   40 CONTINUE
      DO NR=1,4
         DO N=1,2
            PNMR(N,NR)=PNMR(N,NR)+QNMG(N,NR)
         ENDDO
         DO N=3,NX2
            PNMR(N,NR)=PNMR(N,NR)+QNMG(3,NR)
         ENDDO
      ENDDO
      DO N=NX1,NXX
         NRX=NXX1-N
         DO NR=1,NRX
            PNMR(N,NR)=PNMR(N,NR)+QNMG(NR+5-NRX,NR)
         ENDDO
      ENDDO
C
      RETURN
C
C
C     SECOND ORDER CONSTRAINT ... KDCTYP=2
C
   50 CONTINUE

      QNMG=QNRBG(:,:,3)

      GO TO 40
C
C
   90 WRITE(6,890) KDCTYP
  890 FORMAT(/' === SL1ADQ DOES NOT ACCEPT   KDCTYP=',I2)
      CALL ABRT1(' SL1ADQ',890)
C
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE AD1EXX
C
      PARAMETER (NDIM=71)
      PARAMETER (KDTDIM=5)
ccccc PARAMETER (LDXDIM=2500)
      PARAMETER (LDXDIM=8000)
C
C     DUMMY ARGUMENTS ARE NOW IN BLANK COMMON FOR VAX-11
      COMMON // A(KDTDIM,NDIM),FD(KDTDIM,LDXDIM),FKMN(KDTDIM,NDIM),
     1          AMM(NDIM,NDIM),DMM(NDIM,NDIM)
C

C-----------------------------------------------------------------------

      ENTRY CL1ADE
C
      CALL CL1ANS(AMM)
      CALL CL1ANS(DMM)
      RETURN
C
C
C

C-----------------------------------------------------------------------

      ENTRY CA1DMM
C
      CALL GT1AMR(AMM)
C
      CALL NEG1NV(AMM,DMM)
C
      RETURN
C
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE PAS1XS(NXX,BR,BS,CS)
C
C     ** COLLECTION OF N-MATRIX ROUTINES FOR SPLEFSK
C
C     ** PASD1X MUST BE CALLED, ONCE FOR ALL,
C        BEFORE ANY ENTRIES, BELOW, ARE CALLED.
C
C
C  ++++++++ THE LIST OF N-MATRIX ROUTINES ++++++++
C
C    SUB NAMES   ENTRY NAMES            OPERATIONS
C
C     PASD1X     NRT1S0(BR,CS)          CS=   BR
C                NEG1NV(BS,CS)          CS=-INV(BS)
C
C     PASD1S     itself                 CS=AS*BS+CS
C                CL1ANS (CS)            CS=0.
C
C     PASD1R     AN1RTD (BR,CD)         CD=   BR
C                AN1TPD (BR,CD)         CD=TP(BR)
C
C         AS,BS,CS  NDIM*NDIM SQUARE MATRICES
C            BR,CR  NDIM*4 RECTANGLE MATRICES
C               CD  NDIM*7 RECTANGLE MATRICES (DOUBLE R)
C
C         CS,CR,CD  ARE ALWAYS THE OUTPUT
C         BS OR BR  MAY SHARE THE SAME ADDRESS WITH CS OR CR, RESPECTIVE
C               AS  MUST HAVE ITS OWN ADDRESS DIFFERENT FROM BS,BR,CS,OR
C
C     ** WORK SPACE IS PROVIDED LOCALLY FOR
C         ZD(NDIM,7) IN PASD1X
C         ZV(NDIM)   IN PASD1S
C
C     ** DO INDEX CONSTANTS ARE GENERATED IN /PASDCC/ BY PASD1X
C
C
      PARAMETER (NDIM=71)
C
C     DUMMY ARGUMENTS
      DIMENSION BS(NDIM,NDIM),CS(NDIM,NDIM),BSD(NDIM,NDIM)
      DIMENSION BR(NDIM,4)   ,CSD(NDIM,NDIM)
      DOUBLE PRECISION BSD,CSD,DET
C
C      LOCAL WORK SPACE
      DIMENSION ZD(NDIM,7)
C
      COMMON /PASDCC/ IXX,IX,IX1,IX2
C
C-----------------------------------------------------------------------

C
C     ENTRY PASD1X(NXX)    ... MUST BE CALLED TO DEFINE DO INDEX CONSTAN
C
      ENTRY PASD1X(NXX)
      IXX=NXX
      IX =IXX-1
      IX1=IX-1
      IX2=IX-2
C
      IF(NXX.LE.NDIM) RETURN
C
      WRITE(6,800) NXX,NDIM
  800 FORMAT(/' === PASD1X FOUND NXX .GT. NDIM ===',3X,2I6)
      CALL ABRT1(' PASD1X',800)

C-----------------------------------------------------------------------
C
      ENTRY NRT1S0(BR,CS)
C
      CALL AN1RTD (BR,ZD)
C
      DO I=1,IXX
         CS(I,1:IXX)=0.
         DO J=MAX(I-3,1),MIN(I+3,IXX)
            CS(I,J)=ZD(I,J+4-I)
         ENDDO
      ENDDO
      RETURN

C-----------------------------------------------------------------------
C
C
      ENTRY NEG1NV(BS,CS)
C
C     COPY BS INTO DOUBLE PRECISION ARRAY
C
      BSD(1:IXX,1:IXX)=BS(1:IXX,1:IXX)
C
      CALL INVMTX(BSD,NDIM,CSD,NDIM,IXX,DET,ZD,IER)
C
      IF(IER.GT.1) GO TO 54
C
      CS(1:IXX,1:IXX)=CSD(1:IXX,1:IXX)

      RETURN
C
C
   54 WRITE(6,854) IER,DET
  854 FORMAT(/' === NEG1NV/INVMTX FOUND BS TO BE SINGULAR.   IER=',I2,
     1    3X,D12.3)
      CALL ABRT1(' NEG1NV',854)
C
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE CL1ANS (CS)
C
      PARAMETER (NDIM=71)
C
      DIMENSION CS(NDIM,NDIM)
C
      COMMON /PASDCC/ IXX,IX,IX1,IX2
C
      CS(1:IXX,1:IXX)=0.

      RETURN

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE PASD1R(BR,CD)
C
      PARAMETER (NDIM=71)
C
C     DUMMY ARGUMENTS
      DIMENSION BR(NDIM,4),CD(NDIM,7)
C
      COMMON /PASDCC/ IXX,IX,IX1,IX2
C

C-----------------------------------------------------------------------

C
      ENTRY AN1RTD (BR,CD)
C
      lgo = 16
C
C      EXPAND BR TO DOUBLE RECTANGLE ARRAY, CD(NDIM,7)
C     ** THE UN-USED CORNERS OF CD ARE NOT CLEARED.
C
   10 CONTINUE
      CD(1:IXX,4:7)=BR(1:IXX,:)
C
      DO J=1,3
         DO I=5-J,IXX
            CD(I,J)=BR(I+J-4,5-J)
         ENDDO
      ENDDO
C
      if(lgo.eq.16)  then
         go to 16
      else  if(lgo.eq.18)  then
         go to 18
      else
         call ABRT1(' AN1RTD',16)
      endif
C
C     ADD OR SUBTRACT ANTISYMMETRIC TERMS
   16 CD(1,5)=CD(1,5)+CD(IXX,6)
      CD(2,3)=CD(2,3)-CD(IXX,6)
      CD(IXX-1,5)=CD(IXX-1,5)+CD(IXX-1,7)
      CD(IXX  ,3)=CD(IXX  ,3)-CD(IXX-1,7)
      RETURN

C-----------------------------------------------------------------------

C
C
      ENTRY AN1TPD (BR,CD)
C
      lgo = 18
      GO TO 10
C
C      REVERSE THE SIGN OF ANTISYMMETRIC TERMS (TRANSPOSE)
   18 CD(IXX  ,6)=-CD(IXX  ,6)
      CD(IXX-1,7)=-CD(IXX-1,7)
      GO TO 16

C-----------------------------------------------------------------------
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
C.                SL1MBO **   11/20/84
C     ++ ASSUMED DIM PARAMETERS ... NDIM=71, LDXDIM=8000,
C                               ... KDTDIM=5
C
C
      SUBROUTINE SL1MBO(KP1,KP2)
C
C     ** NODAL SPLINE AMPLITUDES A(K,N) FROM DATA FD(K,L)**
C
C
      PARAMETER (NDIM=71)
ccccc PARAMETER (LDXDIM=2500)
      PARAMETER (LDXDIM=8000)
      PARAMETER (KDTDIM=5)
C
C     ** SECONDARY PARAMETERS FOR COMPILATION
C
C     ** DUMMY ARGUMENTS
C
C      DIMENSION FD(KDTDIM,LDXDIM),A(KDTDIM,NDIM)
C
C
C              FD(K,L)   K-TH COMPONENT OF FIELD DATA AT LOCATION L
C              KP1       FIRST COMPONENT K TO BE PROCESSED
C              KP2       LAST  COMPONENT K TO BE PROCESSED
C
C     OUTPUT   A(K,N)  NODAL AMPLITUDE OF K-TH COMPONENT AT NODE N
C
C
C
C        $$ SL1OVR WAS CALLED TO DEFINE CONSTANTS IN SEVERAL COMMONS
C
C        $$ DATA POINTS WERE DEFINED IN /S1DTPT/ INCLUDING WEIGHTS
C
C     ** EXPLICITLY REQUIRED COMMONS
C
      COMMON // A(KDTDIM,NDIM),FD(KDTDIM,LDXDIM),FKMN(KDTDIM,NDIM),
     1          AMM(NDIM,NDIM),DMM(NDIM,NDIM)
C
      COMMON /S1NODE/ NXX,DYN,YN(NDIM)
      COMMON/S1DTPT/IDSPD1,IDSPD2,LDX,YD(LDXDIM),WD(LDXDIM),
     1               LXSORT(LDXDIM)
C
      CHARACTER*8 IDSPD1,IDSPD2*72
C
C     ** LOCAL WORK SPACE
C
      DIMENSION ZV(NDIM,KDTDIM)
C
C
c && 4 comments
CC    IZERO = 0
CC    INSEC = ISECND(IZERO)
CC    WRITE(6,800) INSEC
CC800 FORMAT(/' === SL1MBO BEGINS ===',T91,'SECOND=',I6)
C
C
      KA=MIN(KP1,KP2)
      KB=MAX(KP1,KP2)
      IF(KB.GT.KDTDIM) GO TO 90
C
      A(KA:KB,1:NXX)=0.
C
C
C     ** CONSTANTS FOR CONVENIENCE
      YN1=YN(1)
      DY0=1./DYN
C
C
C     ** CONVERSION OF DISCRETE FIELD DATA TO NODAL FORCING **
C
      DO18 L=1,LDX
C
      IF(WD(L).LE.0) GO TO 18
      NA=MAX(INT((YD(L)-YN1)*DY0),1)
      NB=MIN(NA+3,NXX)
C
      DO N=NA,NB
         WMN=Y1BF(N,YD(L))*MIN(WD(L),1.0)
         DO K=KA,KB
            A(K,N)=A(K,N)+WMN*FD(K,L)
         ENDDO
      ENDDO
C
   18 CONTINUE
C
C
C     ** CONVERSION OF NODAL FORCING TO NODAL AMPLITUDES **
C       +++ WE RETURN TO THE RIGHT-HANDED FORCING +++
C       +++ THE LEFT-HANDED CONVENTION IN PLIB SPLEND IS NOT USED +++
C
C
      DO K=KA,KB
         ZV(1:NXX,K)=0.0
         DO I=1,NXX
            DO J=1,NXX
               ZV(I,K)=ZV(I,K)+DMM(I,J)*A(K,J)
            ENDDO
         ENDDO
      ENDDO
      DO K=KA,KB
         DO N=1,NXX
            A(K,N)=ZV(N,K)
         ENDDO
      ENDDO
C
c && 3 comments
CC    IDELTA = ISECND(INSEC)
CC    WRITE(6,880) IDELTA
CC880 FORMAT(' === SL1MBO DONE ===',T91,'ELAPSED TIME=',I6)
C
      RETURN
C
C     ** ERROR EXIT
C
   90 WRITE(6,890) KP1,KP2,KDTDIM
  890 FORMAT(/' === SL1MBO FOUND THE COMPONENT RANGE  K=',I2,',',I2,
     1       '  EXCEEDED  KDTDIM=',I2)
      CALL ABRT1(' SL1MBO',890)
      END


C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE SP1LNT(A,KPA,F,KPFDIM,NFDIM,KPF,N1,N2,N3,ZYBF)
C
C
C
      PARAMETER (NDIM=71)
      PARAMETER (KDTDIM=5)
C
C     ** DUMMY ARGUMENTS
C
C     ** INPUT ... SPLINE AMPLITUDE
      DIMENSION A(KDTDIM,NDIM)
C
C     ** OUTPUT ..
      DIMENSION F(KPFDIM,NFDIM)
C
C     ** PARAMETER FOR THE LOCAL USE ... MAXIMUM DIVISIONS ALLOWED
      PARAMETER (JXBFDM=8)
C
C     ** LOCAL ARRAYS ... BF TABLES
      DIMENSION YB1(4,JXBFDM),YBN(4,JXBFDM),YBX(4,JXBFDM),YBXX(4)
C     ** LOCAL WORK SPACE
      CHARACTER*7 KENTRY
C
      COMMON /S1NODE/ NXX,DYN,YN(NDIM)
      DATA KENTRY/' SP1LNT'/
C
      SAVE
C
C-----------------------------------------------------------------------

      ENTRY SL1NTA(A,N1,N2,N3)
      KENTRY = 'SL1NTA'
C
C
C       LOCALLY DEFINED
      NX=NXX-1
      NX1=NX-1
      IF(NXX.GT.NDIM) GO TO 900
C
C     ** SET CONSTANTS FOR DEFINING THE AREA AND SUBDIVISIONS
C
      NA=MIN(N1,N2)
      NB=MAX(N1,N2)
      JX=MAX(N3,1)
      IF(NA.LT.1)   GO TO 901
      IF(NB.GT.NXX) GO TO 901
C
      IF(JX.GT.JXBFDM) GO TO 905
C
C
      NAIL=MAX(NA,2)
      NBIL1=MIN(NB,NX1)
      NBIL2=MIN(NB-1,NX1)
C
C     ** MINIMUM DIMENSIONS REQUIRED OF THE OUTPUT FIELD
C
      NFDIM0=JX*(NB-NA)+1
C
C     ** ROUTING DECISIONS
C
      lgon1 = 120
      lgonx = 150
C
      IF(NA.EQ.1)   lgon1 = 110
      IF(NB.EQ.NXX)  then
         lgonx = 126
      else  IF(NB.EQ.NX)  then
         lgonx = 128
      endif
C
      RETURN

C-----------------------------------------------------------------------

C
C
C     ** INPUT ... THE SPLINE BASIS FUNCTIONS
C
C     ZXBF     XBF,DXBF, OR DDXBF
C     ZYBF     Y1BF,D1YBF, OR DD1YBF
C
C     ** ** ** WARNING ** ** **
C
C       THERE IS NO DEFAULT SETTING OF ZYBF.
C         SL1NTD MUST BE CALLED, AT LEAST ONCE, TO DEFINE THE BF TABLES
C
C     ** WARNING **
C       DO NOT SHORTCUT SL1NTD WITHIN THIS SUBROUTINE ALTHOUGH IT MAY
C       SEEM TO BE UNNECESSARY WHEN N3 IS UNCHANGED.
C
C       SINCE ZYBF MAY BE CHANGED, ONLY THE CALLING ROUTINE
C       CAN DETERMINE THE NEED OF CALLING SL1NTD ANEW.
C
C       SIMILARLY, THE TEST OF N3 BY SL1NTO IS NO GUARANTEE FOR
C       CORRECT BF TABLES, IF THERE WERE OMISSION OF CALLING SL1NTD.
C
C

C-----------------------------------------------------------------------

      ENTRY SL1NTD(ZYBF)
C
C     ** SAVE THE CURRENT JX(=N3)
      JXBF0=JX
C
      DYNJ=DYN/REAL(JX)
C
      DO 64 J=1,JX
      YNJ=(J-1)*DYNJ
C
      DO ND=0,2
         YB1(2+ND,J)=ZYBF(1+ND,YN(1)+YNJ)
      ENDDO
C
      DO ND=-1,2
         YBN(2+ND,J)=ZYBF(3+ND,YN(3)+YNJ)
      ENDDO
C
      DO ND=-1,1
         YBX(2+ND,J)=ZYBF(NX+ND,YN(NX)+YNJ)
      ENDDO
   64 CONTINUE
C
      DO ND=-1,0
         YBXX(2+ND)=ZYBF(NXX+ND,YN(NXX))
      ENDDO
C
      RETURN

C-----------------------------------------------------------------------

      ENTRY SL1NTO(A,KPA,F,KPFDIM,NFDIM,KPF)
      KENTRY = 'SL1NTO'
C
      KA=KPA
      KF=KPF
C
C     ** CHECK THE INPUT ARGUMENTS
      IF(KPA.GT.KDTDIM) GO TO 902
      IF(KPF.GT.KPFDIM) GO TO 910
C
      IF(NFDIM.LT.NFDIM0) GO TO 910
C
C
      IF(JX.NE.JXBF0) GO TO 920

      F(KF,:)=0.
C
      DO 300 J=1,JX
C
      IF(J-2.EQ.0) THEN
         GO TO 102
      ELSE  IF(J-2.GT.0) THEN
         GO TO 103
      END IF
C
C       ON THE N-NODES (J=1)
      NDX=1
      NBIL=NBIL1
      GO TO 103
C
C       OFF-NODE FINE MSESH POINTS
  102 NDX=2
      NBIL=NBIL2
C
  103 CONTINUE
C
C
      if(lgon1.eq.110)  then
         go to 110
      else  if(lgon1.eq.120)  then
         go to 120
      else
         call ABRT1(' SL1NTO',103)
      endif
C
C       AT N=1. (FOR NA=1 ONLY)
  110 CONTINUE
      DO ND=0,NDX
         F(KF,1)=A(KA,1+ND)*YB1(2+ND,J)+F(KF,1)
      ENDDO
C
C       AT ALL N BETWEEN NAIL AND NBIL, BUT NBIL IS.LE. NX1
C         NOTE ... THE SECOND DO WILL NOT EXECUTE IF NAIL .GT. NBIL
C
  120 CONTINUE
      DO ND=-1,NDX
      DO N=NAIL,NBIL
         F(KF,N)=A(KA,N+ND)*YBN(2+ND,J)+F(KF,N)
      ENDDO
      ENDDO
C
C      CHECK THE LEFT LIMIT OF ACCUMULATION
      if(lgonx.eq.126)  then
         go to 126
      else  if(lgonx.eq.128)  then
         go to 128
      else  if(lgonx.eq.150)  then
         go to 150
      else
         call ABRT1(' SL1NTO',126)
      endif
  126 IF(J.EQ.1) GO TO 130
      GO TO 140
  128 IF(J.EQ.1) GO TO 140
      GO TO 150
C
C       ONLY FOR J=1 AND NB=NXX
  130 CONTINUE
      DO ND=-1,0
         F(KF,NXX)=A(KA,NXX+ND)*YBXX(2+ND)+F(KF,NXX)
      ENDDO
C
C       FOR ALL J IF NB=NXX(ENTERS FROM 132)
C       ONLY FOR J=1 IF NB=NX
C
  140 CONTINUE
      DO ND=-1,1
         F(KF,NX)=A(KA,NX+ND)*YBX(2+ND,J)+F(KF,NX)
      ENDDO
C
  150 CONTINUE
C
C
  300 CONTINUE
C
C
      RETURN
C
C
C     ** ERROR EXITS
C
  900 WRITE(6,8900) NXX,NDIM
 8900 FORMAT(/' === SL1NTA FOUND NXX TOO LARGE FOR NDIM'
     1   ,5X,I5,5X,I5)
      CALL ABRT1(KENTRY,8900)
C
  901 WRITE(6,8901) N1,N2,NXX
 8901 FORMAT(/' === SL1NTA INPUT ARGUMENTS N1,N2 ARE IN ERROR'
     1    ,5X,I5,3X,I5,5X,'NXX IS',3X,I5)
      CALL ABRT1(KENTRY,8901)
C
  902 WRITE(6,8902) KPA,KDTDIM
 8902 FORMAT(/' === SL1NTO ARGUMENT KPA IS TOO LARGE FOR KDTDIM',5X,2I3)
      CALL ABRT1(KENTRY,8902)
C
  905 WRITE(6,8905) N3,JXBFDM
 8905 FORMAT(/' === SL1NTA INPUT ARGUMENTS N3 ARE TOO LARGE FOR '
     1    ,'THE LOCAL PARAMETER JXBFDM',5X,I3,5X,I3)
      CALL ABRT1(KENTRY,8905)
C
  910 WRITE(6,8910) KPFDIM,NFDIM,NFDIM0
 8910 FORMAT(/' === SL1NTO ARGUMENTS KPFDIM,NFDIM ARE TOO SMALL '
     1   ,'FOR THE REQUIRED KPF,NFDIM0', 5X,I3,I5,5X,I3,I5)
      CALL ABRT1(KENTRY,8910)
C
  920 WRITE(6,8920) JX,JXBF0
 8920 FORMAT(/' === SL1NTO FOUND N3 HAVE BEEN CHANGED SINCE THE '
     1   ,'LAST CALL TO SL1NTD WAS MADE',5X,I3,5X,I3)
      CALL ABRT1(KENTRY,8920)
C
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    ????????    ?????????????????????????????????????????
C   PRGMMR: S. J. LORD       ORG: NP22       DATE: ????-??-??
C
C ABSTRACT: ??????????????????????????????????????????????????????????
C   ??????????????????????????????????????????????????????????????????
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD
C
C USAGE:    CALL ????????(????)
C   INPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT ARGUMENT LIST:
C     ??????   - ???????????????????????????????????????????????
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     ??????   - ???????????????????????????????????????????????
C
C   OUTPUT FILES:
C     ??????   - ???????????????????????????????????????????????
C
C REMARKS: ?????????????????????????????????????????????????????
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE SP1TNO(Y,A,K,F)
C
      PARAMETER (NDIM=71)
      PARAMETER (KDTDIM=5)
C
C
C     ** ** SPOT INVERSE TRANSFORMATION OF A SINGLE SPLINE AMPLITUDE
C            TO F AT Y
C
C       Y        THE SPOT COORDINATE AT WHICH OUTPUT F IS DESIRED
C       A(K,N)   KTH COMPONET OF NODAL AMPLITUDE AT N
C       K        THE  COMPONENT OF THE AMPLITUDE
C       F        THE SPOT OUTPUT F.
C
C     ** DUMMY ARGUMENTS
      DIMENSION A(KDTDIM,NDIM)
C
      COMMON /S1NODE/ NXX,DYN,YN(NDIM)
      EQUIVALENCE (YN(1),Y1)
C
C     ** LOCAL WORK SPACE
      DIMENSION BN(4),ZN(4)
C
C
      N0=MAX(INT((Y-Y1)/DYN),1)-1
      N4=MIN(NXX-N0,4)
C
      DO N=1,N4
         BN(N)=Y1BF(N+N0,Y)
      ENDDO
C
      ZN=0.
C
      DO N=1,N4
         ZN(N)=ZN(N)+A(K,N+N0)*BN(N)
      ENDDO
C
      F=ZN(1)+ZN(2)+ZN(3)+ZN(4)
C
      RETURN
      END


C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    SURPRP      SURVEYS INPUT PREPBUFR FILE FOR PMSL& WND
C   PRGMMR: D. A. KEYSER     ORG: NP22       DATE: 2014-09-05
C
C ABSTRACT: SURVEYS THE INPUT PREPBUFR FILE, LOOKING FOR REPORTS FOR
C   ALL TYPES IN THE VICINITY OF THE TROPICAL STORM IN QUESTION.
C   IF A MASS REPORT IS FOUND, THEN THE SEA-LEVEL PRESSURE (EITHER
C   REPORTED OR CALCULATED) IS USED TO HELP GENERATE BOGUS DATA IN
C   THE VICINITY OF THE STORM.  IF A WIND REPORT IS FOUND, THEN THE
C   WIND ON ALL LEVELS IS USED IN THE SAME WAY. THIS SUBROUTINE CAN
C   PRINT OUT ALL QUALIFYING REPORTS (BASED ON MODPRT SWITCH).
C
C
C PROGRAM HISTORY LOG:
C ????-??-??  S. J. LORD - ORIGINAL AUTHOR
C 1999-06-28  D. A. KEYSER - MADE CODE MORE EFFICIENT BY SKIPPING
C        THE READING OF REPORTS OUT OF BUFR MESSAGES WHICH CAN'T
C        EVER PRODUCE A SEA-LEVEL PRESSURE OR WIND; CORRECTED ERROR
C        WHICH NEVER ALLOWED SURFACE MARINE SEA-LEVEL PRESSURE TO
C        BE USED HERE IN THE VICINITY OF STORM; CORRECTED AN ERROR
C        WHICH USUALLY LED TO 1000 MB PRESSURE/HEIGHT NOT BEING USED
C        HERE TO CALC. SEA-LEVEL PRESSURE IN THE VICINITY OF STORM;
C        NOW CHECKS QUALITY MARK OF PERTINENT VARIABLES IN BOTH
C        MEAN-SEA LEVEL PRESSURE PROCESSING AND WIND PROCESSING FOR
C        REPORTS IN THE VICINITY OF THE STORM, IF Q.M. IS BAD SKIPS
C        PROCESSING (NEVER CHECKED Q.M. BEFORE); CORRECTED ERROR
C        WHICH LED TO REPORT TIME MINUS CYCLE TIME BEING A FACTOR OF
C        100 TOO SMALL (RESULTED IN INCORRECT STORM ADJUSTMENT IN
C        SUBR. SURPRP); STREAMLINED CODE TO MAKE IT MORE EFFICIENT;
C        ADDED DOCBLOCK, COMMENTS, AND MORE STDOUT PRINT
C 1999-09-24  D. A. KEYSER - REPORTS IN SPSSMI MESSAGES NO LONGER
C        PROCESSED (USELESS BECAUSE NO WIND DIRECTION AVAILABLE)
C 2004-09-09  D. A. KEYSER - REPORTS IN NEW MESSAGE TYPE GPSIPW
C        ARE NOT PROCESSED BECAUSE THEY HAVE NEITHER PRESSURE NOR
C        WIND DATA
C 2005-07-01  D. A. KEYSER - REPLACED CALL TO BUFRLIB ROUTINE BORT WITH
C        CALL TO W3LIB ROUTINE ERREXIT
C 2014-09-05  D. A. KEYSER - IF EITHER UOB OR VOB (OR BOTH) ARE
C        MISSING, SKIP THE PROCESSING OF INPUT PREPBUFR WIND REPORT
C        LEVEL (UOB AND/OR VOB CAN NOW BE MISSING FOR SURFACE WIND
C        REPORTS SINCE A RECENT IMPLEMENTATION ALLOWS REPORTS WITH ONLY
C        WIND SPEED OR ONLY WIND DIRECTION TO STORE THESE IN SOB AND
C        DDO, RESP. - PRIOR TO THIS FIX IN SYNDATA, MISSING VALUES FOR
C        UOB AND VOB WERE GENERATING NONSENSICAL BOGUS WINDS OR CAUSING
C        PROGRAM TO ABORT).
C
C USAGE:    CALL SURPRP(IUNTPN,IUNTBH,IUNTDH,PTOP,XMLZ,XMRZ,YNBZ,YNTZ,
C                       RPOT,SPDPOT,NOBWMN,IYRZ,DAY00,NDATA,DATA,
C                       IPRT,IHRD,INDCOM,ONLYWI,ONLYMA,ONLYPS)
C   INPUT ARGUMENT LIST:
C     IUNTPN   - UNIT NUMBER OF INPUT PREPBUFR FILE
C     IUNTBH   - UNIT NUMBER OF OUTPUT BGHISTRY.DIAG FILE
C     IUNTDH   - UNIT NUMBER OF OUTPUT DTHISTRY FILE
C     PTOP     - UPPER PRESSURE (MB) LIMIT FOR EXTRACTING DATA
C     XMLZ     - MINIMUM LONGITUDE LIMIT FOR EXTRACTING DATA
C     XMRZ     - MAXIMUM LONGITUDE LIMIT FOR EXTRACTING DATA
C     YNBZ     - MINIMUM LATITUDE  LIMIT FOR EXTRACTING DATA
C     YNTZ     - MAXIMUM LATITUDE  LIMIT FOR EXTRACTING DATA
C     RPOT     - ???????????????????????????????????????????????
C     SPDPOT   - ???????????????????????????????????????????????
C     NOBWMN   - ???????????????????????????????????????????????
C     IYRZ     - 4-DIGIT YEAR
C     DAY00    - FRACTIONAL NUMBER OF DAYS SINCE 365 DAYS PRIOR TO
C              - 00Z ON NCEP DATE
C     NDATA    - ???????????????????????????????????????????????
C     DATA     - ???????????????????????????????????????????????
C     IPRT     - FLAG TO TURN ON EXTRA STDOUT PRINT
C     IHRD     - ???????????????????????????????????????????????
C     INDCOM   - ???????????????????????????????????????????????
C     ONLYWI   - LOGICAL T/F TO EXTRACT ONLY WIND DATA
C     ONLYMA   - LOGICAL T/F TO EXTRACT ONLY MASS DATA
C     ONLYPS   - LOGICAL T/F TO EXTRACT ONLY MASS DATA
C
C   OUTPUT FILES:
C     UNIT 06  - STANDARD OUTPUT PRINT
C     UNIT "IUNTBH"  - BGHISTRY.DIAG FILE
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE SURPRP(IUNTPN,IUNTBH,IUNTDH,PTOP,XMLZ,XMRZ,YNBZ,YNTZ,
     1                  RPOT,SPDPOT,NOBWMN,IYRZ,DAY00,NDATA,DATA,IPRT,
     2                  IHRD,INDCOM,ONLYWI,ONLYMA,ONLYPS)

      CHARACTER*8 SUBSET,LAST

      DIMENSION   DATA(NDATA),INDCOM(NDATA)

      CHARACTER*8  STAID

      REAL(8) HDR_8(5),OBS_8(4,255),QMS_8(3,255),PSL_8(2),PSFC_8,BMISS

      EQUIVALENCE  (STAID,HDR_8(1))

      LOGICAL     ONLYWI,ONLYMA,ONLYPS,PROCES

      COMMON/BUFRLIB_MISSING/BMISS

      DATA TKEL / 273.16 /
      DATA SST  / 28.0   /
      DATA RGAS / 287.   /
      DATA GRAV / 9.81   /

      SAVE

C-----------------------------------------------------------------------
C-----------------------------------------------------------------------

      WRITE(6,111) XMLZ,XMRZ,YNBZ,YNTZ,ONLYWI,ONLYMA,ONLYPS,IHRD
  111 FORMAT(//' ===> SURPRP: SCANNING PREPBUFR FILE IN THE AREA ',
     $ 'DEFINED BY: XML=',F8.2,', XMR=',F8.2,', YNB=',F8.2,', AND ',
     $ 'YNT=',F8.2/15X,'ONLYWI=',L1,', ONLYMA=',L1,', ONLYPS=',L1//
     $ 15X,'NOTE: The value for "IHRD" should always be ZERO - here ',
     $ 'IHRD =',I4//)

      LAST = 'XXXXXXXX'

      LATMN=YNBZ
      LATMX=YNTZ
      LONMN=XMLZ
      LONMX=XMRZ

C  OPEN PREPBUFR FILE AND PRINT THE DATE
C  -------------------------------------

      CALL DATELEN(10)

      CALL OPENBF(IUNTPN,'IN',IUNTPN)
      CALL READMG(IUNTPN,SUBSET,IDATBF,IRET)
      IF(IRET.NE.0) THEN
         PRINT *, 'SURPRP - ERROR OPENING INPUT PREPBUFR FILE'
         CALL ERREXIT(20)
      END IF
      PRINT 789, IUNTPN,IDATBF
  789 FORMAT(/' ===> SURPRP: INPUT PREPBUFR FILE IN UNIT',I3,
     $ ' SUCCESSFULLY OPENED - SECTION 1 MESSAGE DATE =',I11/)
      WRITE(IUNTBH,*) 'DATE OF INPUT PREPBUFR FILE: ',IDATBF

      KOUNT = 0
      KREC  = 0

      CALL CLOSBF(IUNTPN)
      CALL OPENBF(IUNTPN,'IN',IUNTPN)

C  READ THE NEXT SUBSET
C  --------------------

      ISKPMG = 0
      ICNTOT = 0
      ICNTTA = 0

  300 CONTINUE

      CALL READMG(IUNTPN,SUBSET,IDATBF,IRET)
      IF(IRET.NE.0) GO TO 110
      KREC = KREC + 1
      IF(SUBSET.NE.LAST)  THEN
         ISKPMG = 0
         IF(LAST.NE.'XXXXXXXX')  PRINT 1249, IUNTPN,LAST,ICNTTA
 1249 FORMAT(/' ===> SURPRP: ALL MESSAGES IN INPUT PREPBUFR FILE IN ',
     $ 'UNIT',I3,' WITH TABLE A ENTRY "',A8,'" PROCESSED -- '/15X,
     $ 'NUMBER OF INDIVIDUAL REPORTS DECODED OUT OF THESE MESSAGES =',
     $ I6/)
         ICNTTA = 0
         PRINT 1240, IUNTPN,SUBSET,IDATBF
 1240 FORMAT(/' ===> SURPRP: NEXT MESSAGE IN INPUT PREPBUFR FILE IN ',
     $ 'UNIT',I3,' HAS NEW TABLE A ENTRY OF "',A8,'" - DATE IS',I11/)

C  NO NEED TO DECODE MESSAGES THAT NEVER CONTAIN WIND OR PRESSURE DATA
C   (NOTE: "SATEMP" IN NAM RUNS HAS MISSING HEIGHT ON ALL LEVELS)
C  -------------------------------------------------------------------

         IF(SUBSET.EQ.'GOESND  '.OR.SUBSET.EQ.'SATEMP'.OR.
     $      SUBSET.EQ.'GPSIPW  ') THEN
            PRINT 1261
 1261 FORMAT(/' ===> SURPRP: MESSAGES WITH THIS TABLE A ENTRY WILL ',
     $ 'NEVER BE PROCESSED SINCE NEVER HAVE WIND OR PRESSURE DATA,',
     $ ' DON-T DECODE'/)
            ISKPMG = 1
         ELSE  IF(SUBSET.EQ.'SYNDAT  ') THEN
            PRINT 1861
 1861 FORMAT(/' ===> SURPRP: MESSAGES WITH THIS TABLE A ENTRY WILL ',
     $ 'NEVER BE PROCESSED SINCE THE BOGUS SYNDATA SHOULD NOT BE IN ',
     $ 'THE INPUT PREPBUFR FILE, DON-T DECODE'/)
            ISKPMG = 1
         ELSE  IF(SUBSET.EQ.'SPSSMI  ') THEN
            PRINT 1881
 1881 FORMAT(/' ===> SURPRP: MESSAGES WITH THIS TABLE A ENTRY WILL ',
     $ 'NEVER BE PROCESSED SINCE SSM/I WIND SPEED IS USELESS (NO ',
     $ 'DIRECTION) AND'/15X,'SSM/I TPW IS NOT USED, DON-T DECODE'/)
            ISKPMG = 1
         ELSE
            IF(.NOT.ONLYWI)  THEN

C  IF ONLYWI=F, NO NEED TO DECODE MESSAGES CONTAINING ONLY WIND DATA
C   OR MESSAGES CONTAINING MASS DATA BUT NO PRESSURE
C  -----------------------------------------------------------------

               IF(SUBSET.EQ.'SATWND  '.OR.SUBSET.EQ.'PROFLR  '.OR.
     $            SUBSET.EQ.'VADWND  '.OR.SUBSET.EQ.'ERS1DA  ') THEN
                  PRINT 1241
 1241 FORMAT(/' ===> SURPRP: MESSAGES WITH THIS TABLE A ENTRY WILL ',
     $ 'NEVER BE PROCESSED BASED ON ONLYxx SWITCHES, DON-T DECODE'/)
                  ISKPMG = 1
               END IF
            END IF
            IF(.NOT.ONLYMA.AND..NOT.ONLYPS)  THEN

C  IF ONLYMA & ONLYPS=F, NO NEED TO DECODE MSG CONTAINING ONLY MASS DATA
C  ---------------------------------------------------------------------

               IF(SUBSET.EQ.'SATEMP  '.OR.SUBSET.EQ.'SFCBOG  ') THEN
                  PRINT 1241
                  ISKPMG = 1
               END IF
            END IF
         END IF
         IF(ISKPMG.EQ.0)  PRINT 1242
 1242 FORMAT(/' ===> SURPRP: MESSAGES WITH THIS TABLE A ENTRY MUST BE ',
     $ 'PROCESSED BASED ON ONLYxx SWITCHES, EACH INDIVIDUAL REPORT ',
     $ 'MUST BE DECODED'/)
      END IF

      LAST = SUBSET

      IF(ISKPMG.EQ.1)  THEN
         GO TO 300
      END IF

      ICNT = 0

    1 CONTINUE

      CALL READSB(IUNTPN,IRET)
      IF(IRET.NE.0) GO TO 300
      ICNTTA = ICNTTA + 1
      ICNTOT = ICNTOT + 1

      KOUNT = KOUNT+1
      ICNT  = ICNT+1

C  READ THE NEXT HEADER
C  --------------------

      HDR_8=BMISS
      CALL UFBINT(IUNTPN,HDR_8,5,1,IRET,'SID XOB YOB DHR TYP')
      RLON  = HDR_8(2)
      RLAT  = HDR_8(3)

      IF(NINT(RLAT*100.) .LE. NINT(LATMN*100.)) GOTO 1
      IF(NINT(RLAT*100.) .GE. NINT(LATMX*100.)) GOTO 1
      IF(NINT(RLON*100.) .LE. NINT(LONMN*100.)) GOTO 1
      IF(NINT(RLON*100.) .GE. NINT(LONMX*100.)) GOTO 1

C  MASS/WIND REPORT SELECTION
C  --------------------------

      PROCES=.FALSE.
      IRTYP = HDR_8(5)
      KK    = IRTYP/100
      IF(ONLYWI .AND. KK.EQ.2)  PROCES=.TRUE.
      IF(ONLYMA .AND. KK.EQ.1)  PROCES=.TRUE.
      IF(ONLYPS .AND. KK.EQ.1)  PROCES=.TRUE.
      IF(.NOT. PROCES)  GO TO 1

C  CONVERT OFF CYCLE TIME TO DECIMAL DAYS  (1/24=4.16666E-2)
C  ---------------------------------------------------------

      DHR   = HDR_8(4)
      ROFFT = 4.16666E-2*DHR
      DAYZ  = DAY00+ROFFT
      RLATZ = RLAT
      RLONZ = RLON

C  READ AND GO THROUGH THE DATA IN A REPORT
C  ----------------------------------------

      PSFC_8=BMISS
      MCHOIC = 1
      IF(SUBSET.EQ.'ADPSFC  ')  THEN
         IF(KK.EQ.1)  THEN

C  MASS REPORTS: USE MEAN SEA LEVEL PRESSURE FROM SURFACE REPORTS
C     FIRST CHOICE: ENCODED VALUE "PMO" (ONLY FOR ADPSFC REPORTS)
C  --------------------------------------------------------------

            PSL_8=BMISS
            CALL UFBINT(IUNTPN,PSL_8,2,1,IONE,'PMO PMQ')
            IF(IBFMS(PSL_8(1)).EQ.0) THEN
               IF(NINT(PSL_8(1)*10.).GT.10200)  THEN
                  WRITE(6,9163)  PSL_8(1),STAID,IRTYP,SUBSET,MCHOIC
 9163 FORMAT(/' ***> SURPRP: UNREAL PSFC=',E16.8,' AT STN. ',A8,
     $ ', R.TYPE =',I4,', SUBSET = "',A8,'", MCHOIC =',I2,' - GO ON TO',
     $ ' NEXT REPORT'/)
                  GO TO 1
               ELSE IF(NINT(PSL_8(2)).GT.7)  THEN
                  WRITE(6,9164)  PSL_8(1),NINT(PSL_8(2)),STAID,IRTYP,
     $             SUBSET,MCHOIC
 9164 FORMAT(/' ***> SURPRP: BAD PSFC=',F6.1,', Q.M.=',I2,' AT STN. ',
     $ A8,', R.TYPE =',I4,', SUBSET = "',A8,'", MCHOIC =',I2,' - GO ON',
     $ ' TO NEXT REPORT'/)
                  GO TO 1
               ENDIF
               PSFC_8=PSL_8(1)
               GO TO 1500
            ENDIF
         ENDIF
      ENDIF

      OBS_8=BMISS
      CALL UFBINT(IUNTPN,OBS_8,4,255,NLEV,'POB ZOB UOB VOB')
      QMS_8=BMISS
      CALL UFBINT(IUNTPN,QMS_8,3,255,NLEV,'PQM ZQM WQM')

      IWFLG = 1

      DO MSEL=1,NLEV
         POB = OBS_8(1,MSEL)
         ZOB = OBS_8(2,MSEL)
         UOB = OBS_8(3,MSEL)
         VOB = OBS_8(4,MSEL)
         PQM = QMS_8(1,MSEL)

C  Don't want to consider pressure with q.m. 10 as bad since only
C   this code can aplly this quality mark (downstream of here)

         IF(NINT(PQM).EQ.10)  PQM = -10
         ZQM = QMS_8(2,MSEL)
         WQM = QMS_8(3,MSEL)
         IF(KK.EQ.1)  THEN

C  MASS REPORTS: USE MEAN SEA LEVEL PRESSURE FROM SURFACE REPORTS
C     SECOND CHOICE: ENCODED VALUE "POB" IF AT SEA-LEVEL
C                    (ONLY FOR ADPUPA, SFCSHP AND SFCBOG, REPORTS)
C     THIRD  CHOICE: CALCULATED FROM 1000 MB PRESSURE AND HEIGHT
C                    (ONLY FOR ADPUPA REPORTS)
C  ---------------------------------------------------------------

            IF(NINT(POB*10.).LE.9999.AND.ZOB.GT.7)  GO TO 1
            IF(ZOB.GT.-1.AND.ZOB.LT.8) THEN
               MCHOIC = 2
               IF(NINT(POB*10.).GT.10200)  THEN
                  WRITE(6,9993)  POB,STAID,IRTYP,SUBSET,MCHOIC,ZOB
 9993 FORMAT(/' ***> SURPRP: UNREAL PSFC=',E16.8,' AT STN. ',A8,
     $ ', R.TYPE =',I4,', SUBSET = "',A8,'", MCHOIC =',I2,', ELEV =',
     $ F8.1/15X,' - GO ON TO NEXT REPORT'/)
                  GO TO 1
               ELSE IF(MAX(NINT(PQM),NINT(ZQM)).GT.7)  THEN
                  WRITE(6,9165)  POB,ABS(NINT(PQM)),ZOB,NINT(ZQM),STAID,
     $             IRTYP,SUBSET,MCHOIC
 9165 FORMAT(/' ***> SURPRP: BAD PSFC=',F6.1,', Q.M.=',I2,' AND/OR BAD',
     $ ' ELEV=',F8.1,', Q.M.=',I2,' AT STN. ',A8,', R.TYPE =',I4,', ',
     $ 'SUBSET = "',A8,'"'/15X,'MCHOIC =',I2,' - GO ON TO NEXT REPORT'/)
                  GO TO 1
               ENDIF
               PSFC_8=POB
               GO TO 1500
           ELSE IF(NINT(POB*10.).EQ.10000.AND.IBFMS(OBS_8(2,MSEL)).EQ.0)
     $       THEN
               MCHOIC = 3
               IF(MAX(NINT(PQM),NINT(ZQM)).GT.7)  THEN
                  WRITE(6,9165)  POB,ABS(NINT(PQM)),ZOB,NINT(ZQM),STAID,
     $             IRTYP,SUBSET,MCHOIC
                  GO TO 1
               END IF
               TSFC=TKEL+SST
               PSFC_8=POB+GRAV*POB/(RGAS*TSFC)*ZOB
               IF(NINT(PSFC_8*10.).GT.10200)  THEN
                  WRITE(6,9167) PSFC_8,STAID,IRTYP,SUBSET,MCHOIC,TSFC,
     $             ZOB,POB
 9167 FORMAT(/' ***> SURPRP: UNREAL PSFC=',E16.8,' AT STN. ',A8,
     $ ', R.TYPE =',I4,', SUBSET = "',A8,'", MCHOIC =',I2,', TSFC =',
     $ F8.3/15X,'Z1000 =',F8.1,', P1000 =',F7.1,' - GO ON TO NEXT ',
     $ 'REPORT'/)
                  GO TO 1
               ENDIF
               GO TO 1500
            ENDIF

         ELSE  IF(KK.EQ.2)  THEN
cdak  fix 9/5/14 vvvvvvvvvv
            if(ibfms(OBS_8(3,MSEL)).gt.0.or.
     $         ibfms(OBS_8(4,MSEL)).gt.0)  then

c  If either UOB or VOB (or both) are missing, skip the processing of
c  this wind level (UOB and/or VOB can now be missing for surface wind
c  reports since a recent implementation allows reports with only wind
c  speed or only wind direction to store these in SOB and DDO, resp.)
c  -------------------------------------------------------------------

               WRITE(6,9195)  POB,STAID,IRTYP,SUBSET,UOB,VOB
 9195 FORMAT(/' ***> SURPRP: ONE OR BOTH UOB/VOB MISSING: PSFC=',F6.1,
     $       ' AT STN. ',A8,', R.TYPE =',I4,', SUBSET = "',A8,'",'/
     $ 15X,'UOB = ',G0,', VOB = ',G0,' - SKIP AND GO ON TO NEXT ',
     $ 'LEVEL OF THIS REPORT'/)
               go to 30
           endif
cdak  fix 9/5/14 ^^^^^^^^^^

C  WIND REPORTS: USE DATA ON ALL LEVELS BELOW PTOP
C  -----------------------------------------------

            IF(NINT(POB*10.).LT.NINT(PTOP*10.))  GO TO 1
            IF(NINT(WQM).GT.7)  THEN
               WRITE(6,9166)  POB,NINT(WQM),STAID,IRTYP,SUBSET
 9166 FORMAT(/' ***> SURPRP: BAD WIND ON LEVEL POB=',F6.1,', WIND ',
     $ 'Q.M.=',I2,' AT STN. ',A8,', R.TYPE =',I4,', SUBSET = "',A8,'"'/
     $ 15X,'- SKIP AND GO ON TO NEXT LEVEL OF THIS REPORT'/)
               GO TO 30
            ENDIF
            IF(IWFLG.EQ.1)  THEN
               IF(IHRD.EQ.0)  THEN

C  ON FIRST VALID WIND LEVEL ONLY, IF IHRD=0 CONVERT TO STORM-RELATIVE
C   SYSTEM AND CALCULATE DATA-STORM DISTANCE AND ANGLE
C  -------------------------------------------------------------------

                  CALL STMADJ(RLONZ,RLATZ,DAYZ)
                  CALL STMCOR(RLATZ,RLONZ,IHOWFR,ANGLE)
               END IF

C  ON FIRST VALID WIND LEVEL ONLY, PRINT WIND REPORT (MAYBE?)
C  ----------------------------------------------------------

c && comment out 2 lines
               iprtl = iprt
               iprt=2
               IF(IPRT.GT.1 .AND. MOD(KOUNT,1).EQ.0)  THEN
                 PRINT20,ICNT,KREC,RLAT,RLON,STAID,NLEV,DHR,IRTYP,SUBSET
   20 FORMAT(1X,'WIND: ICNT=',I4,', KREC=',I5,', LAT=',F7.2,', LON=',
     $ F7.2,', STNID=',A8,', LVLS=',I3,', D-TIME=',F6.2,', RTYP=',I3,
     $ ', SUBSET="',A8,'"')
               ENDIF
c && comment out next line
               iprt=iprtl
               IWFLG = 0
            END IF
c && 3 comments
CC          WRITE(6,29) MSEL,POB,UOB,VOB,RLAT,RLON
CC 29 FORMAT('...SELECTING WINDS, MSEL,PRESR,UWIND,VWIND,RLAT,RLON=',I5,
CC   $ 5(F10.2))
            DATA(INDCOM(1))=UOB
            DATA(INDCOM(2))=VOB
            IF(IHRD.EQ.0)  THEN
              CALL OWNCOM(IPRT,IHOWFR,ANGLE,RLAT,RLON,POB,IRTYP,NDATA,
     $                    DATA)
            ELSE  IF(IHRD.GT.0)  THEN
               CALL MAKHRD(IRTYP,IYRZ,DAYZ,RLAT,RLON,POB,UOB,VOB)
            END IF
         END IF
   30    CONTINUE

      ENDDO

      GO TO 1

 1500 CONTINUE

C  COME HERE IF MASS REPORT WITH SEA-LEVEL PRESSURE
C  ------------------------------------------------

      IF(IHRD.EQ.0)  THEN

C  IF IHRD=0 CONVERT TO STORM-RELATIVE SYSTEM AND CALCULATE DATA-STORM
C  DISTANCE AND ANGLE
C  -------------------------------------------------------------------

         CALL STMADJ(RLONZ,RLATZ,DAYZ)
         CALL STMCOR(RLATZ,RLONZ,IHOWFR,ANGLE)
      END IF

C  PRINT MASS REPORT (MAYBE?)
C  --------------------------

c && comment out 2 lines
      iprtl = iprt
      iprt=2
      IF(IPRT.GT.1 .AND. MOD(KOUNT,1).EQ.0)  THEN
         PRINT 21, ICNT,KREC,RLAT,RLON,STAID,NLEV,DHR,IRTYP,SUBSET
   21 FORMAT(1X,'MASS: ICNT=',I4,', KREC=',I5,', LAT=',F7.2,', LON=',
     $ F7.2,', STNID=',A8,', LVLS=',I3,', D-TIME=',F6.2,', RTYP=',I3,
     $ ', SUBSET="',A8,'"')
         IF(MCHOIC.EQ.1)  THEN
            PRINT 220, MCHOIC,PSFC_8
  220 FORMAT(1X,'....: MCHOIC=',I1,', PSFC=',F6.1)
         ELSE  IF(MCHOIC.EQ.2)  THEN
            PRINT 221, MCHOIC,PSFC_8,ZOB
  221 FORMAT(1X,'....: MCHOIC=',I1,', PSFC=',F6.1,', ELEV=',F7.1)
         ELSE  IF(MCHOIC.EQ.3)  THEN
            PRINT 222, MCHOIC,PSFC_8,ZOB,TSFC,POB
  222 FORMAT(1X,'....: MCHOIC=',I1,', PSFC=',F6.1,', Z1000=',F7.1,
     $ ', TSFC=',F7.3,', P1000=',F6.1)
         END IF
      END IF
c && comment out next line
      iprt=iprtl

      DATA(INDCOM(3))=PSFC_8

C ==> Important: If IHRD != 0, then I don't think IHOWFR and
C                ANGLE would be defined at this point

      CALL OPSCOM(IPRT,IHOWFR,ANGLE,RLAT,RLON,IRTYP,NDATA,DATA)

      GO TO 1

 110  CONTINUE

C  FINISHED READING THE FILE
C  -------------------------

      PRINT 1249, IUNTPN,LAST,ICNTTA
      PRINT 1259, IUNTPN,ICNTOT
 1259 FORMAT(//' ===> SURPRP: ALL MESSAGES IN INPUT PREPBUFR FILE IN ',
     $ 'UNIT',I3,' PROCESSED - NUMBER OF INDIVIDUAL REPORTS DECODED'/
     $ 15X,'OUT OF ALL MESSAGES =',I6//)
      CALL CLOSBF(IUNTPN)
      PRINT 799, IUNTPN
  799 FORMAT(/' ===> SURPRP: INPUT PREPBUFR FILE IN UNIT',I3,
     $ ' SUCCESSFULLY CLOSED'/)

C  ANALYZE RESULTS
C  ---------------

      IF(IHRD.EQ.0) CALL ANLCOM(RPOT,SPDPOT,NOBWMN,IUNTDH,ONLYWI,ONLYPS)

      RETURN

      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    COMBIN      COMBINES BOGUS AND ENVIRONMENTAL BOGUS
C   PRGMMR: D. A. KEYSER     ORG: NP22       DATE: 2001-09-27
C
C ABSTRACT: COMBINES BOGUS AND ENVIRONMENTAL DATA TO PRODUCE
C   THE FINAL BOGUS VALUES.  CONSIDERS WINDS AND HEIGHTS ONLY.
C   CAN GENERATE A NEW FORM OF MASS BOGUS REPORT AT THE STORM
C   LOCATION.
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD
C 2001-09-27  D. A. KEYSER - OPTION AVAILABLE TO GENERATE A NEW FORM
C       OF MASS BOGUS REPORT AT THE STORM LOCATION (TYPE 111),
C       CONTROLLED BY NAMELIST SWITCH "MAK111" (IF FALSE THEN REPORTS
C       WILL NOT BE GENERATED) (THESE REPORTS ARE LATER MODIFIED IN
C       SUBR. EDTPRP)
C
C USAGE:    CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... )
C   INPUT ARGUMENT LIST:
C     INARG1   - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C     INARG2   - TYPE.  EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     WRKARG   - GENERIC DESCRIPTION, ETC., AS ABOVE.
C     OUTARG1  - EXPLAIN COMPLETELY IF ERROR RETURN
C     ERRFLAG  - EVEN IF MANY LINES ARE NEEDED
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     DDNAME1  - GENERIC NAME & CONTENT
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     DDNAME2  - GENERIC NAME & CONTENT AS ABOVE
C     FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE COMBIN(IEFLTP,IUNTFE,MXUNTE,IUNTVO,ADVORT,IUNTBG,RLAT1,
     1                  RLAT2,RLON1,RLON2,F,MAXFI,MAXF2J,STMLTZ,STMLNZ,
     2                  STMDRZ,STMSPZ,IDATEZ,IUTCZ,PCENST,RMAXST,IFSTZ)
C
      PARAMETER (MAXI=360,MAXJ=181,MAX2J=2*MAXJ)
      PARAMETER (MAXBGI=35,MAXBGJ=35,MAXBGK=10)
      PARAMETER (KDTDIM=5,MAXBG=MAXBGI*MAXBGJ*MAXBGK*KDTDIM)
      PARAMETER (NSTM=1,MAXSTM=NSTM)
C
      CHARACTER MTITLE*102,STMNMZ*12
      LOGICAL OUTPUT,STORLV,FRSTLV,ADVORT,INCMOD,SETLON,ZEROIT
C
      COMMON/OVRHED/ITYP,PRES(MAXBGK)
      COMMON/T111SW/MAK111
C
      SAVE

      REAL(8)  SINDEG_8,DISTSP_8
C
      DIMENSION F(MAXFI,MAXF2J),RLONLS(MAXI),RLATLS(MAXJ),
     1          Z(MAXBGI,MAXBGJ,MAXBGK), T(MAXBGI,MAXBGJ,MAXBGK),
     2          RH(MAXBGI,MAXBGJ,MAXBGK),U(MAXBGI,MAXBGJ,MAXBGK),
     3          V(MAXBGI,MAXBGJ,MAXBGK)
      DIMENSION FENARA(MAXBGI,MAXBGJ,MAXBGK,KDTDIM),BOGDAT(MAXBG),
     1          VORARA(MAXBGI,MAXBGJ,MAXBGK,KDTDIM),VORDAT(MAXBG),
     2          DATOUT(KDTDIM+1,MAXBGK),IUAPRS(MAXBGK)
C
      CHARACTER STMNAM*9,STMID*3,RSMC*4
C
      LOGICAL FSTFLG,MAK111
C
      DIMENSION STMNAM(MAXSTM),STMLAT(MAXSTM),STMLON(MAXSTM),
     1          STMDIR(MAXSTM),STMSPD(MAXSTM),IDATE(MAXSTM),
     2          IUTC(MAXSTM),RMAX(MAXSTM),PENV(MAXSTM),PCEN(MAXSTM),
     3          PTOP(MAXSTM),RSMC(MAXSTM),RMW(MAXSTM),VMAX(MAXSTM),
     4          R15NW(MAXSTM),R15NE(MAXSTM),R15SE(MAXSTM),R15SW(MAXSTM),
     5          STMID(MAXSTM),FSTFLG(MAXSTM)
C
C
      EQUIVALENCE (FENARA(1,1,1,1),T(1,1,1)),
     1            (FENARA(1,1,1,2),RH(1,1,1)),
     2            (FENARA(1,1,1,3),Z(1,1,1)),
     3            (FENARA(1,1,1,4),U(1,1,1)),
     4            (FENARA(1,1,1,5),V(1,1,1)),
     5            (FENARA(1,1,1,1),BOGDAT(1)),
     6            (VORARA(1,1,1,1),VORDAT(1))
C
C
      DATA EPS/1.E-2/,EPSLL/0.2/,EPSFC/1.E-6/,IQZ/0/,IQV/0/,IRTYP/110/,
     1     IRTYPC/111/,IOVITL/1/,IPRNT/1/,IWRITE/6/,IPMAX/100/
C
C     DATA PARAMETERS FOR ESTIMATE OF 1000 MB HEIGHT AND STORM
C       CENTER BOGUS OBS
C
      DATA TKEL/273.16/,SST/28.0/,RGAS/287./,GRAV/9.81/,IOFFT/0/,
     1     P1000/1000./,IPSURF/1000/,RMISS/-9999.9/,IQT/0/,IQM/0/,
     2     OMEG/14.584E-5/
C
C     SUBROUTINE COMBIN TAKES THE ENVIRONMENTAL FIELD AND THE BOGUS
C       VORTEX POINTS AND ADDS THEM TOGETHER.
C
C     CURRENTLY, TWO TYPES OF ENVIRONMENTAL FIELDS ARE ACCEPTED:
C         1)  GLOBAL DOMAIN MAP LAUNCHER (LAT/LON)  (IEFLTP=1)
C         2)  LIMITED DOMAIN MAP LAUNCHER FORMAT (LAT/LON) (IEFLTP=2)
C
C     ADVORT=.FALSE. MEANS THAT THE BOGUS VORTEX IS NOT ADDED
C        TO THE FILTERED LARGE-SCALE ENVIRONMENTAL FIELD
C
      UCALM=0.0
      VCALM=0.0
      RHCNTR=99.0
      INCMOD=.FALSE.
      SETLON=.FALSE.
C
C     **** IMPORTANT NOTE:    *****
C     TEMPORARILY, WE NEED DELXBG, DELYBG AND STORM NAME FROM BOGUS
C     DATA FILE. DOMAIN PARAMETERS, DATE, TIME ARE INPUT FROM ARGUMENT
C       LIST IN SUBROUTINE MODE
C
      READ(IUNTVO,*) ZLONMN,ZLONMX,ZLATMN,ZLATMX,DELXBG,DELYBG,STMNMZ
      STMNAM(1)=STMNMZ(1:9)
      READ(IUNTVO,*) IZZ,IDATEJ,IUTC(1)
      IDATE(1)=IDATEJ
      BACKSPACE IUNTVO
C
      IF(IEFLTP .EQ. 1)  THEN
      RLONMN=ZLONMN
      RLONMX=ZLONMX
      RLATMN=ZLATMN
      RLATMX=ZLATMX
      XXDOM=360.
      YYDOM=180.
      XXANCH=0.0
      YYANCH=90.
C
      ELSE IF(IEFLTP .EQ. 2)  THEN
C
      RLONMN=RLON1
      RLONMX=RLON2
      RLATMN=RLAT1
      RLATMX=RLAT2
      XXDOM=ABS(RLONMX-RLONMN)
      YYDOM=    RLATMX-RLATMN
      XXANCH=RLONMN
      YYANCH=RLATMX
      ELSE
      WRITE(6,1)  IEFLTP
    1 FORMAT(/'******ENVIRONMENTAL FILE TYPE NOT ALLOWED, IEFLTP=',I5)
      CALL ABRT1(' COMBIN',1)
      ENDIF
C
      IF(RLONMN .LT. 0.0) RLONMN=360.+RLONMN
      IF(RLONMX .LT. 0.0) RLONMX=360.+RLONMX
C
      WRITE(IWRITE,199)
  199 FORMAT(//)
      WRITE(6,2) IEFLTP,IUNTVO,IUNTBG,RLATMN,RLATMX,RLONMN,RLONMX,RMAXST
    2 FORMAT(/'...ENTERING COMBIN WITH IEFLTP,IUNTVO,IUNTBG,RLATMN,',
     1       'RLATMX,RLONMN,RLONMX,RMAXST=',/,4X,3I5,5F10.2)
C
      WRITE(6,3)
      WRITE(6,3)
      WRITE(6,4)
      WRITE(6,5) STMNMZ,IDATE(1),IUTC(1),ADVORT
      WRITE(6,4)
      WRITE(6,3)
      WRITE(6,3)
    3 FORMAT(20X,'**********************************************')
    4 FORMAT(20X,'****                                      ****')
    5 FORMAT(20X,'****',8X,'STORM:',A13,11X,'****',/
     1       20X,'****',4X,'DATE:',I9,' TIME:',I5,9X,'****',/
     2       20X,'****',5X,'ADVORT:',L2,24X,'****')
C
C     INITIAL LOOK AT ENVIRONMENTAL FILE TO SET ARRAY SIZE
C        THEN CALCULATE LATITUDE AND LONGITUDES FOR THE GRIDDED POINTS.
C        WE ASSUME THAT GRIDDED POINTS ARE EQUALLY
C        SPACED IN LAT/LON.
C
      IUNTMX=IUNTFE-1+MXUNTE
      READ(IUNTFE)  ! this is the first "dummy" record
      READ(IUNTFE)  IMAX,JMAX,((F(I,J),I=1,IMAX),J=1,JMAX),MTITLE,NCHAR
      if(nchar.le.0) then
         print *
         print *
         print *, '$$$$$$ nchar = 0!!!! - this should not happen'
         print *
         print *
      else
        WRITE(6,7)   IUNTFE,IUNTMX,IMAX,JMAX,MTITLE(1:NCHAR)
    7    FORMAT(/'...INITIAL FILE READ, UNITS (',I2,', ',I2,') ',
     1          'WILL BE READ, IMAX,JMAX,MTITLE=',2I5,/,4X,A,//)
      end if
C
C     ALLOW FOR THE POSSIBILITY THAT THE FIRST FIELD IS A SCALAR,
C        AND THAT THERE ARE VECTOR FIELDS
C
      IF(MTITLE(1:1) .NE. '$')  JMAX= JMAX*2
      BACKSPACE IUNTFE
C
      IF(IMAX .GT. MAXI .OR. JMAX .GT. MAX2J)  THEN
      WRITE(6,9) IMAX,JMAX,MAXI,MAXJ
    9 FORMAT('****** IMAX,JMAX=',2I5,' EXCEED MAXI,MAX2J=',2I5)
      CALL ABRT1(' COMBIN',9)
      ENDIF
C
      MDIM=IMAX
      NDIM=JMAX
      NDIM2=NDIM/2
      DELYLS=YYDOM/REAL(NDIM2-1)
      IF(IEFLTP .EQ. 1)  DELXLS=XXDOM/REAL(MDIM)
      IF(IEFLTP .EQ. 2)  DELXLS=XXDOM/REAL(MDIM-1)
C
      DO 10 N=1,NDIM2
      RLATLS(N)=YYANCH-(N-1)*DELYLS
   10 CONTINUE
C
      DO 20 M=1,MDIM
      RLONLS(M)=XXANCH+(M-1)*DELXLS
   20 CONTINUE
      WRITE(6,21) (RLATLS(N),N=1,NDIM2)
   21 FORMAT('...LATITUDES ARE',/,(5X,10F11.2))
      WRITE(6,22) (RLONLS(M),M=1,MDIM)
   22 FORMAT('...LONGITUDES ARE',/,(5X,10F11.2))
C
C     INITIALIZE STORAGE ARRAYS TO MISSING VALUES
C
      BOGDAT=RMISS
      VORDAT=RMISS
C
      WRITE(6,31) RLONMN,RLONMX,RLATMN,RLATMX,DELXBG,DELXLS,DELYBG,
     1            DELYLS,STMNMZ
   31 FORMAT('...INSERTION AREA DEFINED BY:',/,10X,'RLONMN=',F10.3,
     1       /,10X,'RLONMX=',F10.3,/,10X,'RLATMN=',F10.3,/,10X,
     2       'RLATMX=',F10.3,/,10X,'DELX (BG,LS)=',2F8.4,/,10X,
     3       'DELY (BG,LS)=',2F8.4,/,10X,'STORM NAME=',A12)
C
      IMODX=1
      IMODY=1
      IF(ABS(DELXBG-DELXLS) .GT. EPS .OR. ABS(DELYBG-DELYLS) .GT. EPS)
     1   THEN
      IMODX=IFIX(DELXBG/DELXLS+EPS)
      IMODY=IFIX(DELYBG/DELYLS+EPS)
      WRITE(6,32) DELXBG,DELXLS,DELYBG,DELYLS,IMODX,IMODY
   32 FORMAT('...DELTAS DO NOT MATCH, MOD FUNCTION WILL BE INVOKED',/,
     1       10X,'DELXBG,DELXLS,DELYBG,DELYLS=',4F10.4,'  IMODX,IMODY=',
     2       2I5)
      IF(IMODX .EQ. 0 .OR. IMODY .EQ. 0)  THEN
      WRITE(6,33) DELXBG,DELXLS,DELYBG,DELYLS
   33 FORMAT(' IMODX OR IMODY ARE ZERO: DELXBG, DELXLS, DELYBG, DELYLS='
     1       ,4F10.4)
      ENDIF
      ENDIF
C
C     REMEMBER THAT NORTH POLE CORRESPONDS TO THE SMALLEST N INDEX
C
      DO 40 N=1,NDIM2
      NMX=N
      IF(NINT(ABS(RLATLS(N)-RLATMN)*100.) .LT. NINT(EPS*100.))  GO TO 45
   40 CONTINUE
      WRITE(6,41) RLATMN
   41 FORMAT('**** RLATLS DOES NOT AGREE WITH ANY RLATMN=',F10.4)
      CALL ABRT1(' COMBIN',41)
   45 DO 50 N=1,NDIM2
      NMN=N
      IF(NINT(ABS(RLATLS(N)-RLATMX)*100.) .LT. NINT(EPS*100.))  GO TO 55
   50 CONTINUE
      WRITE(6,51) RLATMX
   51 FORMAT('**** RLATLS DOES NOT AGREE WITH ANY RLATMX=',F10.4)
      CALL ABRT1(' COMBIN',51)
   55 DO 60 M=1,MDIM
      MMN=M
      IF(NINT(ABS(RLONLS(M)-RLONMN)*100.) .LT. NINT(EPS*100.))  GO TO 65
   60 CONTINUE
      WRITE(6,61) RLONMN
   61 FORMAT('**** RLONLS DOES NOT AGREE WITH ANY RLONMN=',F10.4)
      CALL ABRT1(' COMBIN',61)
   65 DO 70 M=1,MDIM
      MMX=M
      IF(NINT(ABS(RLONLS(M)-RLONMX)*100.) .LT. NINT(EPS*100.))  GO TO 75
   70 CONTINUE
      WRITE(6,71) RLONMX
   71 FORMAT('**** RLONLS DOES NOT AGREE WITH ANY RLONMX=',F10.4)
      CALL ABRT1(' COMBIN',71)
C
   75 CONTINUE
C
C     DO SOME CHECKS ON STORAGE SPACE FOR THE FENARA AND VORARA
C
   76 MXXPTS=NINT(REAL(MMX-MMN+1)/IMODX)
      IF(MXXPTS .GT. MAXBGI)  THEN
      INCMOD=.TRUE.
      WRITE(6,77)  MMX,MMN,MXXPTS,IMODX
   77 FORMAT(/'...INCREMENTATION OF MOD FUNCTION IN X DIRECTION',
     1       ' FOR SELECTION OF LARGE-SCALE AND BOGUS POINTS',/,
     2       '    HAS BEEN NECESSARY BECAUSE MAXBGI IS TOO SMALL',/,
     3       5X,'MXX,MMN,MXXPTS,IMODX=',4I5)
      IMODX=IMODX+1
      GO TO 76
      ENDIF
C
   78 NXXPTS=NINT(REAL(NMX-NMN+1)/IMODY)
      IF(NXXPTS .GT. MAXBGJ)  THEN
      INCMOD=.TRUE.
      WRITE(6,79)  NMX,NMN,NXXPTS,IMODY
   79 FORMAT(/'...INCREMENTATION OF MOD FUNCTION IN Y DIRECTION',
     1       ' FOR SELECTION OF LARGE-SCALE AND BOGUS POINTS',/,
     2       '    HAS BEEN NECESSARY BECAUSE MAXBGJ IS TOO SMALL',/,
     3       5X,'NXX,NMN,NXXPTS,IMODY=',4I5)
      IMODY=IMODY+1
      GO TO 78
      ENDIF
C
C     LOAD VARIABLES FROM LARGE-SCALE MODEL ARRAY
C
      WRITE(6,799) NMN,NMX,IMODY,MMN,MMX,IMODX
  799 FORMAT(/'...PREPARING TO LOAD VARIABLES FROM ENVIRONMENTAL ARRAY',
     1       ', NMN,NMX,IMODY,MMN,MMX,IMODX=',6I5)
      DO 100 NARA=1,999
      CALL READAG(IUNTFE,MDIM,NDIM,F,KL,IV,IEND)
      IF(IEND .EQ. 1)  GO TO 101
C
C     STORE ENVIRONMENTAL FIELDS INTO BOGUS ARRAY.  ALSO ASSIGN
C        LATITUDE AND LONGITUDE FOR THESE POINTS INTO
C        RLATLS, RLONLS ARRAYS
C
      IF(.NOT. SETLON)  THEN
        SETLON=.TRUE.
        MXX=0
        DO 80 M=MMN,MMX,IMODX
        MXX=MXX+1
        RLONLS(MXX)=RLONLS(M)
   80   CONTINUE
      ENDIF
C
      NXX=0
      DO N=NMN,NMX,IMODY
         NXX=NXX+1
         RLATLS(NXX)=RLATLS(N)
C
         MXX=0
         DO M=MMN,MMX,IMODX
            MXX=MXX+1
            FENARA(MXX,NXX,KL,IV)=F(M,N)
         END DO
      END DO
      WRITE(6,851)  KL,IV,MXX,NXX
  851 FORMAT(//'    ....LARGE SCALE ARRAY: KL,IV,MXX,NXX=',4I5)
      WRITE(6,852) (M,M=1,MXX)
      WRITE(6,853) (RLONLS(M),M=1,MXX)
  852 FORMAT(8X,10I11)
  853 FORMAT(12X,10F11.2)
      DO 856 N=1,NXX
      WRITE(6,854) N,RLATLS(N)
  854 FORMAT(I4,F8.2)
      WRITE(6,857) (FENARA(M,N,KL,IV),M=1,MXX)
  857 FORMAT(12X,10F11.2)
  856 CONTINUE
C
C     DOUBLE CHECK CALCULATION OF MXXPTS
C
      IF(MXXPTS .NE. MXX) THEN
      WRITE(6,858) MXXPTS,MXX
  858 FORMAT(/'***** A SEVERE ERROR HAS OCCURRED, MXXPTS=',I5,
     1       ' NOT EQUAL TO MXX=',I5)
      CALL ABRT1(' COMBIN',858)
      ENDIF
C
C     STORE V
C
      IF(IV .EQ. 4)  THEN
      IV=5
      NXX=0
      DO N=NMN,NMX,IMODY
         MXX=0
         NXX=NXX+1
         DO M=MMN,MMX,IMODX
            MXX=MXX+1
            FENARA(MXX,NXX,KL,IV)=F(M,N+NDIM2)
         END DO
      END DO
      WRITE(6,911)  KL,IV,MXX,NXX
  911 FORMAT(//'    ....LARGE SCALE ARRAY: KL,IV,MXX,NXX=',4I5)
      WRITE(6,912) (M,M=1,MXX)
      WRITE(6,913) (RLONLS(M),M=1,MXX)
  912 FORMAT(8X,10I11)
  913 FORMAT(12X,10F11.2)
      DO 916 N=1,NXX
      WRITE(6,914) N,RLATLS(N)
  914 FORMAT(I4,F8.2)
      WRITE(6,915) (FENARA(M,N,KL,IV),M=1,MXX)
  915 FORMAT(12X,10F11.2)
  916 CONTINUE
      ENDIF
  100 CONTINUE
C
  101 CONTINUE
      IF(IUNTFE .LT. IUNTMX) THEN
      WRITE(6,103) IUNTFE
  103 FORMAT(/'...NOW READING UNIT',I2)
      READ(IUNTFE)
      GO TO 75
      ENDIF
C
C     ***************************************
C     *****  BEGIN DIAGNOSTICS SECTION  *****
C     ***************************************
C
      WRITE(6,105)
  105 FORMAT(//10X,'*******  DIAGNOSTICS OF ENVIRONMENTAL FIELDS',
     1       ' OVER BOGUS DOMAIN   *******')
C
C     CHECK GEOSTROPHY OF FILTERED ENVIRONMENTAL WIND FIELD
C
      DO 130 KL=1,MAXBGK
      PHI1=0.0
      PHI2=0.0
      PHI3=0.0
      PHI4=0.0
      IF(ABS(U(1,1,KL)-RMISS) .LT. EPS .OR.
     1   ABS(Z(1,1,KL)-RMISS) .LT. EPS)  GO TO 130
C
      DO 110 N=1,NXX
      PHI1=PHI1+Z(1  ,N,KL)
      PHI2=PHI2+Z(MXX,N,KL)
  110 CONTINUE
C
      DO 120 M=1,MXX
      PHI3=PHI3+Z(M,1  ,KL)
      PHI4=PHI4+Z(M,NXX,KL)
  120 CONTINUE
C
      PHI1=PHI1/REAL(NXX)
      PHI2=PHI2/REAL(NXX)
      PHI3=PHI3/REAL(MXX)
      PHI4=PHI4/REAL(MXX)
      WRITE(6,121) PRES(KL),PHI1,PHI2,PHI3,PHI4
  121 FORMAT(/20X,'CHECKING GEOSTROPHY OF ENVIRONMENTAL FIELDS'//
     1       '...PRES,PHI1,PHI2,PHI3,PHI4=',5F10.2)
C
      UAVG=0.0
      VAVG=0.0
      DO N=1,NXX
         DO M=1,MXX
            UAVG=UAVG+U(M,N,KL)
            VAVG=VAVG+V(M,N,KL)
         END DO
      END DO
      UAVG=UAVG/REAL(MXX*NXX)
      VAVG=VAVG/REAL(MXX*NXX)
      WRITE(6,126) UAVG,VAVG
  126 FORMAT('...AVERAGED U,V=',2F10.2)
C
      DX=DISTSP_8(RLATLS(1),RLONLS(1),RLATLS(1),RLONLS(MXX))
      DY=DISTSP_8(RLATLS(1),RLONLS(1),RLATLS(NXX),RLONLS(1))
      WRITE(6,127) DX,DY
  127 FORMAT('...DX,DY=',2F12.2)
C
      FCOR=OMEG*SINDEG_8(0.5*(RLATLS(1)+RLATLS(NXX)))
      IF(ABS(FCOR) .LT. EPSFC)  FCOR=SIGN(EPSFC,FCOR)
      VGEOS=GRAV*(PHI2-PHI1)/(FCOR*DX)
      UGEOS=GRAV*(PHI4-PHI3)/(FCOR*DY)
      WRITE(6,128) UGEOS,VGEOS
  128 FORMAT('...GEOSTROPHIC U,V=',2F10.2,/)
C
  130 CONTINUE
C
C     CALCULATE SOME COMPARISONS BETWEEN THE FILTERED ENVIRONMENTAL
C       WINDS AND THE 12 HOUR PAST STORM MOTION.
C     WE ONLY NEED TO ACCESS THE VITAL STATISTICS FILE FOR THE
C       STAND-ALONE MODE (ASSUMED TO BE THE GLOBAL LAT/LON FILE TYPE)
C
      IF(IEFLTP .EQ. 1)  THEN
      IOPT=2
      IDTREQ=IDATEZ
      IHRREQ=IUTCZ
      IHRWIN=0
C
      CALL NEWVIT(IOVITL,IPRNT,IOPT,IERVIT,NSTM,KSTORM,IDTREQ,IHRREQ,
     1            IHRWIN,IDATE,IUTC,STMLAT,STMLON,STMDIR,STMSPD,PCEN,
     2            PENV,RMAX,VMAX,RMW,R15NE,R15SE,R15SW,R15NW,PTOP,
     3            FSTFLG,STMNAM,STMID,RSMC)
C
      ELSE
      STMLAT(1)=STMLTZ
      STMLON(1)=STMLNZ
      STMDIR(1)=STMDRZ
      STMSPD(1)=STMSPZ
      IDATE(1) =IDATEZ
      IUTC(1)  =IUTCZ
      PCEN (1) =PCENST
      ENDIF
C
C     LONGITUDES HAVE BEEN CONVERTED TO 0-360 DEG LONGITUDE FORMAT IN
C       NEWVIT.
C
      DO 140 N=NMN,NMX
      NCEN=N
      IF(NINT(RLATLS(N)*100.) .LT. NINT(STMLAT(1)*100.))  GO TO 145
  140 CONTINUE
  145 CONTINUE
      DO 150 M=MMN,MMX
      MCEN=M
      IF(NINT(RLONLS(M)*100.) .GT. NINT(STMLON(1)*100.))  GO TO 155
  150 CONTINUE
C
  155 CONTINUE
C
C     STORM SPEED HAS BEEN CONVERTED TO M/SEC IN NEWVIT.
C
      WRITE(6,156) NCEN,MCEN,RLONLS(MCEN-1),RLONLS(MCEN),RLATLS(NCEN-1),
     1             RLATLS(NCEN),STMLON(1),STMLAT(1)
  156 FORMAT(//' ...NCEN,MCEN=',2I5,'. CLOSEST FOUR POINTS TO STORM ',
     1       'ARE:',2F10.2,' LONGITUDE, AND',2F10.2,' LATITUDE.'/23X,
     2       'STORM LON/LAT=',2F10.2//10X,'PRES',7X,'  ZONAL WIND',9X,
     3       'MERID WIND',11X,'SPEED',12X,'DIRECTION',10X,'DIFFERENCE ',
     4       'VECTOR (ENV-PERSIS)'/23X,4('ENV    STM',9X),'U',7X,'V',7X,
     5       'DIR',4X,'SPEED')
C
      ULMAVG=0.0
      VLMAVG=0.0
      CALL DS2UV(USTM,VSTM,STMDIR(1),STMSPD(1))
C
C     WEIGHTING OF 4 NEAREST NEIGHBORS IS INVERSELY PROPORTIONAL
C        TO SEPARATION FROM STORM POSITION
C
      W1=DISTSP_8(RLATLS(NCEN  ),RLONLS(MCEN  ),STMLAT(1),STMLON(1))
      W2=DISTSP_8(RLATLS(NCEN  ),RLONLS(MCEN-1),STMLAT(1),STMLON(1))
      W3=DISTSP_8(RLATLS(NCEN-1),RLONLS(MCEN  ),STMLAT(1),STMLON(1))
      W4=DISTSP_8(RLATLS(NCEN-1),RLONLS(MCEN-1),STMLAT(1),STMLON(1))
C
      IF(W1 .LT. 1.)  THEN
      W1=1.0
      W2=0.0
      W3=0.0
      W4=0.0
      ELSE IF(W2 .LT. 1.)  THEN
      W1=0.0
      W2=1.0
      W3=0.0
      W4=0.0
      ELSE IF(W3 .LT. 1.)  THEN
      W1=0.0
      W2=0.0
      W3=1.0
      W4=0.0
      ELSE IF(W4 .LT. 1.)  THEN
      W1=0.0
      W2=0.0
      W3=0.0
      W4=1.0
      ELSE
      W1=1./W1
      W2=1./W2
      W3=1./W3
      W4=1./W4
      ENDIF
      WT=W1+W2+W3+W4
C
      NLM=0
      DO 170 KL=1,MAXBGK
      UAVG=(W1*FENARA(MCEN,NCEN  ,KL,4)+W2*FENARA(MCEN-1,NCEN  ,KL,4)+
     1      W3*FENARA(MCEN,NCEN-1,KL,4)+W4*FENARA(MCEN-1,NCEN-1,KL,4))
     2      /WT
      VAVG=(W1*FENARA(MCEN,NCEN  ,KL,5)+W2*FENARA(MCEN-1,NCEN  ,KL,5)+
     1      W3*FENARA(MCEN,NCEN-1,KL,5)+W4*FENARA(MCEN-1,NCEN-1,KL,5))
     2      /WT
      IF(ABS(UAVG-RMISS) .GT. EPS)  THEN
      NLM=NLM+1
      ULMAVG=ULMAVG+UAVG
      VLMAVG=VLMAVG+VAVG
      CALL UV2DS(UAVG,VAVG,ENVDIR,ENVSPD)
      UDIF=UAVG-USTM
      VDIF=VAVG-VSTM
      CALL UV2DS(UDIF,VDIF,DIRDIF,SPDDIF)
      WRITE(6,161) PRES(KL),UAVG,USTM,VAVG,VSTM,ENVSPD,STMSPD(1),
     1             ENVDIR,STMDIR(1),UDIF,VDIF,DIRDIF,SPDDIF
  161 FORMAT(7X,F7.1,6(3X,2F8.2))
      ENDIF
  170 CONTINUE
      ULMAVG=ULMAVG/REAL(NLM)
      VLMAVG=VLMAVG/REAL(NLM)
      CALL UV2DS(ULMAVG,VLMAVG,ENVDIR,ENVSPD)
      UDIF=ULMAVG-USTM
      VDIF=VLMAVG-VSTM
      CALL UV2DS(UDIF,VDIF,DIRDIF,SPDDIF)
      WRITE(6,171) ULMAVG,USTM,VLMAVG,VSTM,ENVSPD,STMSPD(1),ENVDIR,
     1             STMDIR(1),UDIF,VDIF,DIRDIF,SPDDIF
  171 FORMAT(6X,'LYR MEAN',6(3X,2F8.2))
C
C     **********************************
C     ****  READ BOGUS VORTEX DATA  ****
C     **********************************
C
      MBGMN= 9999
      MBGMX=-9999
      NBGMN= 9999
      NBGMX=-9999
      DO 200 IREAD=1,9999
      CALL READBG(IUNTVO,RLATBG,RLONBG,KL,ZZ,UU,VV,IEND)
      IF(IEND .EQ. 1)  GO TO 210
C
C     TRANSFORM LONGITUDE TO 0-360 DEG
C
      RLONBG=MOD(360.-RLONBG,360.)
      IPNFND=0
C
C     FIND MATCHING LOCATION IN LARGE SCALE ARRAY
C
      DO 180 N=1,NXX
      NBG=N
      IF(NINT(ABS(RLATBG-RLATLS(N))*100.) .LT. NINT(EPS*100.)) GO TO 185
  180 CONTINUE
      IF(IPNFND .LT. IPMAX) THEN
        IPNFND=IPNFND+1
        WRITE(6,181) RLATBG,INCMOD
  181   FORMAT('****** BOGUS POINT AT RLATBG=',F10.2,' COULD NOT BE',
     1         ' FOUND, INCREMENT MOD FUNCTION IS:',L2)
        IF(.NOT. INCMOD)  CALL ABRT1(' COMBIN',181)
      ENDIF
C
  185 DO 190 M=1,MXX
      MBG=M
      IF(NINT(ABS(RLONBG-RLONLS(M))*100.) .LT. NINT(EPS*100.)) GO TO 195
  190 CONTINUE
      IF(IPNFND .LT. IPMAX) THEN
        IPNFND=IPNFND+1
        WRITE(6,191) RLONBG,INCMOD
  191   FORMAT('****** BOGUS POINT AT RLONBG=',F10.2,' COULD NOT BE',
     1         ' FOUND, INCREMENT MOD FUNCTION IS:',L2)
        IF(.NOT. INCMOD)  CALL ABRT1(' COMBIN',191)
      ENDIF
C
  195 CONTINUE
      VORARA(MBG,NBG,KL,3)=ZZ
      VORARA(MBG,NBG,KL,4)=UU
      VORARA(MBG,NBG,KL,5)=VV
      MBGMN=MIN(MBGMN,MBG)
      MBGMX=MAX(MBGMX,MBG)
      NBGMN=MIN(NBGMN,NBG)
      NBGMX=MAX(NBGMX,NBG)
C
      IF(IEND .EQ. 1) GO TO 210
  200 CONTINUE
C
  210 CONTINUE
C
C     AVERAGE HEIGHTS AROUND BORDER.  WE WANT TO ADD THE ONLY THE
C        HEIGHT DEVIATION TO THE LARGE SCALE FIELD
C
      DO 250 KL=1,MAXBGK
      IF(VORARA(MBGMN,NBGMN,KL,3) .EQ. RMISS) GO TO 250
      AVG=0.0
      NAVG=0
C
      DO 220 N=NBGMN,NBGMX
      NAVG=NAVG+2
      AVG=AVG+VORARA(MBGMN,N,KL,3)+VORARA(MBGMX,N,KL,3)
  220 CONTINUE
C
      DO 230 M=MBGMN+1,MBGMX-1
      NAVG=NAVG+2
      AVG=AVG+VORARA(M,NBGMN,KL,3)+VORARA(M,NBGMX,KL,3)
  230 CONTINUE
C
      AVG=AVG/REAL(NAVG)
      WRITE(6,231) KL,AVG,NAVG
  231 FORMAT(/'...AVERAGE HEIGHT FIELD FOR KL, AVG,NAVG=',I4,F12.3,I6)
C
      DO N=NBGMN,NBGMX
         DO M=MBGMN,MBGMX
            VORARA(M,N,KL,3)=VORARA(M,N,KL,3)-AVG
         END DO
      END DO
C
  250 CONTINUE
C
C     COMBINE LARGE SCALE FIELD AND BOGUS FOR ALL POINTS
C
      WRITE(6,251)  IUNTBG,IRTYP,IRTYPC,IDATE(1),IUTC(1),ADVORT
  251 FORMAT(//'...READY TO CREATE DATA FOR PREPBUFR ON UNIT=',I3,
     1       '. IRTYP,IRTYPC,IDATE,IUTC=',2I5,2X,I10,3X,I5,
     2       ' ADD VORTEX=',L2///)
C
C     KEEP TRACK OF MAXIMUM NUMBER OF LEVELS IN ALL SOUNDINGS
C
      IDATE0=IDATE(1)*100+IUTC(1)/100
      MAXLEV=-99
C
C     WRITE DOMAIN PARAMETERS
C
      WRITE(IUNTBG,253) RLATLS(NBGMX),RLATLS(NBGMN),RLONLS(MBGMX),
     1                  RLONLS(MBGMN)
      WRITE(6,253) RLATLS(NBGMX),RLATLS(NBGMN),RLONLS(MBGMX),
     1             RLONLS(MBGMN)
  253 FORMAT(2X,4F10.2)
C
C     REDEFINE MAXIMUM AND MINIMUM LAT/LON FOR THE EDTPRP STEP
C
      RLAT1= 1.E10
      RLAT2=-1.E10
      RLON1= 1.E10
      RLON2=-1.E10
C
      DO N=1,NXX
      DO M=1,MXX
C
C     WE DON'T WANT TO WRITE A BOGUS POINT VERY NEAR THE STORM CENTER
C
      IF(NINT(ABS(RLATLS(N)-STMLAT(1))*100.) .LE. NINT(EPSLL*100.) .AND.
     1   NINT(ABS(RLONLS(M)-STMLON(1))*100.) .LE. NINT(EPSLL*100.))
     2   GO TO 300
C
C     WE MUST GUARANTEE THAT THE VORTEX IS IDENTICALLY ZERO OUTSIDE
C       RMAX.  IT CAN BE NON-ZERO DUE TO THE SPLINE FILTERING
C
      ZEROIT=DISTSP_8(RLATLS(N),RLONLS(M),STMLAT(1),STMLON(1)) .GE.
     1       RMAXST*1.E3
C
C     IF THIS STORM HAS BEEN BOGUSED BEFORE OR THERE IS A PRIOR
C       CIRCULATION IN THE GUESS FIELD (IFSTZ>=2), DO NOT WRITE
C       ANY DATA OUTSIDE RMAX.  THIS HELPS TO PREVENT VORTICITY
C       SWIRLS AT THE EDGES OF THE BOGUS DATA.
C
      IF(ZEROIT .AND. IFSTZ .GE. 2)  GO TO 300
C
      RLAT1=MIN(RLAT1,RLATLS(N))
      RLAT2=MAX(RLAT2,RLATLS(N))
      RLON1=MIN(RLON1,RLONLS(M))
      RLON2=MAX(RLON2,RLONLS(M))
C
      FRSTLV=.TRUE.
      OUTPUT=.FALSE.
      NLEV=0
C
      DO 280 KL=1,MAXBGK
C
      STORLV=.FALSE.
      DO 260 KD=1,KDTDIM
      IF(ABS(FENARA(M,N,KL,KD)-RMISS) .GT. EPS .AND.
     1   ABS(VORARA(M,N,KL,KD)-RMISS) .GT. EPS) STORLV=.TRUE.
      IF(ZEROIT)  VORARA(M,N,KL,KD)=0.0
  260 CONTINUE
C
      IF(STORLV)  THEN
      NLEV=NLEV+1
        IF(MAXLEV .LT. NLEV)  THEN
        IUAPRS(NLEV)=NINT(PRES(KL))
        MAXLEV=NLEV
        ENDIF
      DATOUT(1,NLEV)=PRES(KL)
        IF(FRSTLV)  THEN
        RLAT=RLATLS(N)
        RLON=RLONLS(M)
        FRSTLV=.FALSE.
        OUTPUT=.TRUE.
c && 2 comments
CC      WRITE(6,261) RLAT,RLON,DATOUT(1,NLEV)
CC261   FORMAT('...STORING BOGUS AT RLAT, RLON, PRES=',3F10.2)
        ENDIF
C
C     NOTE: CONVENTION FOR MISSING DATA NOW SET TO -9999.9
C
C     THE OPTION TO NOT INCLUDE THE BOGUS VORTEX IS NOW ADDED
C        SET "ADVORT" TO .FALSE.
C
        IF(ADVORT) THEN
           DO KD=1,KDTDIM
              DATOUT(KD+1,NLEV)=RMISS
              IF(ABS(FENARA(M,N,KL,KD)-RMISS) .GT. EPS)
     1         DATOUT(KD+1,NLEV)=FENARA(M,N,KL,KD)+VORARA(M,N,KL,KD)
           END DO
C
C     QUICK FIX FOR SOME MOISTURE AT THE FOUR POINT SURROUNDING THE
C       STORM CENTER
C
C          IF(N .EQ. NCEN .OR. N .EQ. NCEN-1)  THEN
C             IF(M .EQ. MCEN .OR. M .EQ. MCEN-1)  THEN
C                DATOUT(3,NLEV)=RHCNTR
C             ENDIF
C          ENDIF
C
        ELSE
           DO KD=1,KDTDIM
              DATOUT(KD+1,NLEV)=RMISS
              IF(ABS(FENARA(M,N,KL,KD)-RMISS) .GT. EPS)
     1         DATOUT(KD+1,NLEV)=FENARA(M,N,KL,KD)
           END DO
        ENDIF
C
      ENDIF
C
  280 CONTINUE
C
C     WRITE ASSEMBLED WIND BOGUS DATA TO OUTPUT FILE
C
      IF(OUTPUT)  THEN
      WRITE(6,281)      IRTYP,IDATE0,IOFFT,RLAT,RLON,NLEV
      WRITE(IUNTBG,281) IRTYP,IDATE0,IOFFT,RLAT,RLON,NLEV
  281 FORMAT(3X,I3,1X,I10,2X,I4,2(2X,F6.2),3X,I3)
      DO 290 KL=1,NLEV
      WRITE(6,283)      NINT(DATOUT(1,KL)),DATOUT(4,KL),IQZ,
     1                  DATOUT(2,KL),IQT,DATOUT(3,KL),IQM,
     2                  DATOUT(5,KL),DATOUT(6,KL),IQV
      WRITE(IUNTBG,283) NINT(DATOUT(1,KL)),DATOUT(4,KL),IQZ,
     1                  DATOUT(2,KL),IQT,DATOUT(3,KL),IQM,
     2                  DATOUT(5,KL),DATOUT(6,KL),IQV
  283 FORMAT(3X,I4,3(1X,F8.2,4X,I1),2(1X,F8.2),4X,I1)
  290 CONTINUE
      ENDIF
C
  300 CONTINUE
      END DO
      END DO

      IF(.NOT.MAK111)  GO TO 1000

C     CREATE A BOGUS POINT AT THE REPORTED STORM CENTER AND WRITE TO
C        OUTPUT FILE.  THIS POINT CONTAINS MASS INFORMATION, RIGHT NOW
C        A SURFACE PRESSURE BASED ON THE REPORTED STORM CENTRAL
C        PRESSURE AND A SURFACE HEIGHT OF ZERO.  THE SURFACE PRESSURE
C        WILL BE ADJUSTED AND SPECIFIC HMUIDITY WILL BE ADDED LATER IN
C        SUBROUTINE EDTPRP. THIS WILL LATER GET PREPBUFR REPORT TYPE
C        111.

      IPSURF=NINT(PCEN(1))
      ZSURF=0.0

C     SKIP ANY MANDATORY LEVELS BELOW THE SURFACE LEVEL

      MAXLV1 = 1
      DO KL=1,MAXLEV
         IF(IUAPRS(KL). LT. IPSURF )  THEN
            MAXLV1 = MAXLV1 + 1
         END IF
      END DO

C     THE SURFACE LEVEL

      WRITE(6,281)      IRTYPC,IDATE0,IOFFT,STMLAT(1),STMLON(1),MAXLV1
      WRITE(6,283)      IPSURF,ZSURF,IQZ,RMISS,IQT,RMISS,IQM,
     1                  RMISS,RMISS,IQV
      WRITE(IUNTBG,281) IRTYPC,IDATE0,IOFFT,STMLAT(1),STMLON(1),MAXLV1
      WRITE(IUNTBG,283) IPSURF,ZSURF,IQZ,RMISS,IQT,RMISS,IQM,
     1                  RMISS,RMISS,IQV

C     ADDITIONAL LEVELS ABOVE SURFACE

      DO KL=1,MAXLEV
         IF(IUAPRS(KL). LT. IPSURF )  THEN
            WRITE(6,283)      IUAPRS(KL),RMISS,IQZ,RMISS,IQT,RMISS,IQM,
     1                        RMISS,RMISS,IQV
            WRITE(IUNTBG,283) IUAPRS(KL),RMISS,IQZ,RMISS,IQT,RMISS,IQM,
     1                        RMISS,RMISS,IQV
         END IF
      END DO

 1000 CONTINUE

      IF(INCMOD) CALL ABRT1(' COMBIN',1000)

      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    EDTPRP      COPIES/EDITS PREPBUFR FILE, ADDS BOGUS
C   PRGMMR: D. A. KEYSER     ORG: NP22       DATE: 2012-08-31
C
C ABSTRACT: FIRST, READS THROUGH THE INPUT PREPBUFR FILE AND COPIES
C   ALL DATA TO THE OUTPUT PREPBUFR FILE.  IN THE PROCESS OF DOING
C   THIS, - IF REQUESTED - CHECKS FOR MASS REPORTS IN THE VICINITY OF
C   ALL STORMS PROCESSED AND FLAGS THE PRESSURE Q.M. ON ALL LEVELS
C   FOR THESE REPORTS, ALSO - IF REQUESTED - CHECKS FOR DROPWINSONDE
C   WIND REPORTS IN THE VICINITY OF ALL STORMS PROCESSED AND FLAGS THE
C   WIND Q.M. ON ALL LEVELS FOR THESE REPORTS (SEE COMMENTS IN THIS
C   SUBROUTINE FOR DEFINITION OF "IN THE VICINITY").  IN BOTH CASES,
C   THIS WILL PREVENT THESE REPORTS FROM BEING ASSIMILATED BY THE
C   ANALYSIS.  FINALLY, - IF REQUESTED - APPENDS BOGUS REPORTS,
C   GENERATED EARLIER FOR EACH STORM, TO THE OUTPUT PREPBUFR FILE.
C
C PROGRAM HISTORY LOG:
C 1991-06-06  S. J. LORD - ORIGINAL AUTHOR
C 1999-06-28  D. A. KEYSER - MADE CODE MORE EFFICIENT BY SKIPPING
C        THE READING OF REPORTS OUT OF BUFR MESSAGES WHICH NEVER
C        CONTAIN MASS DATA OR NEVER CONTAIN PRESSURE SINCE THESE
C        DATA ARE NEVER EDITED BY THIS SUBROUTINE, INSTEAD
C        JUST COPIES SUCH MESSAGES DIRECTLY TO OUTPUT PREPBUFR FILE;
C        CORRECTED ERROR WHICH HAD RESULTED IN ONLY REPORTS IN THE
C        VICINITY OF THE FIRST STORM BEING SUBJECT TO EDITING (PRESS.
C        Q.M. FLAGGING); OUTPUT BOGUS REPORTS NOW HAVE UNIQUE STNIDS;
C        ADDED DOCBLOCK, COMMENTS, AND MORE STDOUT PRINT
C 1999-09-22  D. A. KEYSER - THE FLAGGING OF MASS REPORTS IN THE
C        VICINITY OF STORMS IS NOW CONTROLLED BY NEW N-LIST SWITCH
C        "FLMASS", IF FALSE THEN REPORTS WILL NOT BE FLAGGED
C 2001-09-27  D. A. KEYSER - ENCODES INTO THE PREPBUFR FILE A NEW
C        MASS BOGUS REPORT WITH R. TYPE 111 AT THE LOCATION OF THE
C        STORM (IF PRELIMINARY FORM OF REPORT WAS GENERATED EARLIER
C        IN SUBROUTINE COMIN), THIS ROUTINE ADJUSTS THE REPORTED STORM
C        CENTRAL PRESSURE ACCORDING TO THE FIRST GUESS PRESSURE AND
C        THE STORM CATEGORY ON THE SAFFIR-SIMPSON SCALE, IT THEN USES
C        THE GUESS TEMPERATURES AND AN ASSUMPTION OF 99% R.H. TO
C        GENERATE SPECIFIC HUMIDTY ON ALL LEVELS THROUGHOUT THE DEPTH
C        OF THE STORM
C 2001-10-10  D. A. KEYSER -- MODIFIED TO NOW PASS TWO SPANNING GLOBAL
C        SIGMA GUESS FILES INTO W3LIB ROUTINE GBLEVENTS IN SITUATIONS
C        WHERE THE CENTER DATE FOR THE PREPBUFR FILE HAS AN HOUR THAT
C        IS NOT A MULTIPLE OF 3 (SEE 2001-10-10 CHANGES TO GBLEVENTS);
C        ADDED PROGRAM CODE ("SYNDATA") AND REASON CODE (0) FOR ALL
C        BOGUS DATA CREATED IN REPORT TYPES 210, 100, 111 (FOR TYPE
C        111 THIS CAN BE UPDATED WITH EVENTS - SEE 2001-09-27)
C 2004-09-09  D. A. KEYSER - REPORTS IN NEW MESSAGE TYPE GPSIPW
C        ARE NOT READ BECAUSE THEY NEVER CONTAIN MASS DATA OR PRESSURE
C        AND THUS ARE NEVER EDITED BY THIS SUBROUTINE (THEY ARE
C        INCLUDED IN LIST OF MESSAGE TYPES COPIED DIRECTLY TO OUTPUT
C        PREPBUFR FILE)
C 2005-07-01  D. A. KEYSER - ADDED OPTION TO FLAG DROPWINSONDE WINDS
C        ON ALL LEVELS FOR STORMS SUFFICIENTLY CLOSE TO STORMS VIA NEW
C        NAMELIST SWITCH "FLBWND" (DEFAULTS TO TRUE) (SEE COMMENTS IN
C        THIS SUBROUTINE FOR DEFINITION OF "SUFFICIENTLY CLOSE"); ADDED
C        OPTION TO NOT APPEND TYPE 110/210 BOGUS REPORTS TO PREPBUFR
C        FILE VIA NEW SCRIPT VARIABLE "DO_BOGUS" (OBTAINED VIA CALL TO
C        SYSTEM ROUTINE GETENV - DEFAULTS TO "YES")
C 2012-08-31  D. A. KEYSER - REMOVED DEPENDENCY OF MAK111 ON DO_BOGUS,
C        THUS IF DO_BOGUS=NO AND MAK111=TRUE TYPE 111 BOGUS REPORTS
C        WILL BE GENERATED EVEN THOUGH TYPE 110/220 BOGUS REPORTS ARE
C        NOT (BEFORE NEITHER WOULD BE GENERATED IF DO_BOGUS=NO); FIXED
C        STDOUT PRINT ERROR FOR LIMITING RADIUS OVERWHICH DROPSONDE
C        REPORTS WILL HAVE WIND QM'S FLAGGED
C 2020-01-09  J. Dong - Changed the windowing decade from 20 to 40
C        for cases when the years is represented by 2 digits instead
C        of 4.
C
C USAGE:    CALL EDTPRP(BLATMN,BLATMX,BLONMN,BLONMX,RMW,STMLAT,STMLON,
C    1                  IUNTPN,IUNTPO,IUNTBG,LSTORM,vmax,stmnam)
C   INPUT ARGUMENT LIST:
C     BLATMN   - ARRAY CONTAINING MINIMUM LATITUDE FOR EACH STORM
C              - (WITHIN WHICH MASS OBSERVATIONS MAY BE FLAGGED)
C     BLATMX   - ARRAY CONTAINING MAXIMUM LATITUDE FOR EACH STORM
C              - (WITHIN WHICH MASS OBSERVATIONS MAY BE FLAGGED)
C     BLONMN   - ARRAY CONTAINING MINIMUM LONGITUDE FOR EACH STORM
C              - (WITHIN WHICH MASS OBSERVATIONS MAY BE FLAGGED)
C     BLONMX   - ARRAY CONTAINING MAXIMUM LONGITUDE FOR EACH STORM
C              - (WITHIN WHICH MASS OBSERVATIONS MAY BE FLAGGED)
C     RMW      - ARRAY CONTAINING RADIUS OF MAXIMUM SURFACE WIND FOR
C              - EACH STORM (USED TO CALCULATE RADIUS WITHIN WHICH
C              - DROPWINSONDE WIND OBSERVATIONS MAY BE FLAGGED)
C     STMLAT   - ARRAY CONTAINING CENTER LATITUDE FOR EACH STORM
C              - (USED TO DETERMINE IF DROPWINSONDE WIND OBSERVATIONS
C              - ARE SUFFICIENTLY CLOSE THAT THEY MAY BE FLAGGED)
C     STMLON   - ARRAY CONTAINING CENTER LONGITUDE FOR EACH STORM
C              - (USED TO DETERMINE IF DROPWINSONDE WIND OBSERVATIONS
C              - ARE SUFFICIENTLY CLOSE THAT THEY MAY BE FLAGGED)
C     IUNTPN   - UNIT NUMBER OF INPUT PREPBUFR FILE
C     IUNTPO   - UNIT NUMBER OF OUTPUT PREPBUFR FILE
C     IUNTBG   - UNIT NUMBER OF INPUT FILE CONTAINING BOGUS DATA
C     LSTORM   - NUMBER OF STORMS
C     vmax     - array containing maximum reported wind speed (m/s)
C              - for each storm
C     stmnam   - character*9 array containing storm names
C
C   INPUT FILES:
C     UNIT "IUNTBG"  - BOGUS DATA
C     UNIT "IUNTPN"  - PREPBUFR FILE PRIOR TO ADDITION OF BOGUS DATA OR
C                    - ANY MODIFICATIONS TO NON-BOGUS REPORTS
C
C   OUTPUT FILES:
C     UNIT 06        - STANDARD OUTPUT PRINT
C     UNIT "IUNTPO"  - PREPBUFR FILE WITH POSSIBLE ADDITION OF BOGUS
C                    - DATA AND/OR POSSIBLE MODIFICATIONS TO NON-BOGUS
C                    - REPORTS
C
C REMARKS: NONE.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE EDTPRP(BLATMN,BLATMX,BLONMN,BLONMX,RMW,STMLAT,STMLON,
     1                  IUNTPN,IUNTPO,IUNTBG,LSTORM,vmax,stmnam)

      CHARACTER*80 CREC
      CHARACTER*52 HDSTR,PESTR,WESTR,TZSTR,UVSTR,zstr,qstr
      character*9  stmnam
      CHARACTER*8  STNID,SUBSET,SYNSET,LAST
      CHARACTER*3  DO_BOGUS
      CHARACTER*2  PREFIX

      DIMENSION    IUNTGS(2)
      DIMENSION    BLATMN(LSTORM),BLATMX(LSTORM),BLONMN(LSTORM),
     $             BLONMX(LSTORM),RMW(LSTORM),STMLAT(LSTORM),
     $             STMLON(LSTORM),RLON(LSTORM),vmax(lstorm),
     $             icat(lstorm),padj(0:5),stmnam(lstorm)

      REAL(8)      HDR_8(6),PES_8(4,255),WES_8(5,255),TZS_8(13,255),
     $             UVS_8(10,255),BMISS
      real(8)      qevn_8(4,255),pevn_8(4,255),fcst_8(2,255),
     $             zdta_8(5,255)
      EQUIVALENCE  (STNID,HDR_8(1))

      LOGICAL  PREVEN,FLMASS,DROP,FLBWND,MAK111

      COMMON/PREVSW/PREVEN
      COMMON/PROCSW/FLMASS,FLBWND,DO_BOGUS
      COMMON/BUFRLIB_MISSING/BMISS

      COMMON/T111SW/MAK111

      DATA SYNSET /'SYNDAT'/
      DATA PREFIX /'MA'/

      DATA HDSTR/'SID XOB YOB DHR TYP TSB                             '/
      DATA PESTR/'POB PQM PPC PRC                                     '/
      DATA WESTR/'UOB VOB WQM WPC WRC                                 '/
      DATA TZSTR/'CAT POB PQM PPC PRC TOB TQM TPC TRC ZOB ZQM ZPC ZRC '/
      DATA UVSTR/'CAT POB PQM PPC PRC UOB VOB WQM WPC WRC             '/
      data zstr /'CAT ZOB ZQM ZPC ZRC                                 '/
      data qstr /'QOB QQM QPC QRC                                     '/

      DATA IUNTGS/30,31/,IUNTOE/32/,IUNTSU/80/

C Storm center pressure adjustment (from guess pressure) based on
C  Category -- cat.  0    1    2    3    4    5 
      data padj /    0.,  0.,  4.,  8., 12., 15.  /

      SAVE

C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
C FCNS BELOW CONVERT TEMP/TD (K) & PRESS (MB) INTO SAT./ SPEC. HUM.(G/G)
      ES(T) = 6.1078 * EXP((17.269 * (T - 273.16))/((T - 273.16)+237.3))
      QFRMTP(T,P) = (0.622 * ES(T))/(P - (0.378 * ES(T)))
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------

      LAST = 'XXXXXXXX'

C  OPEN THE INPUT AND OUTPUT BUFR FILES
C  ------------------------------------

      CALL DATELEN(10)

      CALL OPENBF(IUNTPN,'IN',IUNTPN)
      CALL READMG(IUNTPN,SUBSET,IDATBF,IRET)
      IF(IRET.NE.0)  THEN
         PRINT *, 'EDTPRP - ERROR OPENING INPUT PREPBUFR FILE'
         CALL ERREXIT(20)
      END IF
      PRINT 789, IUNTPN,IDATBF
  789 FORMAT(/' ===> EDTPRP: INPUT PREPBUFR FILE IN UNIT',I3,
     $ ' SUCCESSFULLY OPENED - SECTION 1 MESSAGE DATE =',I11/)

      IF(IDATBF.LT.1000000000)  THEN

C If 2-digit year returned in IDATBF, must use "windowing" technique
C  to create a 4-digit year

C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS
C            CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT
C            Y2K COMPLIANT (BUFRLIB DOES THE WINDOWING HERE)

         PRINT *, '##SYNDATA - THE FOLLOWING SHOULD NEVER HAPPEN!!!!!'
         PRINT *, '##SYNDATA - 2-DIGIT YEAR IN IDATBF RETURNED FROM ',
     $    'READMG (IDATBF IS: ',IDATBF,') - USE WINDOWING TECHNIQUE ',
     $    'TO OBTAIN 4-DIGIT YEAR'
C IF IDATBF=41~99 THEN IDATBF=1941~1999
C IF IDATBF=00~40 THEN IDATBF=2000~2040
         IF(IDATBF/1000000.GT.40)  THEN
            IDATBF = 1900000000 + IDATBF
         ELSE
            IDATBF = 2000000000 + IDATBF
         ENDIF
         PRINT *, '##SYNDATA - CORRECTED IDATBF WITH 4-DIGIT YEAR, ',
     $    'IDATBF NOW IS: ',IDATBF
      ENDIF

      PRINT 1234
 1234 FORMAT(//' ===> EDTPRP: THE ENTIRE PREPBUFR FILE WILL BE READ, ',
     $ 'ALL MESSAGES ARE COPIED FROM INPUT PREPBUFR FILE TO OUTPUT ',
     $ 'PREPBUFR FILE.'/15X,'STORM BOUNDARIES AND RADIUS OF MAXIMUM ',
     $ 'SURFACE WIND WILL FOLLOW.'//)
      IF(DO_BOGUS.EQ.'YES') PRINT 1336
 1336 FORMAT(' ===> EDTPRP: TYPE 110/210 BOGUS REPORTS WILL BE ',
     $ 'APPENDED TO PREPBUFR FILE.'//)
      IF(MAK111) PRINT 8336
 8336 FORMAT(' ===> EDTPRP: TYPE 111 BOGUS REPORTS WILL BE APPENDED TO',
     $ ' PREPBUFR FILE.'//)
      IF(FLMASS) PRINT 1335
 1335 FORMAT(' ===> EDTPRP: ALL MASS REPORTS WITHIN THE STORM ',
     $ 'BOUNDARIES WILL HAVE THEIR PRESSURE Q.M. FLAGGED ON EVERY ',
     $ 'LEVEL.'//)
      IF(FLBWND) PRINT 1236
 1236 FORMAT(' ===> EDTPRP: ALL DROPWINSONDE REPORTS WITHIN A ',
     $ 'DISTANCE TO STORM CENTER OF THE LARGER OF 111 KM OR 3 X THE ',
     $ 'RADIUS OF MAXIMUM'/15X,'SURFACE WIND WILL HAVE THEIR WIND Q.M.',
     $ ' FLAGGED ON EVERY LEVEL.'//)

      DO J = 1,LSTORM

C Determine the Saffir-Simpson Storm Category based on the maximum
C  reported wind speed (use cateogry 0 for all speeds below hurricane
C  strength)

         vmax(j) = 1.94 * vmax(j)
         if(vmax(j).gt.135.0) then
            icat(j) = 5
         else  if(vmax(j).gt.113.0) then
            icat(j) = 4
         else  if(vmax(j).gt.95.0) then
            icat(j) = 3
         else  if(vmax(j).gt.82.0) then
            icat(j) = 2
         else  if(vmax(j).gt.63.0) then
            icat(j) = 1
         else
            icat(j) = 0
         end if

C  Convert the storm center longitude to west longitude (0-360)
C   (this is assuming storm center longitude comes in as 0-360 E)
C  --------------------------------------------------------------

         RLON(J) = 360. - STMLON(J)
         IF(RLON(J).EQ.360.)  RLON(J) = 0.

         PRINT 1294, stmnam(j),J,STMLAT(J),RLON(J),BLATMN(J),BLATMX(J),
     $    BLONMN(J),BLONMX(J),nint(RMW(J)),nint(vmax(j)),icat(j)
 1294 FORMAT(1X,A9,'(storm #',i2,'):: center:',f7.2,'N lat, ',f8.2,
     $ 'W lon; EDTPRP bdry: ',F7.2,' -',f7.2,'N lat and ',F8.2,
     $ ' -',F8.2,'E lon'/24X,'Radius of max. wind speed is ',I4,
     $ ' km; Max. wind speed is ',I3,' knots making this a Cat. ',I1,
     $ ' storm'//)
      ENDDO

      PRINT 1295
 1295 FORMAT(//)
      IF(.NOT.PREVEN)  THEN
         PRINT 7300
 7300 FORMAT(/1X,100('#')/' ===> EDTPRP: W3LIB ROUTINE GBLEVENTS NOT ',
     $ 'INVOKED -- NAMELIST SWITCH "PREVEN" IS FALSE'/1X,100('#')/)
         WRITE(IUNTSU,7300)
         WRITE(IUNTSU,7301)
 7301 FORMAT(130('#')//40X,'*** NO "PREVENT" EVENTS DATA FILTERING ***'
     $ //)
      END IF
      PRINT 1295

      CALL CLOSBF(IUNTPN)
      CALL OPENBF(IUNTPN,'IN',IUNTPN)

      CALL OPENBF(IUNTPO,'OUT',IUNTPN)
      CALL MAXOUT(50000)                ! CH 08/31/21
      CALL UFBQCD(IUNTPO,'SYNDATA',ISYNPC)

C  VARIOUS COPYING OPTIONS
C  -----------------------

      ICPYMG = 0
      ICNTOT = 0
      ICNTMM = 0
      ICNTMW = 0
      ICNTTA = 0

   30 CONTINUE

      CALL READMG(IUNTPN,SUBSET,JDATBF,IRET)
      IF(IRET.NE.0) GO TO 20
      IF(.NOT.FLMASS.AND.(.NOT.FLBWND.OR.SUBSET.NE.'ADPUPA  '))  THEN

C  NO NEED TO DECODE THIS MESSAGE IF FLMASS IS FALSE AND EITHER
C   FLBWND IS FALSE OR THIS MESSAGE TYPE IS NOT ADPUPA
C  ------------------------------------------------------------

         IF(SUBSET.NE.LAST)  THEN
            IF(LAST.NE.'XXXXXXXX')  THEN
               IF(LAST.NE.'ADPUPA  ')  THEN
                  PRINT 2249, IUNTPN,LAST
 2249 FORMAT(/' ===> EDTPRP: ALL MESSAGES IN INPUT PREPBUFR FILE IN ',
     $ 'UNIT',I3,' WITH TABLE A ENTRY "',A8,'" PROCESSED -- '/15X,
     $ 'SINCE FLMASS IS FALSE, NO INDIVIDUAL REPORTS WERE DECODED OUT ',
     $ 'OF THESE MESSAGES'/)
               ELSE
                  IF(.NOT.FLBWND)  THEN
                     PRINT 2250, IUNTPN,LAST
 2250 FORMAT(/' ===> EDTPRP: ALL MESSAGES IN INPUT PREPBUFR FILE IN ',
     $ 'UNIT',I3,' WITH TABLE A ENTRY "',A8,'" PROCESSED -- '/15X,
     $ 'SINCE FLMASS AND FLBWND BOTH FALSE, NO INDIVIDUAL REPORTS ',
     $ 'WERE DECODED OUT OF THESE MESSAGES'/)
                  ELSE
                     PRINT 1249, IUNTPN,LAST,ICNTTA
                     CALL CLOSMG(IUNTPO)
                  END IF
               END IF
               PRINT 1240, IUNTPN,SUBSET,JDATBF
            END IF
         END IF
         LAST = SUBSET
         CALL COPYMG(IUNTPN,IUNTPO)
         GO TO 30
      END IF
      IF(SUBSET.NE.LAST)  THEN
         ICPYMG = 0
         IF(LAST.NE.'XXXXXXXX')  PRINT 1249, IUNTPN,LAST,ICNTTA
 1249 FORMAT(/' ===> EDTPRP: ALL MESSAGES IN INPUT PREPBUFR FILE IN ',
     $ 'UNIT',I3,' WITH TABLE A ENTRY "',A8,'" PROCESSED -- '/15X,
     $ 'NUMBER OF INDIVIDUAL REPORTS DECODED OUT OF THESE MESSAGES =',
     $ I6/)
         ICNTTA = 0
         PRINT 1240, IUNTPN,SUBSET,JDATBF
 1240 FORMAT(/' ===> EDTPRP: NEXT MESSAGE IN INPUT PREPBUFR FILE IN ',
     $ 'UNIT',I3,' HAS NEW TABLE A ENTRY OF "',A8,'" -- DATE IS',I11)

C  NO NEED TO DECODE MESSAGES CONTAINING ONLY WIND DATA OR NO PRESSURE
C  -------------------------------------------------------------------

         IF(SUBSET.EQ.'SATWND  '.OR.SUBSET.EQ.'PROFLR  '.OR.
     $      SUBSET.EQ.'VADWND  '.OR.SUBSET.EQ.'GOESND  '.OR.
     $      SUBSET.EQ.'SPSSMI  '.OR.SUBSET.EQ.'ERS1DA  '.OR.
     $      SUBSET.EQ.'GPSIPW  ') THEN
            PRINT 1241, IUNTPO
 1241 FORMAT(/' ===> EDTPRP: MESSAGES WITH THIS TABLE A ENTRY WILL ',
     $ 'NEVER BE MODIFIED - COPY MESSAGES TO OUTPUT PREPBUFR FILE IN ',
     $ 'UNIT',I3/)

cc dak 7/3/05 - icpymg is ALWAYS zero here
cc dak 7/3/05 IF(ICPYMG.EQ.0.AND.LAST.NE.'XXXXXXXX') CALL CLOSMG(IUNTPO)
            if(last.ne.'XXXXXXXX')  call closmg(iuntpo)

            ICPYMG = 1
         ELSE  IF(SUBSET.EQ.'SYNDAT  ') THEN
            PRINT 1291, IUNTPO
 1291 FORMAT(/' ===> EDTPRP: MESSAGES WITH THIS TABLE A ENTRY WILL ',
     $ 'NEVER BE PROCESSED NOR COPIED TO OUTPUT PREPBUFR FILE IN UNIT',
     $ I3/15X,'SINCE THE BOGUS SYNDATA SHOULD NOT BE IN THE INPUT ',
     $ 'PREPBUFR FILE'/)
            ICPYMG = 1
         ELSE
            PRINT 1242, IUNTPO
 1242 FORMAT(/' ===> EDTPRP: MESSAGES WITH THIS TABLE A ENTRY MAY BE ',
     $ 'MODIFIED PRIOR TO THEIR OUTPUT TO PREPBUFR FILE IN UNIT',I3,/
     $ 15X,' - EACH INDIVIDUAL REPORT MUST BE DECODED'/)
         END IF
      END IF
      LAST = SUBSET

      IF(ICPYMG.EQ.1)  THEN

C  "SYNDAT" MESSAGES SHOULD NEVER BE IN INPUT PREPBUFR FILE, BUT IF
C   THEY ARE DON'T COPY THEM TO OUTPUT PREPBUFR FILE
C  ----------------------------------------------------------------

         IF(SUBSET.NE.'SYNDAT  ')  THEN
            CALL COPYMG(IUNTPN,IUNTPO)
         ELSE
            PRINT 2345, IUNTPN,IUNTPO
 2345 FORMAT(/' ===> EDTPRP: MESSAGE WITH TABLE A ENTRY "SYNDAT  " ',
     $ 'ENCOUNTERED IN INPUT PREPBUFR FILE IN UNIT',I3,/15X,'-- DO NOT',
     $ ' COPY TO OUTPUT PREPBUFR FILE IN UNIT',I3/)
         END IF
         GO TO 30
      END IF

      CALL OPENMB(IUNTPO,SUBSET,JDATBF)

   10 CONTINUE

      CALL READSB(IUNTPN,IRET)
      IF(IRET.NE.0) GO TO 30
      ICNTTA = ICNTTA + 1
      ICNTOT = ICNTOT + 1
      CALL UFBCPY(IUNTPN,IUNTPO)
      CALL UFBINT(IUNTPN,HDR_8,6,1,IRET,HDSTR)
      XOB  = HDR_8(2)
      YOB  = HDR_8(3)
      KX   = HDR_8(5)
      ITSB = HDR_8(6)
      KK   = KX/100
      DROP = (KX.EQ.232 .AND. ITSB.EQ.2)
      IF(KK.EQ.2 .AND. .NOT.DROP) GO TO 15 !If this is a wind rpt other
                                           ! than a drop, no chg made
      IF(.NOT.DROP)  THEN
         IF(FLMASS)  THEN
C-----------------------------------------------------------------------
C      Processing to flag pressure q.m. on all lvls for mass reports
C            within any one of the storm(s) lat/lon boundaries
C-----------------------------------------------------------------------
            DO  J = 1,LSTORM
               IF(NINT(XOB*100.).GE.NINT(BLONMN(J)*100.)) THEN
                  IF(NINT(XOB*100.).LE.NINT(BLONMX(J)*100.)) THEN
                     IF(NINT(YOB*100.).GE.NINT(BLATMN(J)*100.)) THEN
                      IF(NINT(YOB*100.).LE.NINT(BLATMX(J)*100.))GOTO1500
                     END IF
                  END IF
               END IF
            ENDDO
            GO TO 15
 1500       CONTINUE
            CALL UFBINT(IUNTPN,PES_8,4,255,NLEV,PESTR)
            NFLAG = 0
            DO J=1,NLEV
               PQM = PES_8(2,J)
               IF(PQM.LT.10) THEN
                  PES_8(2,J) = 10
                  PES_8(3,J) = ISYNPC
                  PES_8(4,J) = 10
                  NFLAG = 1
               ELSE
                  PES_8(:,J) = BMISS
               ENDIF
            ENDDO
            IF(NFLAG.EQ.1)  THEN
               PRINT 7280
 7280 FORMAT(/' ===> EDTPRP: ALL LEVEL PRESSURE Q. MARKS WERE FLAGGED ',
     $ '(SET TO 10, R. CODE=10) FOR THE FOLLOWING NON-BOGUS REPORT:')
               PRINT 7220, YOB,XOB,STNID,NLEV,HDR_8(4),KX
 7220 FORMAT(1X,'LATITUDE =',F7.2,'  LONGITUDE=',F7.2,'  STN. ID  =',A8,
     $ '  NO. LVLS =',I3,'  DEL. TIME=',F6.2,'  REP. TYPE=',I3/)
               ICNTMM = ICNTMM + 1
            END IF
            CALL UFBINT(IUNTPO,PES_8,4,NLEV,IRET,PESTR)
         END IF
      ELSE
         IF(FLBWND) THEN
C-----------------------------------------------------------------------
C  Processing to flag wind q.m. on all lvls for dropwindonde reports
C   which are within the larger of 111 km or three times the radius of
C                  maximum surface wind of any storm
C-----------------------------------------------------------------------

C  Convert reported dropwinsonde longitude to west longitude (0-360)
C   (this is assuming dropwinsonde longitude comes in as 0-360 E)
C  -----------------------------------------------------------------

            XOB = 360. - XOB
            IF(XOB.EQ.360.)  XOB = 0.
            DO  J = 1,LSTORM
               JST = J
               CALL CHDIST(RLON(J),STMLAT(J),XOB,YOB,RDIST)
cppppppppppppppp
cc          print *, '++ distance to storm ',jst,' = ',rdist,', max ',
cc   $       'limit for flagging is ',MAX(111.,3*RMW(J))
cc          print *, 'RLON(J),STMLAT(J),XOB,YOB: ',
cc   $                RLON(J),STMLAT(J),XOB,YOB
cppppppppppppppp
C              IF(RDIST.LE.(MAX(111.,3*RMW(J))))  GO TO 1600
               IF((vmax(j) .GE. 32.) .AND. (RDIST .LE. 55.)) GO TO 1600
            ENDDO
            GO TO 15
 1600       CONTINUE
            CALL UFBINT(IUNTPN,WES_8,5,255,NLEV,WESTR)
            NFLAG = 0
            DO J=1,NLEV
               WQM = WES_8(3,J)
               IF(WQM.LT.10) THEN
                  WES_8(3,J) = 10
                  WES_8(4,J) = ISYNPC
                  WES_8(5,J) = 99
                  NFLAG = 1
               ELSE
                  WES_8(:,J) = BMISS
               ENDIF
            ENDDO
            IF(NFLAG.EQ.1)  THEN
               PRINT 8280
 8280 FORMAT(/' ===> EDTPRP: ALL LEVEL WIND Q. MARKS WERE FLAGGED ',
     $ '(SET TO 10, R. CODE=99) FOR THE FOLLOWING DROPWINSONDE REPORT:')
               PRINT 8220, YOB,XOB,STNID,NLEV,HDR_8(4),KX,ITSB,JST,
     $         NINT(RDIST),MAX(111,3*NINT(RMW(JST)))
 8220 FORMAT(1X,'LATITUDE =',F7.2,'N  LONGITUDE=',F7.2,'W  STN. ID  =',
     $ A8,'  NO. LVLS =',I3,'  DEL. TIME=',F6.2,'  REP. TYPE/SUBTYPE=',
     $ I3,'/',I1/1X,'DIST. FROM STORM',I3,'=',I5,'KM WHICH IS WITHIN ',
     $ 'LIMIT OF ',I5,'KM'/)
               ICNTMW = ICNTMW + 1
            END IF
            CALL UFBINT(IUNTPO,WES_8,5,NLEV,IRET,WESTR)
         END IF
C-----------------------------------------------------------------------
      END IF
   15 CONTINUE
      CALL WRITSB(IUNTPO)
      GOTO 10

   20 CONTINUE
      IF(.NOT.FLMASS.AND.(.NOT.FLBWND.OR.LAST.NE.'ADPUPA  '))  THEN
         IF(LAST.NE.'ADPUPA  ')  THEN
            PRINT 2249, IUNTPN,LAST
         ELSE
            PRINT 2250, IUNTPN,LAST
         END IF
      ELSE
         PRINT 1249, IUNTPN,LAST,ICNTTA
      END IF
      PRINT 1259, IUNTPN,ICNTOT,ICNTMM,ICNTMW,IUNTPO
 1259 FORMAT(//' ===> EDTPRP: ALL MESSAGES IN INPUT PREPBUFR FILE IN ',
     $ 'UNIT',I3,' PROCESSED -'/16X,'NUMBER OF INDIVIDUAL REPORTS ',
     $ 'DECODED OUT OF ALL MESSAGES =',I6,' -- OF THESE ...'/19X,
     $ '-- TOTAL NUMBER OF MASS REPORTS ACTUALLY MODIFIED =',10X,I7/
     $ 19X,'-- TOTAL NUMBER OF DROPWINSONDE WIND REPORTS ACTUALLY ',
     $ 'MODIFIED = ',I3//15X,'OUTPUT PREPBUFR FILE IN UNIT',I3,
     $ ' CONTAINS ALL ORIGINAL REPORTS PLUS ANY OF THESE MODIFICATIONS'
     $ //)
      CALL CLOSBF(IUNTPN)
      PRINT 799, IUNTPN
  799 FORMAT(/' ===> EDTPRP: INPUT PREPBUFR FILE IN UNIT',I3,
     $ ' SUCCESSFULLY CLOSED'/)
      CALL CLOSMG(IUNTPO)

      IF(DO_BOGUS.EQ.'NO' .AND. .NOT.MAK111)  THEN
         CALL CLOSBF(IUNTPO)
         PRINT 899, IUNTPO
         PRINT 809
  809 FORMAT(/' ===> EDTPRP: NO BOGUS DATA APPENDED TO PREPBUFR FILE ',
     $ ' (AS REQUESTED)'/)
         RETURN
      END IF

      NEWTYP = 1

C***********************************************************************
C***********************************************************************
C           ADD THE COMPLETE SET OF BOGUS REPORTS (FOR ALL STORMS)
C***********************************************************************
C***********************************************************************

      CALL OPENMG(IUNTPO,SYNSET,IDATBF)
      IREPOT  = 0

  600 CONTINUE
      READ(IUNTBG,'(A80)',END=100) CREC
      IF(CREC(2:6).NE.'START') GO TO 600

C This is "START" record, NSTORM tells us the storm number ...

      READ(CREC(22:24),'(I3)') NSTORM
      READ(IUNTBG,'(A80)',END=100) CREC
      IF(CREC(2:4).EQ.'END') GO TO 600

C This is the first data record for this storm

      ICOUNT = 0
      IREP   = 0
      IREPO  = 0
      READ(CREC(3:42),'(4F10.2)') XLATMN,XLATMX,XLONMN,XLONMX

      PRINT 1235, stmnam(nstorm),NSTORM,XLATMN,XLATMX,XLONMN,XLONMX
 1235 FORMAT(/116('!')/' ===> EDTPRP: For ',A9,' (storm #',I2,'), ',
     $ 'ready to read in and process into PREPBUFR file all generated ',
     $ 'bogus reports'/15X,'Boundary for reports is: ',F7.2,' - ',F7.2,
     $ 'N lat and ',F8.2,' - ',F8.2,'E lon'/116('!')/)

   55 CONTINUE
      READ(IUNTBG,'(A80)',END=100) CREC
      IF(CREC(2:4).EQ.'END') THEN
         PRINT 1275, stmnam(nstorm),NSTORM,IREPO,IUNTPO,SYNSET
 1275 FORMAT(/116('i')/' ===> EDTPRP: All done processing bogus ',
     $ 'reports for ',A9,'(storm #',I2,') - these',I4,' reports added ',
     $ 'to '/15X,'PREPBUFR file in unit',I3,' under table A entry "',A8,
     $ '"'/116('i')/)
         GO TO 600
      END IF
      READ(CREC(4:45),'(I3,13X,I4,2(2X,F6.2),3X,I3)') IRTYP,ITIME,ALAT,
     $ ALON,NLVLS
      ICOUNT = ICOUNT+1
      IREP   = IREP+1
      if(irtyp.eq.210.or.irtyp.eq.110) WRITE(6,57) NSTORM,IREP,IRTYP,
     $ ITIME,ALAT,ALON,NLVLS
   57 FORMAT(' STORM#, EDPREP#, IRTYP,ITIME,ALAT,ALON,NLVLS=',4I10,
     $ 2F10.2,I10)

C  GENERATE REPORT ID
C  ------------------

      WRITE(STNID,'(A2,I2.2,I4.4)') PREFIX,NSTORM,ICOUNT
      HDR_8(2) = ALON
      HDR_8(3) = ALAT
      HDR_8(4) = ITIME
      HDR_8(5) = IRTYP
      HDR_8(6) = BMISS

C  READ AND STORE THE REPORT LEVELS
C  --------------------------------

      TZS_8  = BMISS
      UVS_8  = BMISS
      pevn_8 = BMISS
      zdta_8 = BMISS
      qevn_8 = bmiss
      NLT  = 0
      NLW  = 0
      nltx = 0

      DO ILEV=1,NLVLS
         READ (IUNTBG,58) IPOB,ZOB,IZQM,TOB,ITQM,QOB,IQQM,UOB,VOB,IWQM
         IF((IRTYP.EQ.210.OR.IRTYP.EQ.110) .AND. DO_BOGUS.EQ.'YES') THEN
            WRITE(6,58) IPOB,ZOB,IZQM,TOB,ITQM,QOB,IQQM,UOB,VOB,IWQM
   58       FORMAT(3X,I4,3(1X,F8.2,4X,I1),2(1X,F8.2),4X,I1)
            IF(ZOB.GT.-9999 .OR. TOB.GT.-9999) THEN
               NLT = NLT+1
               TZS_8(1,NLT) = 1
               TZS_8(2,NLT) = IPOB
               TZS_8(3,NLT) = 1
               TZS_8(4,NLT) = ISYNPC
               TZS_8(5,NLT) = 0
               IF(TOB.GT.-9999) THEN
                  TZS_8(6,NLT) = TOB
                  TZS_8(7,NLT) = ITQM
                  TZS_8(8,NLT) = ISYNPC
                  TZS_8(9,NLT) = 0
               END IF
               IF(ZOB.GT.-9999) THEN
                   TZS_8(10,NLT) = ZOB
                   TZS_8(11,NLT) = IZQM
                   TZS_8(12,NLT) = ISYNPC
                   TZS_8(13,NLT) = 0
               END IF
            ENDIF
            IF(UOB.GT.-9999 .AND. VOB.GT.-9999) THEN
               NLW = NLW+1
               UVS_8( 1,NLW) = 1
               UVS_8( 2,NLW) = IPOB
               UVS_8( 3,NLW) = 1
               UVS_8( 4,NLW) = ISYNPC
               UVS_8( 5,NLW) = 0
               UVS_8( 6,NLW) = UOB
               UVS_8( 7,NLW) = VOB
               UVS_8( 8,NLW) = IWQM
               UVS_8( 9,NLW) = ISYNPC
               UVS_8(10,NLW) = 0
            ENDIF
         ELSE IF(IRTYP.EQ.111 .AND. MAK111) then
            NLTX = NLTX+1
            ZDTA_8(1,NLTX) = 1
            IF(ILEV .EQ. 1)  ZDTA_8(1,NLTX) = 0
            IF(ZOB.GT.-9999) THEN
               ZDTA_8(2,NLTX) = ZOB
               ZDTA_8(3,NLTX) = IZQM
               ZDTA_8(4,NLTX) = ISYNPC
               ZDTA_8(5,NLTX) = 0
            END IF
            PEVN_8(1,NLTX) = IPOB
            PEVN_8(2,NLTX) = 1
            PEVN_8(3,NLTX) = ISYNPC
            PEVN_8(4,NLTX) = 0
            IF (ILEV .EQ. 1)  THEN

C The initial surface pressure for report type 111 (the reported
C  storm center pressure) is assigned a reason code of 2

               PEVN_8(2,NLTX) = 0
               PEVN_8(3,NLTX) = ISYNPC
               PEVN_8(4,NLTX) = 2
            END IF
         ENDIF
      ENDDO

C  WRITE THE REPORT(S) OUT
C  -----------------------

      IF(NLT.GT.0) THEN
         CALL UFBINT(IUNTPO,HDR_8,6,  1,IRET,HDSTR)
         CALL UFBINT(IUNTPO,TZS_8,13,NLT,IRET,TZSTR)

C  CALL SUBROUTINE GBLEVENTS TO ENCODE BACKGROUND EVENTS FOR THIS REPORT
C  ---------------------------------------------------------------------

         IF(PREVEN)  CALL GBLEVENTS(IDATBF,IUNTGS,IUNTOE,IUNTPO,IUNTSU,
     $    SYNSET,NEWTYP)
         NEWTYP = 0
         CALL WRITSB(IUNTPO)
         IREPO   = IREPO+1
         IREPOT  = IREPOT+1
         PRINT 1298, IUNTPO,NINT(HDR_8(5))
 1298 FORMAT(/' ===> EDTPRP: THIS BOGUS MASS REPORT SUCCESSFULLY ',
     $ 'ENCODED INTO OUTPUT PREPBUFR FILE IN UNIT',I3,', RTYPE=',I3/)
      ENDIF

      IF(NLW.GT.0) THEN
         HDR_8(5) = HDR_8(5) + 100
         CALL UFBINT(IUNTPO,HDR_8,6,  1,IRET,HDSTR)
         CALL UFBINT(IUNTPO,UVS_8,10,NLW,IRET,UVSTR)

C  CALL SUBROUTINE GBLEVENTS TO ENCODE BACKGROUND EVENTS FOR THIS REPORT
C  ---------------------------------------------------------------------

         IF(PREVEN)  CALL GBLEVENTS(IDATBF,IUNTGS,IUNTOE,IUNTPO,IUNTSU,
     $    SYNSET,NEWTYP)
         NEWTYP = 0
         CALL WRITSB(IUNTPO)
         IREPO   = IREPO+1
         IREPOT  = IREPOT+1
         PRINT 1260, IUNTPO,NINT(HDR_8(5))
 1260 FORMAT(/' ===> EDTPRP: THIS BOGUS WIND REPORT SUCCESSFULLY ',
     $ 'ENCODED INTO OUTPUT PREPBUFR FILE IN UNIT',I3,', RTYPE=',I3/)
      ENDIF

      if(nltx.gt.0) then
         call ufbint(IUNTPO,hdr_8,6,  1,iret,hdstr)
         call ufbint(IUNTPO,zdta_8,5,nltx,iret,zstr)
         call ufbint(IUNTPO,pevn_8,4,nltx,iret,pestr)

C  CALL SUBROUTINE GBLEVENTS TO ENCODE BACKGROUND EVENTS FOR THIS REPORT
C  ---------------------------------------------------------------------

         if(preven)  call gblevents(idatbf,iuntgs,iuntoe,IUNTPO,iuntsu,
     $    synset,newtyp)
         newtyp = 0

C Now, pull out the guess pressure and temperature

         call ufbint(-IUNTPO,fcst_8,2,255,nlev,'PFC TFC ')
         write(6,57) nstorm,irep,nint(hdr_8(5)),nint(hdr_8(4)),hdr_8(3),
     $    hdr_8(2),nlev
         do  ilev = 1,nlev
            if(ibfms(fcst_8(1,ilev)).eq.0 .and. icat(nstorm).le.5 .and.
     $                                     icat(nstorm).ge.0) then
               pnew = fcst_8(1,ilev) - padj(icat(nstorm))
               if(pnew.gt.pevn_8(1,ilev))  then

C Next, update the surface pressure by using the guess pressure
C  along with an adjustment that is based on the Saffir-Simpson
C  Storm Category - as long as this updated pressure is greater
C  than the current pressure (the storm central pressure) this
C  updated pressure is encoded in the PREPBUFR file as an event
C  with reason code 3

                  pevn_8(1,ilev) = pnew
                  pevn_8(2,ilev) = 0
                  pevn_8(3,ilev) = Isynpc
                  pevn_8(4,ilev) = 3
                  call ufbint(IUNTPO,pevn_8(1,ilev),4,1,iret,pestr)
               end if
            end if
            if(ibfms(fcst_8(2,ilev)).eq.0 .and. ibfms(pevn_8(1,ilev))
     $        .eq.0)  then

C Next, use the guess temperature and pressure obs. (just corrected at
C  surface) to generate a saturated specific humidity

               tkel = fcst_8(2,ilev) + 273.16
               pevn = pevn_8(1,ilev)
               qsat = qfrmtp(tkel,pevn) * 1.e6
               if(qsat.gt.0 .and. qsat.lt.99999.)  then

C Now, generate a specific humidity based on an assumed r.h. of 99%
C  and encode this as the specific humidity obs. on all levels 0
C  this event gets reason code 1

                  qevn_8(1,ilev) = 0.99 * qsat
                  qevn_8(2,ilev) = 0
                  qevn_8(3,ilev) = Isynpc
                  qevn_8(4,ilev) = 1
               end if
            end if
            write(6,758) pevn_8(1,ilev),nint(pevn_8(2,ilev)),
     $       zdta_8(1,ilev),nint(zdta_8(2,ilev)),bmiss,nint(bmiss),
     $       qevn_8(1,ilev),nint(qevn_8(2,ilev)),bmiss,bmiss,nint(bmiss)
  758       format(3X,F6.1,4X,I2,3(1X,F8.2,4X,I1),2(1X,F8.2),4X,I1)
         end do
         call ufbint(IUNTPO,qevn_8,4,nlev,iret,qstr)
         call writsb(IUNTPO)
         irepo   = irepo+1
         irepot  = irepot+1
         print 1298, IUNTPO,nint(hdr_8(5))
      endif

      IF(MAX(NLT,NLW,nltx).EQ.0) THEN
         IF(DO_BOGUS.NE.'YES' .AND. MAK111) THEN
            PRINT 3299, IUNTPO
 3299 FORMAT(/' ===> EDTPRP: THIS BOGUS REPORT   N O T   ENCODED ',
     $ 'INTO OUTPUT PREPBUFR FILE IN UNIT',I3,' - DO_BOGUS=NO'/)
         ELSE IF(DO_BOGUS.EQ.'YES' .AND. .NOT.MAK111) THEN
            PRINT 4299, IUNTPO
 4299 FORMAT(/' ===> EDTPRP: THIS BOGUS REPORT   N O T   ENCODED ',
     $ 'INTO OUTPUT PREPBUFR FILE IN UNIT',I3,' - MAK111=FALSE'/)
         ELSE
            PRINT 1299, IUNTPO
 1299 FORMAT(/' ===> EDTPRP: THIS BOGUS REPORT   N O T   ENCODED ',
     $ 'INTO OUTPUT PREPBUFR FILE IN UNIT',I3/)
         end if
         ICOUNT = ICOUNT-1
      END IF

      GOTO 55

  100 CONTINUE

      PRINT 1261, IUNTPO,IREPOT,SYNSET
 1261 FORMAT(//' ===> EDTPRP: ALL DONE -- OUTPUT PREPBUFR FILE IN UNIT',
     $ I3,' CONTAINS ALL ORIGINAL REPORTS (MAYBE WITH MODIFCATIONS)'/
     $ 15X,'PLUS THESE',I5,' BOGUS REPORTS UNDER TABLE A ENTRY "',A8,
     $ '"'//)

C  NORMAL EXIT
C  -----------

      CALL CLOSMG(IUNTPO)
      CALL CLOSBF(IUNTPO)
      PRINT 899, IUNTPO
  899 FORMAT(/' ===> EDTPRP: OUTPUT PREPBUFR FILE IN UNIT',I3,
     $ ' SUCCESSFULLY CLOSED'/)

      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: CHDIST
C   PRGMMR: D. KEYSER        ORG: NP22       DATE: 2004-02-02
C
C ABSTRACT:  COMPUTES CHORD LENGTH DISTANCE FROM ONE LAT/LON POINT
C   TO ANOTHER LAT/LON POINT USING THE FORMULA:
C     S**2/2 = 1 - COS(Y1-Y2) + COS(Y1)*COS(Y2)*(1-COS(X1-X2)).
C
C PROGRAM HISTORY LOG:
C 1990-11-06  J. WOOLLEN -- ORIGINAL AUTHOR
C 2004-02-02  D. KEYSER  -- CORRECTED SUBROUTINE ARGUMENT MISALIGNMENT
C    (THIS DID NOT APPEAR TO CAUSE PROBLEMS IN OUTPUT BUT COULD CAUSE
C    MEMORY CLOBBERING DOWN THE LINE SOMEWHERE)
C
C USAGE:  CALL CHDIST(X1,Y1,X2,Y2,DIST)
C   INPUT ARGUMENTS:
C     X1         - LONGITUDE (0.-360. W) OF POINT 1
C     Y1         - LATITUDE  (N+,S-)     OF POINT 1
C     X2         - LONGITUDE (0.-360. W) OF POINT 2
C     Y2         - LATITUDE  (N+,S-)     OG POINT 2
C
C   OUTPUT ARGUMENTS:
C     DIST       - CHORD LENGTH DISTANCE BETWEEN POINTS (KM)
C
C REMARKS: NONE
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE CHDIST(X1,Y1,X2,Y2,DIST)

      DATA PI180/.0174532 /,RADE/6371./

      SAVE PI180,RADE

C  COMPUTE THE DISTANCE
C  --------------------

      COSY1 = COS(Y1*PI180)
      COSY2 = COS(Y2*PI180)
      COSDX = COS((X1-X2)*PI180)
      COSDY = COS((Y1-Y2)*PI180)
      S = 1.0-COSDY+COSY1*COSY2*(1.0-COSDX)
      S = SQRT(2.*S)
      IF(S.LE..002) S = 0.
      DIST = S*RADE

      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:  SPHERP     SPHERICAL TRANSFORM TO A POINT
C   PRGMMR: KANAMITSU     ORG: NP23          DATE: 1992-04-16
C
C ABSTRACT: TRANSFORMS A SPECTRAL FIELD TO A POINT ON THE GLOBE.
C
C PROGRAM HISTORY LOG:
C 1992-04-16  IREDELL
C
C USAGE:    CALL SPHERP(WAVE,MAXWV,IROMB,IDY,MLT,FAC,RLAT,RLON,VALUE)
C
C   INPUT ARGUMENT LIST:
C     WAVE     - IF IDIR < 0, COMPLEX (KMAX) FIELD TO TRANSFORM,
C                WHERE KMAX=(MAXWV+1)*(IROMB+1)*MAXWV+2)/2.
C                WAVE STARTS AT THE GLOBAL MEAN COMPONENT AND THEN
C                CONTAINS THE ZONALLY SYMMETRIC COMPONENTS.
C     MAXWV    - SPECTRAL TRUNCATION OF THE WAVE
C     IROMB    - IROMB = 0 FOR TRIANGULAR TRUNCATION
C                IROMB = 1 FOR RHOMBOIDAL TRUNCATION
C     IDIR     - 0 FOR NORMAL, 1 FOR LEGENDRE DERIVATIVE
C     MLT      - MULTIPLICATION OPTION ON WAVE VALUES.
C                MLT = 0 FOR NO MULTIPLICATION,
C                MLT = 1 TO MULTIPLY WAVE BY FAC
C                MLT = -1 TO MULTIPLY WAVE BY SQRT(-1)*FAC
C     FAC      - IF MLT.NE.0, REAL (KMAX) FIELD TO MULTIPLY WAVE.
C     RLAT     - LATITUDE IN DEGREES NORTH
C     RLON     - LONGITUDE IN DEGREES EAST
C
C   OUTPUT ARGUMENT LIST:
C     VALUE    - TRANSFORMED VALUE
C
C   SUBPROGRAMS CALLED:
C     (LEGENDR2) - COMPUTE LEGENDRE POLYNOMIALS
C
C   REMARKS: FORTRAN 9X EXTENSIONS ARE USED.
C     FPP CAN BE USED TO INLINE SUBPROGRAMS.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  IBM-SP
C
C$$$
CFPP$ EXPAND(LEGENDR2)
      SUBROUTINE SPHERP(WAVE,MAXWV,IROMB,IDY,MLT,FAC,RLAT,RLON,VALUE)
      REAL WAVE((MAXWV+1)*((IROMB+1)*MAXWV+2))
      REAL FAC((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
      REAL PNM((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
      REAL DNM((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
      REAL FR(0:MAXWV),FI(0:MAXWV)
      PARAMETER(PI=3.1415926535898,PI180=PI/180.)
      SINLAT=SIN(RLAT*PI180)
      CALL LEGENDR2(SINLAT,MAXWV,IROMB,PNM,DNM)
      IF(IDY.NE.0) THEN
        PNM=DNM
      ENDIF
      IF(MLT.NE.0) THEN
        PNM=PNM*FAC
      ENDIF
      K=0
      DO M=0,MAXWV
        FR(M)=0.
        FI(M)=0.
      ENDDO
      DO M=0,MAXWV
        DO N=M,IROMB*M+MAXWV
          FR(M)=FR(M)+WAVE(2*K+1)*PNM(K+1)
          FI(M)=FI(M)+WAVE(2*K+2)*PNM(K+1)
          K=K+1
        ENDDO
      ENDDO
      VALUE=0.
      RLAM=RLON*PI180
      IF(MLT.GE.0) THEN
        DO M=1,MAXWV
          VALUE=VALUE+FR(M)*COS(RLAM*M)-FI(M)*SIN(RLAM*M)
        ENDDO
      ELSE
        DO M=1,MAXWV
          VALUE=VALUE-FI(M)*COS(RLAM*M)-FR(M)*SIN(RLAM*M)
        ENDDO
      ENDIF
      VALUE=FR(0)+2.*VALUE
      RETURN
      END
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:  LEGENDR2   COMPUTE LEGENDRE POLYNOMIALS.
C   PRGMMR: IREDELL       ORG: NP23          DATE: 1992-04-16
C
C ABSTRACT: EVALUATES THE NORMALIZED ASSOCIATED LEGENDRE POLYNOMIALS
C   AT A GIVEN COSINE OF COLATITUDE.
C
C PROGRAM HISTORY LOG:
C 1992-04-16  IREDELL
C
C USAGE:    CALL LEGENDR2(COSCLT,MAXWV,IROMB,PNM,DNM)
C
C   INPUT ARGUMENT LIST:
C     COSCLT   - COSINE OF COLATITUDE AT WHICH TO EVALUTATE.
C     MAXWV    - SPECTRAL TRUNCATION
C     IROMB    - IROMB = 0 FOR TRIANGULAR TRUNCATION
C                IROMB = 1 FOR RHOMBOIDAL TRUNCATION
C
C   OUTPUT ARGUMENT LIST:
C     PNM      - REAL (KMAX) POLYNOMIAL VALUES,
C     DNM      - REAL (KMAX) POLYNOMIAL DERIVATIVES,
C                WHERE KMAX=(MAXWV+1)*(IROMB+1)*MAXWV+2)/2.
C
C   REMARKS: FORTRAN 9X EXTENSIONS ARE USED.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  IBM-SP
C
C$$$
      SUBROUTINE LEGENDR2(COSCLT,MAXWV,IROMB,PNM,DNM)
      DIMENSION PNM((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
      DIMENSION DNM((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
      DIMENSION EPS(0:100)
      SINCLT=SQRT(1.-COSCLT**2)
      NM=0
      K=1
      PNM(K)=SQRT(0.5)
CDIR$ NEXTSCALAR
      DO M=1,MAXWV-NM*(1-IROMB)
        PNMK=PNM(K)
        K=M*(2*MAXWV+2+(1-M)*(1-IROMB))/2+(NM+1)
        PNM(K)=PNMK*SINCLT*SQRT(FLOAT(2*M+1)/FLOAT(2*M))
      ENDDO
      NM=1
CDIR$ IVDEP
      DO M=0,MAXWV-NM*(1-IROMB)
        N=M+NM
        EPSNM=SQRT(FLOAT(N**2-M**2)/FLOAT(4*N**2-1))
        K=M*(2*MAXWV+2+(1-M)*(1-IROMB))/2+(NM+1)
        PNM(K)=COSCLT*PNM(K-1)/EPSNM
        DNM(K-1)=EPSNM*PNM(K)*(N-1)
        EPS(M)=EPSNM
      ENDDO
      DO NM=2,MAXWV
CDIR$ IVDEP
        DO M=0,MAXWV-NM*(1-IROMB)
          N=M+NM
          EPSNM=SQRT(FLOAT(N**2-M**2)/FLOAT(4*N**2-1))
          K=M*(2*MAXWV+2+(1-M)*(1-IROMB))/2+(NM+1)
          PNM(K)=(COSCLT*PNM(K-1)-EPS(M)*PNM(K-2))/EPSNM
          DNM(K-1)=EPSNM*PNM(K)*(N-1)-EPS(M)*PNM(K-2)*N
          EPS(M)=EPSNM
        ENDDO
      ENDDO
CDIR$ IVDEP
      DO M=0,MAXWV
        NM=MAXWV-M*(1-IROMB)
        N=M+NM
        EPS(M)=SQRT(FLOAT(N**2-M**2)/FLOAT(4*N**2-1))
        N=N+1
        EPSNM=SQRT(FLOAT(N**2-M**2)/FLOAT(4*N**2-1))
        K=M*(2*MAXWV+2+(1-M)*(1-IROMB))/2+(NM+1)
        K=K+1
        PNMK=(COSCLT*PNM(K-1)-EPS(M)*PNM(K-2))/EPSNM
        DNM(K-1)=EPSNM*PNMK*(N-1)-EPS(M)*PNM(K-2)*N
      ENDDO
      RETURN
      END

