PROGRAM ADP73U C C From: http://dss.ucar.edu/datasets/ds353.4/software/readupa2.f (or, C but not publically accessible: ~baseball/rje/NMC/adp73prt2.upa ) C C Use f90 to compile. Designed for interactive use. For batch use, you C must wrap this in a script, and rewrite the program code which asks C the user for information - i.e., "hardwire" into DATA statements, etc. C C Written by Gregg Walters, NCAR/SCD/DSS, 2001Jun22 C major modifications: C 2002Nov14 C C C 2007Jun15 (now does location counts) C 2008Jul18 (now can select on elevation) C C contact baseball@ucar.edu or datahelp@ucar.edu C C >>> INSTRUCTIONS FOR USE <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< C >>> PLEASE READ ALL OF THIS TO LEARN HOW TO USE THE PROGRAM <<<<<<<<<<<<<<<<<< C C It can optionally produce a print of all observations in a file, except as C specified by the user when prompted, or by editing the program. C C It can optionally print a list of stations being printed, their names, and C the number of reports from each. C C It reads NCEP/NMC ADP ON29 formatted data from a sequential file. ADP data C files were not designed by NCEP for random access. Our mission has been C to keep an historical archive of data in their original formats. It is C up to you, perhaps using output from this program, to engineer a database. C C When this is run, you will first be prompted to decide whether to do dumps. C If you have modified the program, and having a lot of trouble debugging, C you might try this mode - just be aware that the dump volume can be very C large. When you do choose to do dumps, no selection criteria will be C offered or applied. C C Next you will be prompted for an input file from DS353.4. These files are C available from two sources: the NCAR MSS or the DSS server, and the file C format differs between them. C C The files on the MSS are listed here: C C http://dss.ucar.edu/datasets/ds353.4/MSS-file-list.html C C These files are COS-blocked. You should use msread -fCH to download C the data from the NCAR MSS, which will strip the COS-blocking and add C "newline characters" making them ready to use as input to readupa2. C C Using msread -fBI will strip the COS-blocking but not add the "newline C characters". See below for help with a "fold" command to do this. C C If msrcp is used, you will then need to use our cosconvert software C found here: C C http://dss.ucar.edu/libraries/io/cos_blocking/utils/ C C and then do a "fold" (see below). C C The files on the DSS server can be obtained from here: C http://dss.ucar.edu/datasets/ds353.4/data/ C C These files are not COS-blocked, but they are gzipped, meaning that you C must do a gunzip. The resulting file could be used in the MM5 or WRF. C However, to use in readupa2, you must then do a "fold". C C HELP WITH "fold". readupa2 will only work when the input file has C logical records separated by a "newline character". If not, you will C need to use our FORTRAN version of the UNIX fold, found here: C C http://dss.ucar.edu/datasets/ds353.4/software/fold.f C c Compile it, and move the executable to "fold". Then copy your input C file to fort.11. Then execute fold. The output will be given C in fort.12, which can be used in readupa2. C C In the directory where readupa2 is run, you must have a copy of the USAF C dictionary, named 'usafdict', which is a copy of: C C http://dss.ucar.edu/datasets/ds900.0/data/combined C C >>>>>>> NOTE: A FILE IN THE FORM ACCEPTABLE TO THIS PROGRAM CAN NOT BE <<<<<<< C >>>>>>> READ BY THE MM5. <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< C C Next you will be prompted for an output file. C C If you are not doing a dump, then you will be prompted for a data set C type, up to 10 periods of record, a geographic region and/or a list C of station numbers. Then you will also be prompted for the various C units to be used, and for controls on the appearance of the printout. C Finally, after all these prompts, if you choose not to proceed, you C can either quit, or reset these things and then proceed. C C A sample output is in: C http://dss.ucar.edu/datasets/ds353.4/software/readupa2.sampleout C C The NCEP/NMC ADP format is here: C http://dss.ucar.edu/datasets//common/nmc.adp/format_on29_01mar C C C C PARAMETER (MX=500) ! NUMBER OF LEVELS PARAMETER (NRAN=10) ! NUMBER OF DATE RANGES PARAMETER (MXLV8=8) ! NUMBER OF ADDITIONAL DATA PORTIONS PARAMETER (KWMAX=100) ! NUMBER OF STATIONS FOR SELWMO C CHARACTER*8 QSHO, D08, A08, M08 COMMON / ARRAYS / P(MX), Z(MX), T(MX), H(MX), D(MX), F(MX), A C(MX), QSHO(MX), D08(MX), A08(MX), M08(MX), IC08(MX), R PMSG, ZMSG, TMSG, HMSG, DMSG, FMSG, CMSG C C P PRESSURE IN MB C Z GEOPOTENTIAL IN METERS C T TEMPERATURE IN DEGREES C AS PRINTED (IN TENTHS OF DEGREES AS PACKED) C H DEWPOINT DEPRESSION IN DEGREES C AS PRINTED (IN TENTHS OF DEGREES C AS PACKED) C D WIND DIRECTION IN DEGREES C F WIND SPEED IN KNOTS C Q SET OF QUALITY MARKS (SEE NCEP/NMC OFFICE NOTE 29) C FOR P,Z,T,H,W(WIND) C C C C LEAVE THE 10000 ALONE, EVEN THOUGH IT IS BIGGER THAN THE ORIGINAL C 6440 LOGICAL RECORD SIZE C CHARACTER NBF*10000 COMMON / ADPB / NBF COMMON / ADPC / LOGREC, NU, NA, LTHR, LOUT, idump, irep, ireplim C CHARACTER*8 EOREP, EOREC, XS, WASH, EOFIL COMMON / ADP / EOREP, EOREC, XS, WASH, EOFIL C PARAMETER (JX=21) COMMON / PRESS / PM(JX), KTOP(JX), ICRITR, MANTHRU C C REAL*8 TIME, XLAT, XLON, ELEV CHARACTER*16 IDATSHO CHARACTER*8 IDSTYP, IDTPRT, ASTA C COMMON / CRDADP / IDATSHO, IDSTYP, IDTPRT, ASTA, XLAT, XLON, 2 ELEV, IRTYP, INSTYP, IRC, IYR, IMO, IDY, IHR, TIME, TIME08 DIMENSION ELEVLIM(2) <---<< C C CHARACTER*1 IC25, IC26, IC27 CHARACTER*5 ICNN COMMON / RESERVE / IC25, IC26, IC27, ICNN C CHARACTER*8 LOCI(5,1801,3601) ! STATION ID - UP TO 5 AT EACH POINT CHARACTER*5 STATID CHARACTER*26 NAMEDIC DIMENSION LOCT(5,1801,3601) ! STATION TYPE - UP TO 5 AT EACH POINT DIMENSION LOCK(5,1801,3601) ! COUNTER - UP TO 5 AT EACH POINT C CHARACTER*6 SELWMO(KWMAX) C CHARACTER ARC*13, AREP*3, ANST*3, ANSB*4 CHARACTER*3 MON(12) DATA MON / 'JAN', 'FEB', 'MAR', 'APR', 'MAY', 'JUN', D 'JUL', 'AUG', 'SEP', 'OCT', 'NOV', 'DEC'/ C CHARACTER*2 DYSHO, HRSHO, AGENCY C CHARACTER*32 FNAMI, FNAMO, FILE, FMT, FORM, STAT, STATUS C DIMENSION IPERBEG(NRAN), IPEREND(NRAN) CHARACTER GLOBE*1, IITAB*1, STNSEL*1 <---<< CHARACTER IPERIOD*16, IPSEL*1, IADJ*1, TIMECK*11, IRISK*1 CHARACTER TYPOUT*1 CHARACTER DATETAG*8, DATETUG*8, LONA*1 CHARACTER IDEF*1, IHTU*1, ITEMPU*1, IDEW*1, IWINDU*1 CHARACTER AHTU*2, ATEMPU*1, ADEW*6, AWINDU*3 C CHARACTER ISTACK*1, ASTACK*12, ISORT*1, IDASH*1 CHARACTER IPROC*1, IQR*1, AYR*4 CHARACTER ADU*2 CHARACTER AGM*15 CHARACTER ARP*10, SURFACE*7, TPAUSE*10 C C C AGM = ' ' C SURFACE = 'SURFACE' TPAUSE = 'TROPOPAUSE' NP = 0 ! INITIALIZE THE COUNTER FOR CATEGORY 06 HEADER PRINTS 1000 CONTINUE WRITE (*,*) ' ' WRITE (*,*) ' It is suggested that you widen your window', W ' to 90 - 100 columns, for cleaner prompts' WRITE (*,*) ' ' WRITE (*,*) ' Enter a 0 here; unless you want to run', W ' in a debugging mode, in which case' WRITE (*,*) ' enter the number of reports to dump' WRITE (*,*) ' ' C READ (*,7000,ERR=1000) ZZ READ (*,*,ERR=1000) ZZ idump = ZZ C C7000 FORMAT (I) C NU = 99999 NA = 0 LTHR = 0 C IREC = 0 C IREP = 0 ! REPORTS READ IREPP = 0 ! REPORTS PRINTED ireplim = idump ! limit number of reports read when idump > 0 MLIM = MX MAXLEV = MX C C *** SPECIFY INPUT FILE NAME C WRITE (*,*) ' ' WRITE (*,*) ' Enter input file name' WRITE (*,*) ' ' READ (*,7001) FNAMI 7001 FORMAT (A) IUN = 1 FMT = 'FORMATTED' STAT = 'OLD' OPEN (IUN,FILE=FNAMI,FORM=FMT,STATUS=STAT) C WRITE (*,*) ' ' WRITE (*,*) ' Enter output file name' WRITE (*,*) ' ' READ (*,7001) FNAMO LOUT = 7 STAT = 'NEW' OPEN (LOUT,FILE=FNAMO,FORM=FMT,STATUS=STAT) C 1001 CONTINUE C WRITE (*,*) ' Please select the type of output you want' WRITE (*,*) ' ' WRITE (*,*) ' Enter For' WRITE (*,*) ' d Data reports only' WRITE (*,*) ' s Station report counts only' WRITE (*,*) ' b Both' READ (*,7001) TYPOUT IF (TYPOUT.NE.'d'.AND.TYPOUT.NE.'s'.AND.TYPOUT.NE.'b') GO TO 1000 C IRISK = 'n' ISTACK = 'n' ASTACK = ' ' C IDEF = 'y' C IHTU = 'm' AHTU = ' M' ADU = 'KM' C C C ITEMPU = 'c' ATEMPU = 'C' C IDEW = 'd' ADEW = 'DEWDEP' C IWINDU = 'k' AWINDU = 'KTS' C ISORT = 'd' IDASH = 'n' NRPBH = 50 C IOK = 0 C DATETAG(1:8) = 'SYNOPTIC' DATETUG(1:8) = 'synoptic' LONA = 'W' IRADIUS = 99999 XRADIUS = IRADIUS YLON = 0.0 YLAT = 0.0 DIST = 0.0 ELEVLIM(1) = 99999. <---<< C IF (idump.NE.0) THEN IDTPRT(1:3) = 'all' C ISTACK = 'n' ISTACK = 'y' ASTACK = '(stacked) ' ISTICKY = 1 ISLIPPY = 1 IPERBEG(1) = 1 GLOBE(1:1) = 'g' SELWMO(1)(1:1) = 'q' ELSE 1010 CONTINUE C C ***** SELECT A SPECIFIC FILE TYPE BY SETTING IDTPRT C WRITE (*,*) ' ' WRITE (*,*) ' Enter data type to print, choosing from' WRITE (*,*) ' ' WRITE (*,*) ' Type From ---------' WRITE (*,*) ' ADPUPA DS353.4 List A - raobs & pibals', w ' (all categories separately)' WRITE (*,*) ' STKUPA DS353.4 List A - raobs & pibals', w ' (stack all categories with pressure)' WRITE (*,*) ' AIRCFT DS353.4 List B - aircraft' WRITE (*,*) ' SIRSOB DS353.4 List C - satellite ir soundings' WRITE (*,*) ' SATWND DS353.4 List D - satellite winds' C WRITE (*,*) ' UPABOG DS353.4 List E - upper air bogus' WRITE (*,*) ' AIRCAR DS353.4 List F - aircar' WRITE (*,*) ' ' WRITE (*,*) ' all Print all types available' WRITE (*,*) ' ' WRITE (*,*) ' Note: DS353.1 also has these data types' WRITE (*,*) ' ' READ (*,7001) IDTPRT IF (IDTPRT(1:6).EQ.'ADPUPA') THEN IOK = 1 ASTACK = '(stacked) ' ISTICKY = 1 ISLIPPY = 0 ENDIF IF (IDTPRT(1:6).EQ.'STKUPA') THEN IOK = 1 IDTPRT(1:6) = 'ADPUPA' ISTACK = 'y' ASTACK = '(stacked) ' ISTICKY = 1 ISLIPPY = 0 ENDIF IF (IDTPRT(1:6).EQ.'AIRCFT') THEN ! CATEGORY 06 ONLY? IOK = 1 ISTICKY = 0 ISLIPPY = 1 ENDIF IF (IDTPRT(1:6).EQ.'SIRSOB') THEN IOK = 1 ASTACK = '(stacked) ' ISTICKY = 1 ISLIPPY = 0 ENDIF IF (IDTPRT(1:6).EQ.'SATWND') THEN ! CATEGORY 06 ONLY? IOK = 1 ISTICKY = 0 ISLIPPY = 1 ENDIF C IF (IDTPRT(1:6).EQ.'UPABOG') THEN C IOK = 1 C ISTICKY = 0 C ISLIPPY = 1 C ENDIF IF (IDTPRT(1:6).EQ.'AIRCAR') THEN ! CATEGORY 06 ONLY? IOK = 1 ISTICKY = 0 ISLIPPY = 1 ENDIF IF (IDTPRT(1:3).EQ.'ALL' ) IDTPRT(1:3) = 'all' IF (IDTPRT(1:3).EQ.'all' ) THEN IOK = 1 ISTICKY = 1 ISTACK = 'y' ! THIS FORCES STACKING ASTACK = '(stacked) ' ! WHEN DOING ALL TYPES ISLIPPY = 1 ENDIF IF (IOK.EQ.0) THEN WRITE (*,*) ' DATA TYPE NOT RECOGNIZED - type' WRITE (*,*) ' exactly as shown' GO TO 1010 ENDIF C C ***** SPECIFY PERIOD OF RECORD C WRITE (*,*) ' ' WRITE (*,*) ' Now prompting for the desired period(s) of record' KPER = 0 1020 CONTINUE WRITE (*,*) ' Please specify your date/times (this ', w 'prompt will be looped to allow up to' WRITE (*,*) ' ',NRAN,' selections)' WRITE (*,*) ' ' WRITE (*,*) ' Enter For' WRITE (*,*) ' ' WRITE (*,*) ' YYYYMMDDHH Beginning date/time', w ' (e.g. 2001061500)' WRITE (*,*) ' YYYYMMDDHH Ending date/time', w ' < on the next line > (say 9 if same as beginning)' WRITE (*,*) ' 1 All times available on the file' WRITE (*,*) ' q To stop specifications' WRITE (*,*) ' ' 1025 CONTINUE IF (KPER.GE.NRAN) GO TO 1030 IF (KPER.NE.0) THEN WRITE (*,*) 'NEXT (YYYYMMDDHH and YYYYMMDDHH, or q to quit)' ENDIF READ (*,7001) IPERIOD KPER = KPER + 1 IF (IPERIOD(1:1).EQ.'Q') IPERIOD(1:1) = 'q' IF (IPERIOD(1:1).EQ.'q') THEN IF (KPER.EQ.1) THEN IPERBEG(1) = 1 IPEREND(1) = 1 ELSE KPER = KPER - 1 ENDIF GO TO 1030 ENDIF READ (IPERIOD,7027,ERR=1020) IPERBEG(KPER) 7027 FORMAT (I10) IF (IPERBEG(KPER).EQ.1) GO TO 1030 IF (IPERBEG(KPER).LT.1973010100) GO TO 1020 READ (*,7027,ERR=1020) IPEREND(KPER) IF (IPEREND(KPER).EQ.9) IPEREND(KPER) = IPERBEG(KPER) IF (IPEREND(KPER).LT.IPERBEG(KPER)) GO TO 1020 GO TO 1025 1030 CONTINUE WRITE (*,*) ' ' WRITE (*,*) ' Choose the time convention to be used', W ' to select the data and to show in' WRITE (*,*) ' the printout -' WRITE (*,*) ' synoptic time (h) or report time (i) ?' WRITE (*,*) ' ' READ (*,7001) IPSEL IF (IPSEL.EQ.'H') IPSEL = 'h' IF (IPSEL.EQ.'I') IPSEL = 'i' IF (IPSEL.NE.'h'.AND.IPSEL.NE.'i') GO TO 1030 IF (IPSEL.EQ.'h') THEN IADJ = 'n' GO TO 1035 ENDIF 1032 CONTINUE IADJ = 'y' WRITE (*,*) ' ' WRITE (*,*) ' The true report date may differ from ', W ' the synoptic date.' WRITE (*,*) ' (e.g. a "year mo dy hr hr.hu" ' WRITE (*,*) ' of "1998 6 1 0 23.00" is' WRITE (*,*) ' really "1998 5 31 23 23.00"' WRITE (*,*) ' Would you like to adjust the report date? (y/n)' WRITE (*,*) ' HIGHLY RECOMMENDED to avoid confusion.' WRITE (*,*) ' Note: The adjustment will be done before', W ' the date/time selection is done.' C WRITE (*,*) ' ' READ (*,7001) IADJ IF (IADJ.EQ.'Y') IADJ = 'y' IF (IADJ.EQ.'N') IADJ = 'n' IF (IADJ.NE.'y'.AND.IADJ.NE.'n') GO TO 1032 1035 CONTINUE DATETAG(1:8) = 'SYNOPTIC' DATETUG(1:8) = 'synoptic' IF (IPSEL.EQ.'i') THEN DATETAG(1:8) = ' REPORT ' DATETUG(1:8) = ' report ' ENDIF WRITE (*,*) ' ' WRITE (*,*) ' The date/time sort for the great majority', W ' of the data is reliable. To save a' WRITE (*,*) ' little time, you could make the selection', W ' stop reading the (sequential) file' WRITE (*,*) ' for the period you want after the end', W ' of all periods are found. There is a' WRITE (*,*) ' small risk of losing out of sort data', W ' after that point. If nothing else, ' WRITE (*,*) ' it accelerates things when you are debugging.' WRITE (*,*) ' ' WRITE (*,*) ' So, do you want to do this kind of stop? (y/n)' WRITE (*,*) ' ' READ (*,7001) IRISK IF (IRISK.EQ.'Y') IRISK = 'y' IF (IRISK.EQ.'N') IRISK = 'n' IF (IRISK.NE.'y'.AND.IRISK.NE.'n') GO TO 1035 1040 CONTINUE C C ***** SPECIFY GEOGRAPHIC REGION C WRITE (*,*) ' ' WRITE (*,*) ' Now prompting for the geographic domain.' WRITE (*,*) ' ' WRITE (*,*) ' ' WRITE (*,*) ' Enter For' WRITE (*,*) ' g Entire globe' WRITE (*,*) ' l Latitude-longitude "window"' WRITE (*,*) ' r Places within a radius of a point. This' WRITE (*,*) ' will take longer to process than' WRITE (*,*) ' simple(latitude-longitude window)' WRITE (*,*) ' ' READ (*,7001) GLOBE(1:1) IF (GLOBE(1:1).EQ.'G') GLOBE(1:1) = 'g' IF (GLOBE(1:1).EQ.'L') GLOBE(1:1) = 'l' IF (GLOBE(1:1).EQ.'R') GLOBE(1:1) = 'r' IF (GLOBE(1:1).NE.'g'.AND. i GLOBE(1:1).NE.'l'.AND. i GLOBE(1:1).NE.'r') GO TO 1040 IF (idump0.NE.0) THEN write (lout,7700) globe(1:1), stnsel(1:1) 7700 format (//,1x,'GLOBE(1:1) = ',a1,1x,'STNSEL(1:1) = ',a1) ENDIF C IF (GLOBE(1:1).EQ.'g') THEN LONW = 360 LATS = -90 LONE = 0 LATN = 90 ALONW = LONW ALATS = LATS ALONE = LONE ALATN = LATN GO TO 1048 ENDIF C 1042 CONTINUE IF (GLOBE(1:1).EQ.'l') THEN WRITE (*,*) ' Now prompting for the desired latitude-', w 'longitude window' WRITE (*,*) ' We are using the coordinate system as', w ' specified in NMC Office Note 124' WRITE (*,*) ' ' WRITE (*,*) ' YOU MUST SPECIFY YOUR LONGITUDES AS POSITIVE', W ' INTEGER DEGREES FROM 0 TO 360 WEST.' WRITE (*,*) ' Characters e or w will not be understood.' WRITE (*,*) ' YOU MUST SPECIFY YOUR LATITUDES AS INTEGER', W ' DEGREES BETWEEN -90 (south) AND' WRITE (*,*) ' 90 (north).' WRITE (*,*) ' Characters n or s will not be understood.' WRITE (*,*) ' ' WRITE (*,*) ' Enter For latitude-longitude window' WRITE (*,*) ' www Longitude of lower left corner' WRITE (*,*) ' sss Latitude of lower left corner', w ' << on the next line >>' WRITE (*,*) ' eee Longitude of upper right corner', w ' << on the next line >>' WRITE (*,*) ' nnn Latitude of upper right corner', w ' << on the next line >>' c READ (*,*,ERR=1042) ZZ1, ZZ2, ZZ3, ZZ4 C7004 FORMAT (I/I/I/I) LONW = ZZ1 LATS = ZZ2 LONE = ZZ3 LATN = ZZ4 ALONW = LONW ALATS = LATS ALONE = LONE ALATN = LATN IF (LONW.LT. 0.OR.LONW.GT.360) GO TO 1042 IF (LATS.LT.-90.OR.LATS.GT. 90) GO TO 1042 C IF (LONE.LT. 0.OR.LONE.GT.360) GO TO 1042 IF (LONE.EQ.LONW) GO TO 1042 IF (LATN.LT.-90.OR.LATN.GT. 90) GO TO 1042 IF (LATN.LE.LATS) GO TO 1042 GO TO 1048 ENDIF C IF (GLOBE(1:1).EQ.'r') THEN 1044 CONTINUE WRITE (*,*) ' Within how many kilometers? (50-9999)' WRITE (*,*) ' ' READ (*,*,ERR=1044) ZZ IRADIUS = ZZ IF (IRADIUS.LT.50.OR.IRADIUS.GT.9999) THEN IRADIUS = 99999 GO TO 1044 ELSE XRADIUS = IRADIUS 1046 CONTINUE WRITE (*,*) ' What is your central point? ' WRITE (*,*) ' ' WRITE (*,*) ' We are using the coordinate system as', w ' specified in NMC Office Note 124' WRITE (*,*) ' ' WRITE (*,*) ' YOU MUST SPECIFY YOUR LONGITUDE AS DEGREES', W ' AND FRACTION FROM 0 TO 360 WEST.' WRITE (*,*) ' E.G. 105.1. Characters e or w will not be', W ' understood.' WRITE (*,*) ' YOU MUST SPECIFY YOUR LATITUDE AS DEGREES', W ' AND FRACTION FROM -90.0 (south) AND' WRITE (*,*) ' 90.0 (north).' WRITE (*,*) ' Characters n or s will not be understood.' WRITE (*,*) ' Enter decimal only' WRITE (*,*) ' ' WRITE (*,*) ' www Longitude of center' WRITE (*,*) ' sss Latitude of center', w ' << on the next line >>' READ (*,7003,ERR=1046) ALONW, ALATS 7003 FORMAT (F6.2/F6.2) IF (ALONW.LT. 0.OR.ALONW.GT.360) GO TO 1046 IF (ALATS.LT.-90.OR.ALATS.GT. 90) GO TO 1046 ALONE = ALONW ALATN = ALATS YLON = ALONW YLAT = ALATS GO TO 1048 ENDIF ENDIF C 1048 CONTINUE WRITE (*,*) ' In the output, show longitude west or east? (w/e)' WRITE (*,*) ' ' READ (*,7001) LONA IF (LONA.EQ.'w') LONA = 'W' IF (LONA.EQ.'e') LONA = 'E' IF (LONA.NE.'W'.AND.LONA.NE.'E') GO TO 1048 1050 CONTINUE C <---<< C ***** SPECIFY STATION SELECTION METHOD, IF ANY <---<< C <---<< WRITE (*,*) ' ' <---<< WRITE (*,*) ' Now prompting for WMO station selection method', <---<< W ' method (whether from entire globe, or' <---<< WRITE (*,*) ' from your latitude-longitude window)' <---<< WRITE (*,*) ' ' <---<< WRITE (*,*) ' NOTE- in order to get all reports from', <---<< W ' stations which use two different' <---<< WRITE (*,*) ' identifications, i.e. a WMO number or', <---<< W ' a call sign, be sure to select "All ' <---<< WRITE (*,*) ' stations"' <---<< WRITE (*,*) ' ' <---<< WRITE (*,*) ' Enter For ' <---<< WRITE (*,*) ' a All stations' <---<< WRITE (*,*) ' b Your list of WMO block numbers,', <---<< W ' up to KWMAX' <---<< WRITE (*,*) ' l Your list of WMO station numbers/names,', <---<< W ' up to KWMAX' <---<< WRITE (*,*) ' e Stations between two elevations' <---<< WRITE (*,*) ' ' <---<< WRITE (*,*) ' Please see ', <---<< w ' http://dss.ucar.edu/datasets/ds900.0/data/ , for' <---<< WRITE (*,*) ' a list of WMO station numbers, which includes', <---<< w ' name, lat-lon, elevation, etc.' <---<< WRITE (*,*) ' ' <---<< READ (*,7001,ERR=1050) STNSEL <---<< IF (STNSEL(1:1).EQ.'a') GO TO 1065 <---<< IF (STNSEL(1:1).EQ.'b') GO TO 1054 <---<< IF (STNSEL(1:1).EQ.'l') GO TO 1054 <---<< IF (STNSEL(1:1).EQ.'e') GO TO 1060 <---<< GO TO 1050 <---<< 1054 CONTINUE <---<< KW = 0 <---<< 1055 CONTINUE <---<< IF (KW.EQ.0) THEN <---<< WRITE (*,*) ' ' <---<< WRITE (*,*) ' Now prompting for WMO station numbers/blocks' <---<< WRITE (*,*) ' ' <---<< WRITE (*,*) ' Enter For ' <---<< WRITE (*,*) ' ' <---<< WRITE (*,*) ' BBNNN WMO station number (e.g. 72469 which', <---<< w ' is Denver)' <---<< WRITE (*,*) ' BB All the stations in a WMO block (e.g.', <---<< w ' 08, which is all of Spain)' <---<< WRITE (*,*) ' ' <---<< WRITE (*,*) ' Please see ', <---<< w ' http://dss.ucar.edu/datasets/ds900.0/data/ ,' <---<< WRITE (*,*) ' for a list of station numbers, which', <---<< w ' includes name, lat-lon, elevation, etc.' <---<< WRITE (*,*) ' ' <---<< ELSE <---<< WRITE (*,*) ' Enter next (BBNNN, BB, or q to quit)' <---<< ENDIF <---<< READ (*,7001) SELWMO(KW+1)(1:6) <---<< IF (KW.LT.KWMAX) THEN <---<< IF (SELWMO(KW+1)(1:1).EQ.'Q') SELWMO(KW+1)(1:1) = 'q' <---<< IF (SELWMO(KW+1)(1:1).NE.'q') THEN <---<< C READ (SELWMO(KW+1)(1:5),7000,ERR=1058) IWMO ! TEST INTEGERS <---<< READ (SELWMO(KW+1)(1:5),*,ERR=1058) ZZ ! TEST INTEGERS <---<< C ZZ = IWMO ! 2008.02.15 - PROBABLY A MISCODING <---<< IWMO = ZZ <---<< IF (IWMO.LT.0) GO TO 1055 <---<< 1058 CONTINUE <---<< KW = KW + 1 <---<< GO TO 1055 <---<< ELSE <---<< KW = KW + 1 <---<< ENDIF <---<< ELSE <---<< SELWMO(KW)(1:1) = 'q' <---<< ENDIF <---<< GO TO 1065 <---<< 1060 CONTINUE <---<< WRITE (*,*) ' Please enter the lowest and highest', <---<< w ' station elevations that you want, on', <---<< w ' successive lines, in whole meters.' <---<< READ (*,8060,ERR=1060) ILEVLIM <---<< ELEVLIM(1) = ILEVLIM <---<< READ (*,8060,ERR=1060) ILEVLIM <---<< ELEVLIM(2) = ILEVLIM <---<< 8060 FORMAT (I5) <---<< IF (ELEVLIM(1).LT.-60.0.OR.ELEVLIM(1).GT.11000.0) GO TO 1060 <---<< IF (ELEVLIM(2).LT.-60.0.OR.ELEVLIM(2).GT.11000.0) GO TO 1060 <---<< IF (ELEVLIM(2).LT.ELEVLIM(1)) GO TO 1060 <---<< 1065 CONTINUE <---<< C IDEF = 'y' ! commented out 2008.06.02 IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (*,*) ' ' WRITE (*,*) ' A LIMITED SELECTION OF DATA UNITS IS AVAILABLE', W ' Most of the ADP ON124 data is ' WRITE (*,*) ' in metric, but the winds are in knots.' WRITE (*,*) ' Do you just want to use the ADP ON124 units,', W ' and other defaults? (y/n)' WRITE (*,*) ' ' READ (*,7001,ERR=1070) IDEF IF (IDEF.EQ.'Y') IDEF = 'y' IF (IDEF.EQ.'N') IDEF = 'n' IF (IDEF.NE.'y'.AND.IDEF.NE.'n') GO TO 1065 1070 CONTINUE IF (IDEF.EQ.'y') GO TO 1089 WRITE (*,*) ' In the following prompts, the ON29 "NATIVE"', W ' units appears as capital letters.' WRITE (*,*) ' ' WRITE (*,*) ' Do you want to see elevation in METERS or', W ' feet? (m/f)' C C C C WRITE (*,*) ' ' READ (*,7001,ERR=1070) IHTU IF (IHTU.EQ.'M') IHTU = 'm' IF (IHTU.EQ.'F') IHTU = 'f' IF (IHTU.NE.'m'.AND.IHTU.NE.'f') GO TO 1070 IF (IHTU.EQ.'m') AHTU = ' M' IF (IHTU.EQ.'f') AHTU = 'FT' IF (IHTU.EQ.'m') ADU = 'KM' IF (IHTU.EQ.'f') ADU = 'MI' C C C 1075 CONTINUE WRITE (*,*) ' ' WRITE (*,*) ' Do you want to see temperatures in degrees', W ' CENTIGRADE or Fahrenheit? (c/f)' WRITE (*,*) ' ' READ (*,7001,ERR=1075) ITEMPU IF (ITEMPU.EQ.'C') ITEMPU = 'c' IF (ITEMPU.EQ.'F') ITEMPU = 'f' IF (ITEMPU.NE.'c'.AND.ITEMPU.NE.'f') GO TO 1075 IF (ITEMPU.EQ.'c') ATEMPU = 'C' IF (ITEMPU.EQ.'f') ATEMPU = 'F' 1080 CONTINUE WRITE (*,*) ' ' WRITE (*,*) ' Do you want to see DEWPOINT DEPRESSION', W ' (d) or dewpoint (p) ? (d/p)' WRITE (*,*) ' ' READ (*,7001,ERR=1080) IDEW IF (IDEW.EQ.'D') IDEW = 'd' IF (IDEW.EQ.'P') IDEW = 'p' IF (IDEW.NE.'d'.AND.IDEW.NE.'p') GO TO 1080 IF (IDEW.EQ.'d') ADEW = 'DEWDEP' IF (IDEW.EQ.'p') ADEW = ' DEWPT' 1085 CONTINUE WRITE (*,*) ' ' WRITE (*,*) ' Do you want to see winds in KNOTS or meters', W ' per second? (k/m)' WRITE (*,*) ' ' READ (*,7001,ERR=1085) IWINDU IF (IWINDU.EQ.'K') IWINDU = 'k' IF (IWINDU.EQ.'M') IWINDU = 'm' IF (IWINDU.NE.'k'.AND.IWINDU.NE.'m') GO TO 1085 IF (IWINDU.EQ.'k') AWINDU = 'KTS' IF (IWINDU.EQ.'m') AWINDU = 'MPS' 1089 CONTINUE 1090 CONTINUE IF (ISTICKY.EQ.1) THEN WRITE (*,*) ' ' WRITE (*,*) ' Do you want successive lines with ascending', W ' or descending pressure' WRITE (*,*) ' values? (a/d)' WRITE (*,*) ' ' READ (*,7001,ERR=1090) ISORT IF (ISORT.EQ.'A') ISORT = 'a' IF (ISORT.EQ.'D') ISORT = 'd' IF (ISORT.NE.'a'.AND.ISORT.NE.'d') GO TO 1090 1095 CONTINUE WRITE (*,*) ' ' WRITE (*,*) ' Do you want to separate some portions of', W ' the printout with dashed lines (y/n)?' WRITE (*,*) ' ' READ (*,7001,ERR=1095) IDASH IF (IDASH.EQ.'Y') IDASH = 'y' IF (IDASH.EQ.'N') IDASH = 'n' IF (IDASH.NE.'y'.AND.IDASH.NE.'n') GO TO 1095 ENDIF IF (ISLIPPY.NE.0) THEN 1097 CONTINUE WRITE (*,*) ' ' WRITE (*,*) ' How many single level reports (10 - 60) do', W ' you want to print between headers?' WRITE (*,*) ' (These are AIRCFT, AIRCAR and SATWND)' WRITE (*,*) ' You may enter 0 to turn off the headers, e', W 'xcept for one at the very beginning' WRITE (*,*) ' ' C READ (*,7000,ERR=1097) NRPBH READ (*,*,ERR=1097) ZZ NRPBH = ZZ C IF (NRPBH.EQ. 0) GO TO 1098 IF (NRPBH.LT.10.OR.NRPBH.GT.60) GO TO 1097 ENDIF ENDIF ENDIF 1098 CONTINUE C IF (idump.EQ.0) THEN IF (IDTPRT(1:3).NE.'all') THEN WRITE (LOUT,9899) FNAMI, IDTPRT(1:6), ASTACK 9899 FORMAT ( 1X,'---------------------------------------', F '---------------------------------------', F /,1X,'PRINTOUT OF UPPER AIR OBSERVATIONS FROM', F ' FILE ',A, F /,1X,'USING readupa2.f WITH THESE OPTIONS: ', F //,1X,' Print ',A,' data type only ',A) ELSE WRITE (LOUT,9900) FNAMI, ASTACK 9900 FORMAT ( 1X,'---------------------------------------', F '---------------------------------------', F /,1X,'PRINTOUT OF UPPER AIR OBSERVATIONS FROM', F ' FILE ',A, 'USING readupa2.f', F /,1X,'USING readupa2.f WITH THESE OPTIONS: ', F //,1X,' Print all data types on the file,', F ' including available ADPUPA',A) ENDIF ELSE write (lout,9901) fnami, ireplim 9901 FORMAT ( 1X,'---------------------------------------', F '---------------------------------------', F /,1X,'PRINTOUT OF UPPER AIR OBSERVATIONS FROM', F ' FILE ',A, F /,1X,'FIRST ',I4,' REPORTS IN DUMP MODE',/1X,' ') ENDIF IF (idump.EQ.0) THEN IF (IPERBEG(1).EQ.1) THEN WRITE (LOUT,9902) 9902 FORMAT (/,1X,' For all times on the file ') ELSE write (lout,9903) (iperbeg(ii),iperend(ii),ii=1,kper) 9903 FORMAT (/,1X,' For these periods: ', F 100(/4X,I10,' - ',I10)) IF (IRISK.EQ.'y') THEN write (lout,9904) 9904 FORMAT (/,1X,' Stopping file scan when end of last', F ' period(s) are first processed') ELSE write (lout,9904) 9905 FORMAT (/,1X,' Scanning entire file for data in period(s)') ENDIF ENDIF IF (IPSEL.EQ.'h') then TIMECK(1:11) = ' synoptic ' ELSE TIMECK(1:11) = 'observation' ENDIF WRITE (LOUT,9906) TIMECK(1:11) 9906 FORMAT (/,1X,' Using ',A,' times') IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,99070) 99070 FORMAT (/,1X,' In the printout of the reports, the') IF (IADJ.EQ.'y') then WRITE (LOUT,99071) DATETUG 99071 FORMAT (1X,' ',a,' dates have been adjusted so ', F 'that they agree with the report times') ELSE WRITE (LOUT,99072) DATETUG 99072 FORMAT (1X,' ',a,' dates are the header dates, ', F 'so they may disagree with the report ', F 'times.') ENDIF ENDIF IF (GLOBE(1:1).EQ.'g') THEN <---<< WRITE (LOUT,9908) 9908 FORMAT (/,1X,' Stations from the entire globe') ENDIF IF (GLOBE(1:1).EQ.'l') THEN <---<< WRITE (LOUT,99091) LONW, LONE, LATS, LATN 99091 FORMAT (/,1X,' Stations from this window: ', F /,1X,' Longitude (W) ',I3,' eastward to ',I3, F ' ', F /,1X,' Latitude ',I3,' northward to ',I3) ENDIF IF (GLOBE(1:1).EQ.'r') THEN WRITE (LOUT,99092) IRADIUS, ALONW, ALATS 99092 FORMAT (/,1X,' Stations Within ',I5,' km of this point:', F /,1X,' Longitude (W) ',F6.2, F /,1X,' Latitude ',F6.2, F /,1X,' When reports are printed, the distance', F ' from this point will appear in the ID') ENDIF IF (STNSEL(1:1).EQ.'b'.OR.STNSEL(1:1).EQ.'l') THEN WRITE (LOUT,9910) (SELWMO(KKW)(1:6),KKW=1,KW-1) <---<< 9910 FORMAT (/,1X,' Extracting these stations: (just 2 digits', <---<< F ' means stations with this WMO block number)', <---<< F 10(/,5X,A,2X,A,2X,A,2X,A,2X,A)) <---<< ENDIF IF (STNSEL(1:1).EQ.'e') THEN IF (ELEVLIM(1).NE.99999.) THEN WRITE (LOUT,9912) ELEVLIM(1), ELEVLIM(2) <---<< 9912 FORMAT (/,1X,' Extracting stations within this elevation ', <---<< F ' range:' <---<< F /,5X,F6.0,' through ',F6.0,' meters') <---<< ENDIF <---<< ENDIF <---<< IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN IF (LONA.EQ.'W') THEN WRITE (LOUT,99121) 99121 FORMAT (/,1X,' Longitudes will be shown as 0 - 360 WEST', F ' of the GM') ELSE WRITE (LOUT,99122) 99122 FORMAT (/,1X,' Longitudes will be shown as 0 - 360 EAST', F ' of the GM') ENDIF ENDIF IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9914) AHTU, ATEMPU 9914 FORMAT (/,1X,' Heights in ',A, F /,1X,' Temperatures in ',A) IF (IDEW.EQ.'d') THEN WRITE (LOUT,9915) 9915 FORMAT ( 1X,' Moisture as a dewpoint depression') ELSE WRITE (LOUT,9916) 9916 FORMAT ( 1X,' Moisture as a dewpoint') ENDIF WRITE (LOUT,9917) AWINDU 9917 FORMAT ( 1X,' Winds in ',A) IF (ISORT.EQ.'d') THEN WRITE (LOUT,99181) 99181 FORMAT (/,1X,' Sounding levels in descending pressure', F ' order') ELSE WRITE (LOUT,99182) 99182 FORMAT (/,1X,' Sounding levels in ascending pressure', F ' order') ENDIF IF (IDASH.EQ.'n') THEN WRITE (LOUT,99183) 99183 FORMAT ( 1X,' Dashed lines will not be used to separate', F ' certain portions') ELSE WRITE (LOUT,99184) 99184 FORMAT ( 1X,' Dashed lines will be used to separate', F ' certain portions') ENDIF IF (ISLIPPY.NE.0) THEN IF (NRPBH.EQ.0) THEN WRITE (LOUT,9919) 9919 FORMAT (/,1X,' Just one single level report header will', F ' be printed') ELSE WRITE (LOUT,9920) NRPBH 9920 FORMAT (/,1X,' For single level reports, a header will', F ' be printed every ',I4,' consecutive reports') ENDIF ENDIF ENDIF ENDIF C C REWIND (LOUT) CLOSE (LOUT) ! instead STAT = 'OLD' ! instead OPEN (LOUT,FILE=FNAMO,FORM=FMT,STATUS=STAT) ! instead DO 1115 I = 1, 1000 READ (LOUT,8115,END=1120,ERR=1120) NBF(1:99) 8115 FORMAT (A) WRITE (6,9115) NBF(1:99) 9115 FORMAT (1X,A) 1115 CONTINUE 1120 CONTINUE WRITE (*,*) ' ' WRITE (*,*) ' PROCEED WITH ABOVE OPTIONS? (y/n)' WRITE (*,*) ' ' READ (*,7001) IPROC IF (IPROC.EQ.'Y') IPROC = 'y' IF (IPROC.EQ.'N') IPROC = 'n' IF (IPROC.NE.'y'.AND.IPROC.NE.'n') GO TO 1120 IF (IPROC.EQ.'n') THEN 1125 CONTINUE WRITE (*,*) ' ' WRITE (*,*) ' Options may be reset, but it means going through', W ' all of them again.' WRITE (*,*) ' Reset or quit? (r/q)' WRITE (*,*) ' ' READ (*,7001) IQR IF (IQR.EQ.'R') IQR = 'r' IF (IQR.EQ.'Q') IQR = 'q' IF (IQR.NE.'r'.AND.IQR.NE.'q') GO TO 1125 IF (IQR.EQ.'n') GO TO 991 C REWIND (LOUT) CLOSE (LOUT) ! instead STAT = 'NEW' ! instead OPEN (LOUT,FILE=FNAMO,FORM=FMT,STATUS=STAT) ! instead GO TO 1001 ENDIF C IF (idump.EQ.0) THEN IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9922) 9922 FORMAT (/,1X,'---------------------------------------', F '---------------------------------------', F //,1X,'Detailed information about the data may', F ' be found in the NMC Office Note 29 ', F /,1X,'(ON29) document: ', F ' ', F //,1X,' http://dss.ucar.edu/datasets/common', F '/nmc.adp/format_on29_01mar ', F //,1X,'The quality mark tables apply as follow', F 's: ', F /,1X,' Labeled Parameter Mark Table', F /,1X,' P pressure Q.B ', F /,1X,' Z geopotential Q.A ', F /,1X,' T temperature Q.A ', F /,1X,' H dewpoint Q.C ', F /,1X,' W winds Q.A ', F /,1X,' C cloud cover Q.7 (ra', F 'rely available) ', F /,1X,' (category 06) Q.6 & Q.6C', F //,1X,'Here is a "ruler" to help identify colu', F 'mn numbers in this printout which may ', F /,1X,'help you design code to parse this outp', F 'ut for other purposes. ', F //,1X,' 1 2 3 ', F '4 5 6 7 ', F '8 9', F /,1X,'123456789012345678901234567890123456789', F '0123456789012345678901234567890123456789', F '01234567890'//) ENDIF ENDIF C 1900 CONTINUE ICCNT = 0 KCCNT = 0 c c c c c c c c c c c c c c c C C 2000 CONTINUE C C CLEAR THE ARRAYS (ACTUALLY SET TO MISSING) C DO 5 JAX = 1, MX P(JAX) = PMSG Z(JAX) = ZMSG T(JAX) = TMSG H(JAX) = HMSG D(JAX) = DMSG F(JAX) = FMSG C(JAX) = CMSG QSHO(JAX) = ' ' D08(JAX) = ' ' A08(JAX) = ' ' M08(JAX) = ' ' IC08(JAX) = 999 5 CONTINUE C C *** READ A REPORT C C *** RDADP WILL SELECT ON DATA TYPE (USING NAMES ALREADY INPUT BY USER) C TIME08 = 99.99 CALL RDADP (IUN,IST,IREC,IREP) C IF (IST.EQ.1) GO TO 990 ! we are not working with tapes anymore C IF (IST.EQ.3) GO TO 991 ! we are not working with tapes anymore IF (IST.EQ.1.OR.IST.EQ.3) GO TO 991 IREP = IREP + 1 c if (idump.ne.0) then c IST = 3 c GO TO 991 c ENDIF if (idump.ne.0.and.irep.le.ireplim) then WRITE (LOUT,9005) IREC, IREP, NU, NA, LTHR, IYR 9005 FORMAT (1X,'ADP73: AFTER RDADP irec, irep, nu, na, lthr, iyr', F I3,4I10,I10) ENDIF IFILE = 0 C C AS RETURNED BY RDADP C THE ON29 HEADER (SYNOPTIC) TIME, IHR, IS IN HUNDREDTHS OF AN HOUR C THE REPORT TIME, TIME, IS HR.HH C C TO ANTICIPATE THE REPORT SELECTION PROCESS AND PRINTOUTS, WE NEED C TO DEFINE C IDATE SYNOPTIC DATE/TIME C MDATE REPORT DATE/TIME BASED ON THE SYNOPTIC DATE/TIME, C ADJUSTED IF PREFERRED C C DEFINE IDATE C ICC = 19 IF (IYR.LT.70) ICC = 20 IYEAR = 100*ICC + IYR IYRMO = 100*IYEAR + IMO C C JHR = IHR / 100 C C IDATE EXPECTS JHR IN WHOLE HOURS C IDATE = 10000*IYRMO + IDY*100 + JHR ! SYNOPTIC DATE/TIME if (idump.ne.0.and.irep.le.ireplim) then WRITE (LOUT,6665) IDATE, IYR, IMO, IDY, IHR, TIME 6665 FORMAT (/1X,'idate, iyr, imo, idy, ihr, time', F I16,3I3,I5,F6.2) ENDIF C C DEFINE PREFERRED MDATE C IF (IADJ.eq.'y') THEN C C REPORT TIMES AT 00Z OFTEN DO NOT MATCH THE SYNOPTIC TIME, AND MAY ALSO C CORRESPOND TO THE PREVIOUS OR FOLLOWING DATE, RELATIVE TO THE C SYNOPTIC TIME. EXAMPLES (ALL UTC, ALSO KNOWN AS Z): C C SYNOPTIC REPORT ACTUAL REPORT C DATE/TIME TIME DATE/TIME C (YYMMDDHHHH) HH.HH (YYMMDDHH.HH) C 0003010000 23.03 00022923.03 C 0012311800 02.04 01010102.04 C CALL DADJUST (IYR,IMO,IDY,IHR,TIME,MYR,MMO,MDY,NHR) C MHR = NHR / 100 MHR = TIME ELSE MYR = IYR MMO = IMO MDY = IDY MHR = IHR / 100 ENDIF C IF (MYR.GT.70) THEN MCC = 19 AYR = '19 ' ELSE MCC = 20 AYR = '20 ' ENDIF IF (MYR.GT.9) THEN WRITE (AYR(3:4),9006) MYR ELSE AYR(3:3) = '0' WRITE (AYR(4:4),9007) MYR ENDIF MYEAR = 100*MCC + MYR MYRMO = 100*MYEAR + MMO C C MDATE EXPECTS MHR IN WHOLE HOURS C MDATE = 10000*MYRMO + MDY*100 + MHR C if (idump.ne.0.and.irep.le.ireplim) then WRITE (LOUT,6666) MDATE, MYR, MMO, MDY, MHR, TIME 6666 FORMAT (1X,'mdate, myr, mmo, mdy, mhr, time', F I16,3I3,I5,F6.2) ENDIF C C THE L-DATES ARE USED FOR DEFINING AND DUMPING DATSHO AND NOTHING ELSE C IF (IPSEL.EQ.'h') then LHR = JHR LDY = IDY LMO = IMO LYEAR = IYEAR ELSE LHR = MHR LDY = MDY LMO = MMO LYEAR = MYEAR ENDIF C IF (LDY.GE.10) THEN WRITE (DYSHO(1:2),9006) LDY 9006 FORMAT (I2) ELSE DYSHO(1:1) = '0' WRITE (DYSHO(2:2),9007) LDY 9007 FORMAT (I1) ENDIF IF (LHR.GE.10) THEN WRITE (HRSHO(1:2),9006) LHR ! SYNOPTIC HOUR, NOT OBSERVATION TIME ELSE HRSHO(1:1) = '0' WRITE (HRSHO(2:2),9007) LHR ! SYNOPTIC HOUR, NOT OBSERVATION TIME ENDIF WRITE (IDATSHO(1:16),9009) LYEAR, MON(LMO), DYSHO, HRSHO 9009 FORMAT (I4,A3,A2,'.',A2,' ') if (idump.ne.0.and.irep.le.ireplim) then write (lout,9008) idatsho(1:12), idstyp(1:6), asta(1:6), w xlon, xlat, alonw, alone, alats, alatn 9008 FORMAT (1X,'ADP73: IDATSHO, IDSTYP, ASTA', F ' XLON, XLAT, ALONW, ALONE, ALATS, ALATN ', F A,1X,A,1X,A,2f6.1,4f7.2) endif C C ***** SELECT ON DATE (USING NUMBERS ALREADY INPUT BY USER) C ITOSS = 1 IF (IPERBEG(1).NE.1) THEN KDATE = IDATE ! USE SYNOPTIC DATE IF (IPSEL.EQ.'i') KDATE = MDATE ! USE PREFERRED REPORT DATE DO 10 II = 1, KPER C C IPERB = MOD(IPERBEG(II),100000000) C IPERE = MOD(IPEREND(II),100000000) C 1999123123 C IF (IPEREND(II).NE.9) THEN IF (KDATE.GE.(IPERBEG(II)).AND. I KDATE.LE.(IPEREND(II))) GO TO 12 ENDIF 10 CONTINUE IF (IRISK.EQ.'y') THEN IF (KDATE.GT.IPEREND(KPER)) GO TO 991 ENDIF GO TO 2000 ENDIF 12 CONTINUE LONK = (10 * (XLON+0.05)) + 1 ! ALLOW FOR WRAPAROUND LATK = (10 * (XLAT+0.05)) + 901 ! ALLOW FOR EQUATOR IF (LONK.LT.1.OR.LONK.GT.3601) GO TO 2000 IF (LATK.LT.1.OR.LONK.GT.1801) GO TO 2000 C C BAD LONK AND/OR LATK VALUES CAN BLOW THE LOCK, LOCI AND LOCT TABLES BELOW C C ***** SELECT GEOGRAPHIC AREA (USING NUMBERS ALREADY INPUT BY USER) C IF (GLOBE(1:1).EQ.'l') THEN IF (XLAT.LT.ALATS.OR.XLAT.GT.ALATN) GO TO 2000 IF (ALONW.LT.ALONE) THEN IF (XLON.GT.ALONW.AND.XLON.LT.ALONE) GO TO 2000 <---<< ELSE IF (XLON.LT.ALONE. OR.XLON.GT.ALONW) GO TO 2000 <---<< ENDIF ENDIF IF (GLOBE(1:1).EQ.'r') THEN CALL LLDIST (XLAT,XLON,YLAT,YLON,DIST) IF (DIST.GT.XRADIUS) GO TO 2000 ENDIF C IF (STNSEL(1:1).EQ.'a') GO TO 20 <---<< C C ***** SELECT ON STATION (USING BLOCKS OR NUMBERS ALREADY INPUT BY USER) C IF (STNSEL(1:1).EQ.'b') THEN <---<< DO 16 ISIT = 1, KW <---<< IF (SELWMO(ISIT)(1:1).EQ.'q') GO TO 2000 ! END OF LIST <---<< IF (SELWMO(ISIT)(3:6).NE.' ') THEN <---<< C <---<< C HERE WE ARE SELECTING ENTIRE WMO BLOCKS OF STATIONS <---<< C <---<< IF (ASTA(1:2).EQ.SELWMO(ISIT)(1:2)) GO TO 20 <---<< ENDIF <---<< 16 CONTINUE <---<< GO TO 2000 ! NOT ONE WE WANT <---<< ENDIF <---<< C IF (STNSEL(1:1).EQ.'l') THEN <---<< DO 17 ISIT = 1, KW <---<< IF (SELWMO(ISIT)(1:1).EQ.'q') GO TO 2000 ! END OF LIST <---<< IF (SELWMO(ISIT)(3:6).NE.' ') THEN <---<< C <---<< C HERE WE ARE SELECTING SPECIFIC STATIONS <---<< C <---<< IF (ASTA(1:6).EQ.SELWMO(ISIT)(1:6)) GO TO 20 <---<< ENDIF <---<< 17 CONTINUE <---<< GO TO 2000 ! NOT ONE WE WANT <---<< ENDIF <---<< C IF (STNSEL(1:1).EQ.'e') THEN <---<< C <---<< C **** SELECT FROM ELEVATION RANGE (USING NUMBERS ALREADY INPUT) <---<< C <---<< IF (ELEV.GE.ELEVLIM(1).AND.ELEV.LE.ELEVLIM(2)) GO TO 20 <---<< GO TO 2000 ! NOT ONE WE WANT <---<< ENDIF <---<< 20 CONTINUE ! ACCEPTED <---<< C C **** WE HAVE A REPORT THAT WE WANT!! C C BUMP LOCATION/STATION COUNTER C LONK = (10 * (XLON+0.05)) + 1 ! ALLOW FOR WRAPAROUND LATK = (10 * (XLAT+0.05)) + 901 ! ALLOW FOR EQUATOR DO 21 LLK = 1, 5 IF ( LOCK(LLK,LATK,LONK).EQ.0) THEN LOCI(LLK,LATK,LONK)(1:6) = ASTA(1:6) LOCT(LLK,LATK,LONK) = IRTYP LOCK(LLK,LATK,LONK) = LOCK(LLK,LATK,LONK) + 1 GO TO 22 ELSE IF (LLK.LT.5) THEN IF (ASTA(1:6).EQ.LOCI(LLK,LATK,LONK)(1:6)) THEN LOCK(LLK,LATK,LONK) = LOCK(LLK,LATK,LONK) + 1 GO TO 22 ENDIF ELSE LOCI(LLK,LATK,LONK)(1:6) = 'OTHERS' ! LUMP TOGETHER 5 OR MORE LOCT(LLK,LATK,LONK) = 999 LOCK(LLK,LATK,LONK) = LOCK(LLK,LATK,LONK) + 1 ENDIF ENDIF 21 CONTINUE 22 CONTINUE IELEV = ELEV IF (IHTU.EQ.'f') THEN JELEV = (3.2808399 * IELEV) + 0.5 ELSE JELEV = IELEV ENDIF IF (ADU.EQ.'KM') THEN JDIST = DIST ELSE JDIST = (0.621371 * DIST) + 0.5 ! CONVERT TO MILES ENDIF IF (LONA.EQ.'E') XLON = 360.0 - XLON C C PRINT A HEADER FOR THE REPORT PRINTOUT C C <<< END OF CODE "PARALLEL" WITH readsfc2.f >>> C IHEAD = 0 ! DO NOT PRINT THE FOLLOWING HEADER FOR SINGLE LEVEL REPORTS C = 1 ! DO PRINT THE FOLLOWING HEADER FOR MULTI- LEVEL REPORTS C IF (IDSTYP(1:6).EQ.'ADPUPA') IHEAD = 1 IF (IDSTYP(1:6).EQ.'AIRCFT') IHEAD = 0 IF (IDSTYP(1:6).EQ.'SIRSOB') IHEAD = 1 IF (IDSTYP(1:6).EQ.'SATWND') IHEAD = 0 IF (IDSTYP(1:6).EQ.'AIRCAR') IHEAD = 0 IF (IHEAD.EQ.1) THEN C C PRIOR TO 1992JAN22.12, INSTYP FROM TABLE R.2.A C THEN FROM TABLE R.2.B C IITAB = 'B' IF (IDATE.LT.1992012212) IITAB = 'A' IREPP = IREPP + 1 IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9021) IREPP, IREC, NU, LOGREC, LTHR, W IITAB, DATETAG, LONA, ADU, AHTU 9021 FORMAT (/,1X,9('##########'),'##', F //,1X,'REPORT PRINT',I7,', WHICH CAME FROM RECORD', F I6,', STARTING BYTE',I5,' OF ',I5,', LENGTH',I5, F /,63X,'CODE TABLES', F /,63X,'R.1 R.2.',A, F /,8X,' SOUNDING ', F ' DIST- PLATFORM INSTRU- RADIATION', F /,1X,A,' RELEASE REPORT LAT LON ', F ' ANCE ELEV /ID MENT CORRECTION', F /,1X,'DATE/TIME TIME TIME STATION (', F A,') ',' (',A,') (',A,') TYPE TYPE', F ' ALREADY DONE') ENDIF C NP = 0 ! RESET THE COUNTER FOR CATEGORY 06 HEADER PRINTS C ARC = ' NO ' IF (IRC.NE.0) ARC = 'YES, WMO 3849' IF (IDASH.EQ.'y') THEN IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9022) W IDATSHO(1:12), TIME08, TIME, W ASTA(1:6), XLAT, XLON, JDIST, JELEV, W IRTYP, INSTYP, ARC 9022 FORMAT ( 1X,9('----------'),'--', F /,1X,A,2F6.2,2X,A6,2F7.2,I6,I7,I5,I8,2X,A, F /,1X,9('=========='),'==') C C yyyymmmdd.hh hh.hh nnnnnb lll.ll lll.l C l eeee tt ii C ENDIF ELSE IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9023) W IDATSHO(1:12), TIME08, TIME, W ASTA(1:6), XLAT, XLON, JDIST, JELEV, W IRTYP, INSTYP, ARC 9023 FORMAT ( 1X,A,2F6.2,2X,A6,2F7.2,I6,I7,I5,I8,2X,A) ENDIF ENDIF ENDIF 9028 FORMAT (/7X,7('=========='),'=========') ! SEPARATE SECTIONS OF A REPORT 9029 FORMAT (10X,5('----------'),'----+-+--+',2('--------')) ! TABLE DIVIDER C CEVEL (MB) ( M) (C) (C) DIR SPD(MPS) PZTHWC C-----------------------------------------------------+-+--+---------------- C2345678901234567890123456789012345678901234567890123456789012345678901234567890 ISECLIN = 0 C XSFC = 0. YSFC = 0. ZSFC = 0. PSFC = 0. TSFC = 0. C 30 CONTINUE ANST = ' ' ANSB = ' ' C IF (IDSTYP(1:6).EQ.'ADPUPA'.OR.IDSTYP(1:6).EQ.'SIRSOB') THEN IF (ISTACK.EQ.'y') THEN C C ******* HERE TO COMBINE ALL CATEGORIES WHICH CONTAIN PRESSURE VALUES C INTO A SINGLE SORTED STACK C IF (idump.NE.0) THEN WRITE (LOUT,9031) IREC,IREP, NU, NA, LTHR, IYR, NLV,MLIM 9031 FORMAT (1X,'BEFORE STKADP irec,irep, nu, na, lthr, iyr', F ', nlv,mlim',5I10,I10,2I4) ENDIF C CALL STKADP (IREC,IREP,1,NLV,MLIM,XSFC,TSFC) CALL STKADP (IREC,IREP,1,NLV,MLIM,PSFC,TSFC,JTPP,JWPP,JWZZ) NLVU = NLV IF (NLV.GT.MX) NLV = MX ! WITH MLIM = MX, SHOULDN'T OCCUR C C NLV NUMBER OF MERGED PRESSURE LEVELS (PRESSURE STACK) C JTPP STKADP PACKED NUMBER OF SIGNIFICANT LEVEL TEMPERATURE BY PRESSURE C JWPP STKADP PACKED NUMBER OF SIGNIFICANT LEVEL WIND BY PRESSURE C JWZZ WZZADP PACKED NUMBER OF VARIABLE LEVEL WIND BY HEIGHT C C THE STACKER MAY MERGE SIGNIFICANT PRESSURE LEVELS, SO THAT THE C FINAL COUNT <= JTPP + JWPP C IF (idump.NE.0) THEN WRITE (LOUT,9032) IREC,IREP, NU, NA, LTHR, IYR, NLV,MLIM 9032 FORMAT (1X,'AFTER STKADP irec,irep, nu, na, lthr, iyr', F ', nlv,mlim',5I10,I10,2I4) ENDIF IF (NLV.LT.1) GO TO 2000 IF (ISECLIN.NE.0) THEN IF (IDASH.EQ.'y') THEN IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9028) ENDIF ENDIF ELSE ISECLIN = 1 ENDIF IRP = 2 ARP = 'PIBAL ' C IF (ISORT.EQ.'d') THEN IBEG = 1 IEND = NLV ISTEP = 1 ELSE IBEG = NLV IEND = 1 ISTEP = -1 ENDIF DO 32 I = IBEG, IEND, ISTEP C C DETERMINE WHETHER ITS A RADIOSONDE(1) OR A PIBAL(2) C C IF (T(I).NE.TMSG) THEN C WE FOUND SOME TEMPERATURE DATA, SO ITS A RADIOSONDE C C WE CHANGED THE CRITERIA TO BE CONSISTENT WITH OUR NEW C SUPER INVENTORY C IF (P(I).GT.0.0.AND.P(I).LT.9000.0) THEN IF (T(I).NE.TMSG.OR.Z(I).NE.ZMSG) THEN C C WE FOUND SOME NON-WIND DATA, SO ITS A RADIOSONDE C IRP = 1 ARP = 'RADIOSONDE' GO TO 33 ENDIF ENDIF 32 CONTINUE 33 CONTINUE IF (IDSTYP(1:6).EQ.'SIRSOB') THEN ARP = 'SIRSOB ' ENDIF IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9033) ARP, NLV 9033 FORMAT (/,7X,'STACKED DATA - ',A, F /,1X,I8,' LEVELS (ALL CATEGORIES WITH PRESSURE)') WRITE (LOUT,9034) ADEW, AHTU, ATEMPU, ATEMPU, AWINDU 9034 FORMAT ( 10X,' ', F ' QUALITY MARKS', F /,10X,' PRESSURE HEIGHT TEMP ',A,' ', F '- WIND ----- (TABLES Q.A,Q.B,Q.C)', F /,10X,'LEVEL (MB) (',A,') (',A,') (', F A,') DIR SPD(',A,') PZTHWC') C IF (IDASH.EQ.'y') THEN WRITE (LOUT,9029) ENDIF ENDIF DO 40 I = IBEG, IEND, ISTEP C C 2001OCT22 - TURNED OFF BECAUSE THE SUBSTITUTION CAUSED C PROBLEMS IN OUR SUPER INVENTORY WORK, AND WE WANT TO BE C CONSISTENT WITH THE INVENTORY HANDLING. THIS HAS THE C EFFECT OF LEAVING THE SURFACE LEVEL UNIDENTIFIED AND/OR C THE SURFACE LEVEL ELEVATION VALUE LEFT MISSING. C C IF (XSFC.NE.PMSG) THEN C IF (P(I).EQ.XSFC) THEN C IF (Z(I).EQ.ZMSG) THEN C Z(I) = ELEV ! WHEN HEIGHT MISSING IN SURFACE LEVEL, C ! USE THE STATION ELEVATION C ENDIF C ENDIF C ENDIF C IZZ = Z(I) IF (IHTU.EQ.'f') THEN IF (Z(I).NE.ZMSG) THEN IF (P(I).NE.PMSG) THEN IZZ = (3.2808399 * Z(I)) + 0.5 ELSE C C ADJUST HEIGHT IN DATA (JUST WINDS?) BY HEIGHT DATA, C SO THAT THE VALUES IN FEET REPRODUCE TO THE NEAREST C HUNDRED. MAY HAVE C BEEN NECESSITATED BY TRUNCATION AT NCEP... C IZZ = (3.2808399 * (Z(I)+0.5)) IF (MOD(IZZ,100).GE.95) THEN JZZ = 100 * ((IZZ/100) + 1) IZZ = JZZ ENDIF IF (MOD(IZZ,100).LE. 4) THEN JZZ = 100 * (IZZ/100) IZZ = JZZ ENDIF ENDIF ENDIF ENDIF IF (IDEW.EQ.'p') THEN TD = T(I) - H(I) IF (H(I).EQ.HMSG) TD = H(I) ELSE TD = H(I) ENDIF IF (ITEMPU.EQ.'f') THEN IF (T(I).NE.TMSG) T(I) = (1.8 * T(I)) + 32. IF ( TD.NE.HMSG) TD = (1.8 * TD) + 32. ENDIF IDD = D(I) IFF = F(I) IF (IWINDU.EQ.'m') THEN IF (F(I).NE.FMSG) THEN IFF = (0.514791 * F(I)) + 0.5 ENDIF ENDIF IF (P(I).EQ.XSFC) THEN IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9036) SURFACE, I, P(I), IZZ, T(I), TD, W IDD, IFF, QSHO(I) 9036 FORMAT (3X,A,I5,F8.1,I9,F8.1,F7.1,2I6,5X,A8) ENDIF GO TO 39 ENDIF IF (P(I).EQ.TSFC) THEN IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9037) TPAUSE, I, P(I), IZZ, T(I), TD, W IDD, IFF, QSHO(I) 9037 FORMAT (1X,A,I4,F8.1,I9,F8.1,F7.1,2I6,5X,A8) ENDIF GO TO 39 ENDIF IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9035) I, P(I), IZZ, T(I), TD, IDD, IFF, W QSHO(I) 9035 FORMAT (10X,I5,F8.1,I9,F8.1,F7.1,2I6,5X,A8) ENDIF 39 CONTINUE IF (IDASH.EQ.'y') THEN IDOIT = 0 IF (ISTEP.EQ.1) THEN IF (MOD(( I),5).EQ.0.AND.I.NE.NLV) IDOIT = 1 ELSE IF (MOD((I-1),5).EQ.0.AND.I.NE.NLV) IDOIT = 1 ENDIF IF (IDOIT.EQ.1) THEN IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9029) ENDIF ENDIF ENDIF 40 CONTINUE ELSE C C ******* HERE TO PROCESS ALL STACKABLE CATEGORIES SEPARATELY C C ******* MANDATORY LEVELS C IF (idump.NE.0) THEN WRITE (LOUT,9041) IREC, IREP, NU, NA, LTHR, IYR 9041 FORMAT (1X,'BEFORE MANADP irec, irep, nu, na, lthr, iyr', F 5I10,I10) ENDIF CALL MANADP (IREC,IREP,1,NLV,MLIM) IF (idump.NE.0) THEN WRITE (LOUT,9042) IREC, IREP, NU, NA, LTHR, IYR 9042 FORMAT (1X,'AFTER MANADP irec, irep, nu, na, lthr, iyr', F 5I10,I10) ENDIF C C please see http://dss.ucar.edu/datasets/common/nmc.adp/format_on29_96feb , C Appendix C, Category 01 for a description of these variables. C IF (NLV.GE.1) THEN IF (ISECLIN.NE.0) THEN IF (IDASH.EQ.'y') THEN IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9028) ENDIF ENDIF ELSE ISECLIN = 1 ENDIF IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9043) NLV 9043 FORMAT (/,7X,'MANDATORY LEVEL DATA', F /,1X,I8,' LEVELS (CATEGORY 01)') WRITE (LOUT,9034) ADEW, AHTU, ATEMPU, ATEMPU, AWINDU IF (IDASH.EQ.'y') THEN WRITE (LOUT,9029) ENDIF ENDIF IF (ISORT.EQ.'d') THEN IBEG = 1 IEND = NLV ISTEP = 1 ELSE IBEG = NLV IEND = 1 ISTEP = -1 ENDIF DO 50 I = IBEG, IEND, ISTEP IZZ = Z(I) IF (IHTU.EQ.'f') THEN IF (Z(I).NE.ZMSG) THEN IZZ = (3.2808399 * Z(I)) + 0.5 ENDIF ENDIF IF (IDEW.EQ.'p') THEN TD = T(I) - H(I) IF (H(I).EQ.HMSG) TD = H(I) ELSE TD = H(I) ENDIF IF (ITEMPU.EQ.'f') THEN IF (T(I).NE.TMSG) T(I) = (1.8 * T(I)) + 32. IF ( TD.NE.HMSG) TD = (1.8 * TD) + 32. ENDIF IDD = D(I) IFF = F(I) IF (IWINDU.EQ.'m') THEN IF (F(I).NE.FMSG) THEN IFF = (0.514791 * F(I)) + 0.5 ENDIF ENDIF IF (P(I).EQ.XSFC) THEN IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9036) SURFACE, I, P(I), IZZ, T(I), TD, W IDD, IFF, QSHO(I) ENDIF GO TO 49 ENDIF IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9035) I, P(I), IZZ, T(I), TD, IDD, IFF, W QSHO(I) ENDIF 49 CONTINUE IF (IDASH.EQ.'y') THEN IDOIT = 0 IF (ISTEP.EQ.1) THEN IF (MOD(( I),5).EQ.0.AND.I.NE.NLV) IDOIT = 1 ELSE IF (MOD((I-1),5).EQ.0.AND.I.NE.NLV) IDOIT = 1 ENDIF IF (IDOIT.EQ.1) THEN IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9029) ENDIF ENDIF ENDIF 50 CONTINUE ENDIF C C ******* SIGNIFICANT LEVELS C IF (idump.NE.0) THEN WRITE (LOUT,9031) IREC, IREP, NU, NA, LTHR, IYR 9051 FORMAT (1X,'BEFORE SIGADP irec, irep, nu, na, lthr, iyr', F 5I10,I10) ENDIF CALL SIGADP (IREC,IREP,1,NLV,MLIM,XSFC) IF (idump.NE.0) THEN WRITE (LOUT,9052) IREC, IREP, NU, NA, LTHR, IYR 9052 FORMAT (1X,'AFTER SIGADP irec, irep, nu, na, lthr, iyr', F 5I10,I10) ENDIF C C please see http://dss.ucar.edu/datasets/common/nmc.adp/format_on29_96feb , C Appendix C, Category 02 for a description of these variables. C IF (NLV.GE.1) THEN IF (ISECLIN.NE.0) THEN IF (IDASH.EQ.'y') THEN IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9028) ENDIF ENDIF ELSE ISECLIN = 1 ENDIF IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9053) NLV 9053 FORMAT (/,7X,'SIGNIFICANT LEVEL DATA', F /,1X,I8,' LEVELS (CATEGORY 02)') WRITE (LOUT,9054) ADEW, ATEMPU, ATEMPU 9054 FORMAT ( 10X,' ', F ' QUALITY MARKS', F /,10X,' PRESSURE TEMP ',A,' ', F ' (TABLES Q.A,Q.B,Q.C)', F /,10X,'LEVEL (MB) (',A,') (', F A,') PZTHWC') IF (IDASH.EQ.'y') THEN WRITE (LOUT,9029) ENDIF ENDIF IF (ISORT.EQ.'d') THEN IBEG = 1 IEND = NLV ISTEP = 1 ELSE IBEG = NLV IEND = 1 ISTEP = -1 ENDIF DO 60 I = IBEG, IEND, ISTEP IF (IDEW.EQ.'p') THEN TD = T(I) - H(I) IF (H(I).EQ.HMSG) TD = H(I) ELSE TD = H(I) ENDIF IF (ITEMPU.EQ.'f') THEN IF (T(I).NE.TMSG) T(I) = (1.8 * T(I)) + 32 IF ( TD.NE.HMSG) TD = (1.8 * TD) + 32 ENDIF IF (P(I).EQ.XSFC) THEN IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9056) SURFACE, I, P(I), T(I), TD, QSHO(I) 9056 FORMAT (3X,A,I5,F8.1,9X,F8.1,F7.1,2(6X),5X,A8) ENDIF GO TO 59 ENDIF IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9055) I, P(I), T(I), TD, QSHO(I) 9055 FORMAT (10X,I5,F8.1,9X,F8.1,F7.1,2(6X),5X,A8) ENDIF 59 CONTINUE IF (IDASH.EQ.'y') THEN IDOIT = 0 IF (ISTEP.EQ.1) THEN IF (MOD(( I),5).EQ.0.AND.I.NE.NLV) IDOIT = 1 ELSE IF (MOD((I-1),5).EQ.0.AND.I.NE.NLV) IDOIT = 1 ENDIF IF (IDOIT.EQ.1) THEN IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9029) ENDIF ENDIF ENDIF 60 CONTINUE ENDIF C C ***** ADDITIONAL DATA (925MB IF AVAILABLE) C C PLEASE SEE THE COMMENTS IN THE ADDADP SUBROUTINE C C please see http://dss.ucar.edu/datasets/common/nmc.adp/format_on29_96feb , C Appendix C, Category 08 for a description of other variables. C CALL ADDADP (IREC,IREP,1,NLV08,MLIM) IF (NLV08.GE.1) THEN IF (ISECLIN.NE.0) THEN IF (IDASH.EQ.'y') THEN IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9028) ENDIF ENDIF ELSE ISECLIN = 1 ENDIF DO 925 I = 1, NLV08 IF (IC08(I).EQ.925) THEN C C WE PRODUCE THE REMAINDER OF THE ADDITIONAL DATA BELOW C READ (D08(I),9927,ERR=928) IZZ 9927 FORMAT (I5) IF (IHTU.EQ.'f') THEN IZZ = (3.2808399 * Z(I)) + 0.5 ENDIF IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9925) 9925 FORMAT (/,7X,'ADDITIONAL DATA (925MB FROM', F ' CATEGORY 08)') WRITE (LOUT,9926) AHTU 9926 FORMAT (/,10X,' PRESSURE HEIGHT', F /,10X,' (MB) (',A,')') IF (IDASH.EQ.'y') THEN WRITE (LOUT,9029) ENDIF WRITE (LOUT,9928) IZZ 9928 FORMAT (18X,'925.0',4X,I5) ENDIF GO TO 928 ENDIF 925 CONTINUE 928 CONTINUE ENDIF C C *** TROPOPAUSE C IF (idump.NE.0) THEN WRITE (LOUT,9061) IREC, IREP, NU, NA, LTHR, IYR 9061 FORMAT (1X,'BEFORE TRPADP irec, irep, nu, na, lthr, iyr', F 5I10,I10) ENDIF CALL TRPADP (IREC,IREP,1,NLV,MLIM,TSFC) IF (idump.NE.0) THEN WRITE (LOUT,9062) IREC, IREP, NU, NA, LTHR, IYR 9062 FORMAT (1X,'AFTER TRPADP irec, irep, nu, na, lthr, iyr', F 5I10,I10) ENDIF C C please see http://dss.ucar.edu/datasets/common/nmc.adp/format_on29_96feb , C Appendix C, Category 05 for a description of these variables. C IF (NLV.GE.1) THEN IF (ISECLIN.NE.0) THEN IF (IDASH.EQ.'y') THEN IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9028) ENDIF ENDIF ELSE ISECLIN = 1 ENDIF IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9063) NLV 9063 FORMAT (/,7X,'TROPOPAUSE', F /,1X,I8,' LEVELS (CATEGORY 05)') WRITE (LOUT,9064) ADEW, ATEMPU, ATEMPU, AWINDU 9064 FORMAT ( 10X,' ', F ' QUALITY MARKS', F /,10X,' PRESSURE TEMP ',A,' ', F '- WIND ----- (TABLES Q.A,Q.B,Q.C)', F /,10X,'LEVEL (MB) (',A,') (', F A,') DIR SPD(',A,') PZTHWC') IF (IDASH.EQ.'y') THEN WRITE (LOUT,9029) ENDIF ENDIF IF (ISORT.EQ.'d') THEN IBEG = 1 IEND = NLV ISTEP = 1 ELSE IBEG = NLV IEND = 1 ISTEP = -1 ENDIF DO 70 I = IBEG, IEND, ISTEP IF (IDEW.EQ.'p') THEN TD = T(I) - H(I) IF (H(I).EQ.HMSG) TD = H(I) ELSE TD = H(I) ENDIF IF (ITEMPU.EQ.'f') THEN IF (T(I).NE.TMSG) T(I) = (1.8 * T(I)) + 32. IF ( TD.NE.HMSG) TD = (1.8 * TD) + 32. ENDIF IDD = D(I) IFF = F(I) IF (IWINDU.EQ.'m') THEN IF (F(I).NE.FMSG) THEN IFF = (0.514791 * F(I)) + 0.5 ENDIF ENDIF IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9065) I, P(I), T(I), TD, IDD, IFF, QSHO(I) 9065 FORMAT (10X,I5,F8.1,9X,F8.1,F7.1,2I6,5X,A8) ENDIF IF (IDASH.EQ.'y') THEN IDOIT = 0 IF (ISTEP.EQ.1) THEN IF (MOD(( I),5).EQ.0.AND.I.NE.NLV) IDOIT = 1 ELSE IF (MOD((I-1),5).EQ.0.AND.I.NE.NLV) IDOIT = 1 ENDIF IF (IDOIT.EQ.1) THEN IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9029) ENDIF ENDIF ENDIF 70 CONTINUE ENDIF C C *** WIND BY PRESSURE C IF (idump.NE.0) THEN WRITE (LOUT,9081) IREC, IREP, NU, NA, LTHR, IYR 9081 FORMAT (1X,'BEFORE WPPADP irec, irep, nu, na, lthr, iyr', F 5I10,I10) ENDIF CALL WPPADP (IREC,IREP,1,NLV,MLIM,XSFC) C CALL WPPADP (IREC,IREP,1,NLV,MLIM,PSFC) IF (idump.NE.0) THEN WRITE (LOUT,9082) IREC, IREP, NU, NA, LTHR, IYR 9082 FORMAT (1X,'AFTER WPPADP irec, irep, nu, na, lthr, iyr', F 5I10,I10) ENDIF C C please see http://dss.ucar.edu/datasets/common/nmc.adp/format_on29_96feb , C Appendix C, Category 03 for a description of these variables. C IF (NLV.GE.1) THEN IF (ISECLIN.NE.0) THEN IF (IDASH.EQ.'y') THEN IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9028) ENDIF ENDIF ELSE ISECLIN = 1 ENDIF IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9083) NLV 9083 FORMAT (/,7X,'WIND BY PRESSURE', F /,1X,I8,' LEVELS (CATEGORY 03)') WRITE (LOUT,9084) AWINDU 9084 FORMAT ( 10X,' ', F ' QUALITY MARKS', F /,10X,' PRESSURE ', F ' - WIND ----- (TABLES Q.A,Q.B)', F /,10X,'LEVEL (MB) ', F ' DIR SPD(',A,') PZTHWC') IF (IDASH.EQ.'y') THEN WRITE (LOUT,9029) ENDIF ENDIF IF (ISORT.EQ.'d') THEN IBEG = 1 IEND = NLV ISTEP = 1 ELSE IBEG = NLV IEND = 1 ISTEP = -1 ENDIF DO 90 I = IBEG, IEND, ISTEP IDD = D(I) IFF = F(I) IF (IWINDU.EQ.'m') THEN IF (F(I).NE.FMSG) THEN IFF = (0.514791 * F(I)) + 0.5 ENDIF ENDIF IF (P(I).EQ.XSFC) THEN IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9086) SURFACE, I, P(I), IDD, IFF, QSHO(I) 9086 FORMAT (3X,A,I5,F8.1,9X,8X,7X,2I6,5X,A8) ENDIF GO TO 89 ENDIF IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9085) I, P(I), IDD, IFF, QSHO(I) 9085 FORMAT (10X,I5,F8.1,9X,8X,7X,2I6,5X,A8) ENDIF 89 CONTINUE IF (IDASH.EQ.'y') THEN IDOIT = 0 IF (ISTEP.EQ.1) THEN IF (MOD(( I),5).EQ.0.AND.I.NE.NLV) IDOIT = 1 ELSE IF (MOD((I-1),5).EQ.0.AND.I.NE.NLV) IDOIT = 1 ENDIF IF (IDOIT.EQ.1) THEN IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9029) ENDIF ENDIF ENDIF 90 CONTINUE ENDIF ENDIF C C *** WIND BY HEIGHT C IF (idump.NE.0) THEN WRITE (LOUT,9091) IREC, IREP, NU, NA, LTHR, IYR 9091 FORMAT (1X,'BEFORE WZZADP irec, irep, nu, na, lthr, iyr', F 5I10,I10) ENDIF CALL WZZADP (IREC,IREP,1,NLV,MLIM,YSFC,1) C CALL WZZADP (IREC,IREP,1,NLV,MLIM,ZSFC,1) IF (idump.NE.0) THEN WRITE (LOUT,9092) IREC, IREP, NU, NA, LTHR, IYR 9092 FORMAT (1X,'AFTER WZZADP irec, irep, nu, na, lthr, iyr', F 5I10,I10) ENDIF C C please see http://dss.ucar.edu/datasets/common/nmc.adp/format_on29_96feb , C Appendix C, Category 04 for a description of these variables. C IF (NLV.GE.1) THEN IF (ISECLIN.NE.0) THEN IF (IDASH.EQ.'y') THEN IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9028) ENDIF ENDIF ELSE ISECLIN = 1 ENDIF IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9093) NLV 9093 FORMAT (/,7X,'WIND BY HEIGHT (HEIGHT IS ABOVE MEAN SEA LE', F 'VEL)', F /,1X,I8,' LEVELS (CATEGORY 04)') WRITE (LOUT,9094) AHTU, AWINDU 9094 FORMAT ( 10X,' ', F ' QUALITY MARKS', F /,10X,' HEIGHT ', F '- WIND ----- (TABLES Q.A,Q.B)', F /,10X,'LEVEL (',A,') ', F ' DIR SPD(',A,') PZTHWC') IF (IDASH.EQ.'y') THEN WRITE (LOUT,9029) ENDIF ENDIF IF (ISORT.EQ.'d') THEN IBEG = 1 IEND = NLV ISTEP = 1 ELSE IBEG = NLV IEND = 1 ISTEP = -1 ENDIF DO 100 I = IBEG, IEND, ISTEP IZZ = Z(I) IF (IHTU.EQ.'f') THEN IF (Z(I).NE.ZMSG) THEN C C ADJUST HEIGHT IN WIND BY HEIGHT DATA, C SO THAT THE VALUES IN FEET REPRODUCE TO THE NEAREST C HUNDRED, EXCEPT AT THE SURFACE. MAY HAVE C BEEN NECESSITATED BY TRUNCATION AT NCEP... C IZZ = (3.2808399 * (Z(I)+0.5)) IF (IZZ.LT.30000) THEN IF (MOD(IZZ,100).GT.96) THEN JZZ = 100 * ((IZZ/100) + 1) IZZ = JZZ ENDIF IF (MOD(IZZ,100).LT. 4) THEN JZZ = 100 * (IZZ/100) IZZ = JZZ ENDIF ELSE C C TO THOUSANDS AT HIGHER LEVELS C IF (MOD(IZZ,1000).GT.960) THEN JZZ = 100 * ((IZZ/100) + 1) IZZ = JZZ ENDIF IF (MOD(IZZ,1000).LT. 40) THEN JZZ = 100 * (IZZ/100) IZZ = JZZ ENDIF ENDIF ENDIF ENDIF IDD = D(I) IFF = F(I) IF (IWINDU.EQ.'m') THEN IF (F(I).NE.FMSG) THEN IFF = (0.514791 * F(I)) + 0.5 ENDIF ENDIF IF (Z(I).EQ.YSFC) THEN IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9096) SURFACE, I, IZZ, IDD, IFF, QSHO(I) 9096 FORMAT (3X,A,I5,8X,I9,8X,7X,2I6,5X,A8) ENDIF GO TO 99 ENDIF IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9095) I, IZZ, IDD, IFF, QSHO(I) 9095 FORMAT (10X,I5,8X,I9,8X,7X,2I6,5X,A8) ENDIF 99 CONTINUE IF (IDASH.EQ.'y') THEN IDOIT = 0 IF (ISTEP.EQ.1) THEN IF (MOD(( I),5).EQ.0.AND.I.NE.NLV) IDOIT = 1 ELSE IF (MOD((I-1),5).EQ.0.AND.I.NE.NLV) IDOIT = 1 ENDIF IF (IDOIT.EQ.1) THEN IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9029) ENDIF ENDIF ENDIF 100 CONTINUE ENDIF C C *** CLOUD COVER (MAY BE LITTLE, IF ANY, OF THIS) C IF (idump.NE.0) THEN WRITE (LOUT,9101) IREC, IREP, NU, NA, LTHR, IYR 9101 FORMAT (1X,'BEFORE CLDADP irec, irep, nu, na, lthr, iyr', F 5I10,I10) ENDIF CALL CLDADP (IREC,IREP,1,NLV,MLIM) IF (idump.NE.0) THEN WRITE (LOUT,9102) IREC, IREP, NU, NA, LTHR, IYR 9102 FORMAT (1X,'AFTER CLDADP irec, irep, nu, na, lthr, iyr', F 5I10,I10) ENDIF C C please see http://dss.ucar.edu/datasets/common/nmc.adp/format_on29_96feb , C Appendix C, Category 07 for a description of these variables. C IF (NLV.GE.1) THEN IF (ISECLIN.NE.0) THEN IF (IDASH.EQ.'y') THEN IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9028) ENDIF ENDIF ELSE ISECLIN = 1 ENDIF IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9103) NLV 9103 FORMAT (/,7X,'CLOUD COVER', F /,1X,I8,' LEVELS (CATEGORY 07)') WRITE (LOUT,9104) 9104 FORMAT ( 10X,' ', F ' QUALITY MARKS', F /,10X,' PRESSURE ', F ' (TABLES Q.7) CLOUD', F /,10X,'LEVEL (MB) ', F ' PZTHWC COVER(%)') IF (IDASH.EQ.'y') THEN WRITE (LOUT,9029) ENDIF ENDIF IF (ISORT.EQ.'d') THEN IBEG = 1 IEND = NLV ISTEP = 1 ELSE IBEG = NLV IEND = 1 ISTEP = -1 ENDIF DO 110 I = IBEG, IEND, ISTEP IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9105) I, P(I), QSHO(I), C(I) 9105 FORMAT (10X,I5,F8.0,41X,A,8X,I3) ENDIF IF (IDASH.EQ.'y') THEN IDOIT = 0 IF (ISTEP.EQ.1) THEN IF (MOD(( I),5).EQ.0.AND.I.NE.NLV) IDOIT = 1 ELSE IF (MOD((I-1),5).EQ.0.AND.I.NE.NLV) IDOIT = 1 ENDIF IF (IDOIT.EQ.1) THEN IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9029) ENDIF ENDIF ENDIF 110 CONTINUE ENDIF C C *** ADDITIONAL DATA C C please see http://dss.ucar.edu/datasets/common/nmc.adp/format_on29_96feb , C Appendix C, Category 08 for a description of these variables. C IF (idump.NE.0) THEN WRITE (LOUT,9171) IREC, IREP, NU, NA, LTHR, IYR 9171 FORMAT (1X,'BEFORE ADDADP irec, irep, nu, na, lthr, iyr', F 5I10,I10) ENDIF C C ALREADY CALLED ABOVE C C CALL ADDADP (IREC,IREP,1,NLV08,MLIM) IF (ISTACK.EQ.'y'.AND.NLV08.EQ.1.AND.IC08(1).EQ.925) GO TO 189 IF (idump.NE.0) THEN WRITE (LOUT,9172) IREC, IREP, NU, NA, LTHR, IYR 9172 FORMAT (1X,'AFTER ADDADP irec, irep, nu, na, lthr, iyr', F 5I10,I10) ENDIF C C please see http://dss.ucar.edu/datasets/common/nmc.adp/format_on29_96feb , C Appendix C, Category 06 for a description of these variables. C IF (NLV08.GE.1) THEN IF (ISECLIN.NE.0) THEN IF (IDASH.EQ.'y') THEN IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9028) ENDIF ENDIF ELSE ISECLIN = 1 ENDIF NLVSHO = NLV08 DO 179 I = 1, NLV08 IF (IC08(I).EQ.925) NLVSHO = NLVSHO - 1 179 CONTINUE IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9173) NLVSHO 9173 FORMAT (/,7X,'ADDITIONAL DATA', F /,1X,I8,' LEVELS (CATEGORY 08)') WRITE (LOUT,9174) 9174 FORMAT ( 10X,' FORM DATA FORM ', F /,10X,'VALUE CODE APPLIES IND ', F /,10X,' (101) (Q.8) ') IF (IDASH.EQ.'y') THEN WRITE (LOUT,9029) ENDIF ENDIF DO 180 I = 1, NLV08 IF (ISTACK.EQ.'y'.AND.IC08(I).EQ.925) GO TO 180 C C WE PICK UP THIS 925MB HEIGHT UP ABOVE, SO C SKIP IT HERE C IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9175) D08(I), IC08(I), R A08(I), M08(I)(1:6) 9175 FORMAT (5X,'ADD ',A5,2X,I3,6X,A1,6X,A1) ENDIF IF (IDASH.EQ.'y') THEN IDOIT = 0 IF (ISTEP.EQ.1) THEN IF (MOD(( I),5).EQ.0.AND.I.NE.NLV) IDOIT = 1 ELSE IF (MOD((I-1),5).EQ.0.AND.I.NE.NLV) IDOIT = 1 ENDIF IF (IDOIT.EQ.1) THEN IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9029) ENDIF ENDIF ENDIF 180 CONTINUE ENDIF 189 CONTINUE ENDIF IF (IDSTYP(1:6).EQ.'AIRCFT') THEN C C ***** AIRCRAFT FLIGHT LEVEL REPORTS C C please see http://dss.ucar.edu/datasets/common/nmc.adp/format_on29_96feb , C Appendix C, Category 06 for a description of these variables. C IF (idump.NE.0) THEN WRITE (LOUT,9211) IREC, IREP, NU, NA, LTHR, IYR 9211 FORMAT (1X,'BEFORE AFTADP irec, irep, nu, na, lthr, iyr', F 5I10,I10) ENDIF CALL AFTADP (IREC,IREP,1,NLV,MLIM) IF (idump.NE.0) THEN WRITE (LOUT,9212) IREC, IREP, NU, NA, LTHR, IYR 9212 FORMAT (1X,'AFTER AFTADP irec, irep, nu, na, lthr, iyr', F 5I10,I10) ENDIF C C please see http://dss.ucar.edu/datasets/common/nmc.adp/format_on29_96feb , C Appendix C, Category 06 for a description of these variables. C AREP = 'REP' ANST = 'INS' ANSB = 'TYP ' AGENCY = ' ' ! ACTUALLY A SATELLITE CODE IF (NLV.GE.1) GO TO 600 ENDIF IF (IDSTYP(1:6).EQ.'SATWND') THEN C C ***** SATELLITE WIND REPORTS C C please see http://dss.ucar.edu/datasets/common/nmc.adp/format_on29_96feb , C Appendix C, Category 06 for a description of these variables. C IF (idump.NE.0) THEN WRITE (LOUT,9311) IREC, IREP, NU, NA, LTHR, IYR 9311 FORMAT (1X,'BEFORE STWADP irec, irep, nu, na, lthr, iyr', F 5I10,I10) ENDIF CALL STWADP (IREC,IREP,1,NLV,MLIM) IF (idump.NE.0) THEN WRITE (LOUT,9312) IREC, IREP, NU, NA, LTHR, IYR 9312 FORMAT (1X,'AFTER STWADP irec, irep, nu, na, lthr, iyr', F 5I10,I10) ENDIF C C please see http://dss.ucar.edu/datasets/common/nmc.adp/format_on29_96feb , C Appendix C, Category 06 for a description of these variables. C AREP = 'REP' IF (MDATE.LT.1993090200) THEN ANST = 'INS' ANSB = 'TYP ' ELSE ANST = 'WIN' ! EFFECTIVE 9/2/93 ANSB = 'METH' ! EFFECTIVE 9/2/93 ENDIF AGENCY = 'AG' ! SATELLITE AGENCY CODE (NOAA, JAPAN, ETC) IF (NLV.GE.1) GO TO 600 ENDIF IF (IDSTYP(1:6).EQ.'AIRCAR') THEN C C ***** AIRCRAFT TAKEOFF/LANDING REPORTS C C please see http://dss.ucar.edu/datasets/common/nmc.adp/format_on29_96feb , C Appendix C, Category 06 for a description of these variables. C IF (idump.NE.0) THEN WRITE (LOUT,9411) IREC, IREP, NU, NA, LTHR, IYR 9411 FORMAT (1X,'BEFORE CARADP irec, irep, nu, na, lthr, iyr', F 5I10,I10) ENDIF CALL CARADP (IREC,IREP,1,NLV,MLIM) IF (idump.NE.0) THEN WRITE (LOUT,9412) IREC, IREP, NU, NA, LTHR, IYR 9412 FORMAT (1X,'AFTER CARADP irec, irep, nu, na, lthr, iyr', F 5I10,I10) ENDIF C C please see http://dss.ucar.edu/datasets/common/nmc.adp/format_on29_96feb , C Appendix C, Category 06 for a description of these variables. C AREP = 'REP' ANST = 'INS' ANSB = 'TYP ' AGENCY = ' ' ! ACTUALLY A SATELLITE CODE IF (NLV.GE.1) GO TO 600 ENDIF GO TO 800 600 CONTINUE C C *** PRINT OUT CATEGORY 06 DATA FOR AIRCFT, AIRCAR AND SATWND DATA C IF (idump.NE.0) THEN WRITE (LOUT,9600) IREC, IREP 9600 FORMAT (/,1X,'HELLO, IREC, IREP',2i6) ENDIF IBEG = 1 IEND = NLV ISTEP = 1 DO 680 I = IBEG, IEND C C REPORTS WITH CATEGORY 06 DATA MAY ALWAYS HAVE JUST ONE C OF THESE (IEND = 1) C IZZ = Z(I) IF (IHTU.EQ.'f') THEN IF (Z(I).NE.ZMSG) THEN C C ADJUST PRESSURE ALTITUDE (BUT DO WE NEED TO DO THIS FOR SATWND?) C SO THAT THE VALUES IN FEET REPRODUCE TO THE NEAREST C THOUSAND. MAY HAVE C BEEN NECESSITATED BY TRUNCATION AT NCEP... C IZZ = (3.2808399 * (Z(I)+0.5)) IF (MOD(IZZ,1000).GE.500) THEN JZZ = 1000 * ((IZZ/100) + 1) IZZ = JZZ ENDIF IF (MOD(IZZ,1000).LT.500) THEN JZZ = 1000 * (IZZ/100) IZZ = JZZ ENDIF ENDIF ENDIF C IF (IDEW.EQ.'p') THEN TD = T(I) - H(I) IF (H(I).EQ.HMSG) TD = H(I) ELSE TD = H(I) ENDIF IF (ITEMPU.EQ.'f') THEN IF (T(I).NE.TMSG) T(I) = (1.8 * T(I)) + 32. IF ( TD.NE.HMSG) TD = (1.8 * TD) + 32. ENDIF IDD = D(I) IFF = F(I) IF (IWINDU.EQ.'m') THEN IF (F(I).NE.FMSG) THEN IFF = (0.514791 * F(I)) + 0.5 ENDIF ENDIF NP = NP + 1 IF (NRPBH.GT.1.AND.MOD(NP,NRPBH).EQ.1) THEN IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9651) IDSTYP(1:6), DATETAG 9651 FORMAT (/,1X, F A,' (category 06) ', F A,' DATE REPORT WIND ', F 'PRESSURE TEMPERATURE', F ' ') WRITE (LOUT,9652) AGENCY, LONA, AREP, ANST, ADEW 9652 FORMAT (1X, F ' ID ',A,' LAT LON',A,' DIST ELEV ',A,' ',A, F ' YEAR MO DY HR TIME DIR SPD ', F 'ALTITUDE AIR ',A, F ' ') C WRITE (LOUT,9653) ADU, AHTU, ANSB, W AWINDU, W AHTU, ATEMPU, ATEMPU 9653 FORMAT (1X, F ' (DEGR&.01DEGR) ',A,' ',A,' TYP ',A, F ' HR&.O1HR ',A, F ' ',A,' ',A,' ',A) WRITE (LOUT,9654) 9654 FORMAT (65X,'--- Q --- ---- Q ----- Q ----- Q << ', F 'QUALITY FLAGS (SM.51)') ENDIF ENDIF IF (TYPOUT.EQ.'d'.OR.TYPOUT.EQ.'b') THEN WRITE (LOUT,9655) ASTA, IC27, XLAT, XLON, JDIST, JELEV, 2 IRTYP, INSTYP, AYR, MMO, MDY, MHR, TIME, IDD, QSHO(I)(4:4), 3 IFF, IZZ, QSHO(I)(1:1), T(I), QSHO(I)(2:2), TD, QSHO(I)(3:3) 9655 FORMAT(1X, 1 A6,1X,A1,2F7.2,2I6, 2 I4,I4,1X,A4,3I3,F6.2,I5,1X,A, 3 I4,1X,I7,1X,A,F7.1,1X,A,F6.1,1X,A,F6.1,1X,A) ENDIF 680 CONTINUE 800 CONTINUE C C *** DONE PARSING THIS REPORT, GO GET THE NEXT ONE C GO TO 2000 C 990 CONTINUE IFILE = IFILE + 1 IF (IFILE.LT.2) GO TO 1900 ! we are not working with tapes anymore 991 CONTINUE WRITE (LOUT,9990) 9990 FORMAT (/,1X,'<<< END OF INPUT FILE >>>') IF (IPROC.EQ.'y') THEN IF (TYPOUT.EQ.'s'.OR.TYPOUT.EQ.'b') THEN C C DUMP LOCATION/STATION COUNTERS C NUMLLK = 0 NUMREP = 0 WRITE (LOUT,9991) LONA 9991 FORMAT (/,1X,9('##########'),'##', F //,1X,'ADP73: LOCATION / STATION COUNTS', F /, ' ', F ' NAME SHOWN IN USAF DICTIONARY (DS900.0)', F /, ' LON(',A,') LAT STATION REPORTS', F ' (FIRST OF PERHAPS A FEW)') DO 994 LONK = 1, 3601 DO 993 LATK = 1, 1801 XLON = (LONK - 1) / 10. IF (LONA.EQ.'E') THEN XLON = 360. - XLON ENDIF XLAT = (LATK - 901) / 10. DO 992 LLK = 1, 5 IF (LOCK(LLK,LATK,LONK).EQ.0) GO TO 992 IF (LLK.EQ.1) THEN NUMLLK = NUMLLK + 1 ENDIF STATID(1:5) = LOCI(LLK,LATK,LONK)(1:5) CALL USAFDIC (STATID,NAMEDIC) WRITE (LOUT,9992) XLON, XLAT, LOCI(LLK,LATK,LONK)(1:6), W LOCK(LLK,LATK,LONK), W NAMEDIC(1:26) 9992 FORMAT (F6.1,2X,F6.1,3X,A6,2X,I5,4X,A26) NUMREP = NUMREP + LOCK(LLK,LATK,LONK) 992 CONTINUE 993 CONTINUE 994 CONTINUE WRITE (LOUT,9994) NUMLLK, NUMREP 9994 FORMAT (//1X,'ADP73: FOUND A TOTAL OF ',I6,' STATION', F ' LOCATIONS AND ',I9,' REPORTS', F /1X,' STATIONS CAN GO IN AND OUT OF SERVICE,', F ' RELOCATE, OR TRANSMIT FAULTY', F ' INFORMATION', F /1X,' IF NO NAMES APPEAR ABOVE, VERIFY THAT', F ' YOU PROVIDED DICTIONARY FILE usafdict') ENDIF WRITE (LOUT,9997) IREC, IST 9997 FORMAT (//1X,'ADP73: STOP- IREC, IST',I9,', ',I2,' END OF FILE') WRITE (*,*) ' ' WRITE (*,9998) FNAMO 9998 FORMAT (/1X,'ADP73: NOW EXAMINE THE OUTPUT FILE ',A) WRITE (*,*) ' ' ELSE WRITE (LOUT,9999) IPROC 9999 FORMAT (1X,'ADP73: ',A,'NOT RUN') ENDIF CLOSE (LOUT) CLOSE (IUN) STOP END BLOCK DATA ADPBLK C C BLOCK DATA FOR READ ROUTINES FOR NCEP/NMC ADP DATA 1973 AND LATER C PARAMETER (MX=500) CHARACTER*8 QSHO, D08, A08, M08 COMMON / ARRAYS / P(MX), Z(MX), T(MX), H(MX), D(MX), F(MX), A C(MX), QSHO(MX), D08(MX), A08(MX), M08(MX), IC08(MX), R PMSG, ZMSG, TMSG, HMSG, DMSG, FMSG, CMSG C C P PRESSURE IN MB C Z GEOPOTENTIAL IN METERS C T TEMPERATURE IN DEGREES C AS PRINTED (IN TENTHS OF DEGREES AS PACKED) C H DEWPOINT DEPRESSION IN DEGREES C AS PRINTED (IN TENTHS OF DEGREES AS PACKED) C D WIND DIRECTION IN DEGREES C F WIND SPEED IN KNOTS C Q SET OF QUALITY MARKS (SEE NCEP/NMC OFFICE NOTE 29) C FOR P,Z,T,H,W(WIND) C DATA PMSG, ZMSG, TMSG, HMSG, DMSG, FMSG, CMSG / P 99999., 99999., 999.9, 99.9, 999., 999., 999. / C C LEAVE THE 10000 ALONE, EVEN THOUGH IT IS BIGGER THAN THE ORIGINAL C 6440 LOGICAL RECORD SIZE C CHARACTER NBF*10000 COMMON / ADPB / NBF COMMON / ADPC / LOGREC, NU, NA, LTHR, LOUT, idump, irep, ireplim C CHARACTER*8 EOREP, EOREC, XS, WASH, EOFIL COMMON / ADP / EOREP, EOREC, XS, WASH, EOFIL C PARAMETER (JX=21) COMMON / PRESS / PM(JX), KTOP(JX), ICRITR, MANTHRU C C REAL*8 TIME, XLAT, XLON, ELEV CHARACTER*16 IDATSHO CHARACTER*8 IDSTYP, IDTPRT, ASTA COMMON / CRDADP / IDATSHO, IDSTYP, IDTPRT, ASTA, XLAT, XLON, 2 ELEV, IRTYP, INSTYP, IRC, IYR, IMO, IDY, IHR, TIME, TIME08 C C C DATA PM / 1000., 925., 850., 700., 500., 400., 300., 250., P 200., 150., 100., 70., 50., 30., 20., 10., M 7., 5., 3., 2., 1./ C DATA LOGREC / 6440 / C DATA EOREP /'END REPO'/ DATA EOREC /'END RECO'/ DATA XS /'XXXXXXXX'/ DATA WASH /'WASHINGT'/ DATA EOFIL /'ENDOF FI'/ C END SUBROUTINE RDADP (IUN,ISTAT,IREC,IREP) C C RDADP UNPACKS HEADER BLOCK IDS AND REPORT IDS FROM C THE DATA IN THE INPUT FILE C C LEAVE THE 10000 ALONE, EVEN THOUGH IT IS BIGGER THAN THE ORIGINAL C 6440 LOGICAL RECORD SIZE C CHARACTER NBF*10000 COMMON / ADPB / NBF COMMON / ADPC / LOGREC, NU, NA, LTHR, LOUT, idump, jrep, ireplim C CHARACTER*8 EOREP, EOREC, XS, WASH, EOFIL COMMON / ADP / EOREP, EOREC, XS, WASH, EOFIL C PARAMETER (JX=21) COMMON / PRESS / PM(JX), KTOP(JX), ICRITR, MANTHRU C C REAL*8 TIME, XLAT, XLON, ELEV CHARACTER*16 IDATSHO CHARACTER*8 IDSTYP, IDTPRT, ASTA COMMON / CRDADP / IDATSHO, IDSTYP, IDTPRT, ASTA, XLAT, XLON, 2 ELEV, IRTYP, INSTYP, IRC, IYR, IMO, IDY, IHR, TIME, TIME08 C CHARACTER*1 IC25, IC26, IC27 CHARACTER*5 ICNN COMMON / RESERVE / IC25, IC26, IC27, ICNN C C CHARACTER*8 IDSAVE COMMON / SAVE / IDSAVE, IYRSV, IMOSV, IDYSV, IHRSV C SAVE C IF (idump.NE.0) THEN WRITE (LOUT,8999) IREC, IREP, NU, NA, LTHR, IYR 8999 FORMAT (/1x,'RDADP TOP irec, irep, nu, na, lthr, iyr', F 5I10,I10) ENDIF NU = NU + LTHR IF (NU.LT.NA) GO TO 10 5 CONTINUE C C CALL RDTAPE(IUN,1,0,NBF,LIM) C CALL IOWAIT(IUN,IST,IWDS) C IF(IST.NE.0) GO TO 90 C IST = 1 IREC = IREC + 1 READ (IUN,8001,END=90) NBF 8001 FORMAT (A) C C HOW DO I GET THE ACTUAL NUMBER OF CHARACTERS READ HERE? C IWDS = LOGREC / 8 IST = 0 NU = 1 NA = 8 * IWDS IF (NBF(21:28).NE.WASH) GO TO 10 IREP = 0 ! RESET REPORT COUNT FOR NEW DATE / TYPE C C PRINT HEADER RECORD FOR DIAGNOSTICS C if (idump.ne.0.and.irep.le.ireplim) then write (lout,800) irec, nbf(1:120) 800 format (/1x,'RDADP: HEADER irec =',i5,' nbf(1:120)', f /,1X,'# 1 2 3 4 5', f ' 6 7 8 9 10', f ' 11 12', f /,1X,' 12345678901234567890123456789012345678901234567890', f '12345678901234567890123456789012345678901234567890', f '12345678901234567890', f /,1X,'#',A120,'#') ENDIF C C GET DATE AND DATASET TYPE FROM HEADER RECORD C READ (NBF(1:16),8008) IHRSV, IYRSV, IMOSV, IDYSV, IDSAVE(1:6) 8008 FORMAT (I4,I2,I2,I2,A) GO TO 5 10 CONTINUE IHR = IHRSV ! CALLING PROGRAM MAY IYR = IYRSV ! REWRITE THESE IMO = IMOSV ! VALUES, SO RESTORE IDY = IDYSV ! THEM WITH THE SAVED IDSTYP(1:6) = IDSAVE(1:6) ! VALUES C IF (idump.NE.0) THEN C C ***** SELECT ON FILE TYPE C IF (IDTPRT(1:3).NE.'all'.AND.IDSTYP(1:6).NE.IDTPRT(1:6)) 2 GO TO 5 ENDIF C IF (NBF(NU:NU+7).EQ.EOFIL) GO TO 5 IF (NBF(NU:NU+7).EQ.EOREC) GO TO 5 IF (NBF(NU:NU+7).EQ.XS ) GO TO 5 C C GET ID FOR CURRENT REPORT C C READ (NBF(NU:NU+39),8010,ERR=80) XLAT, XLON, ASTA(1:6), TIME, 2 IC25, IC26, IC27, IRTYP, ELEV, INSTYP, LTH 8010 FORMAT(F5.2,F5.2,A6,F4.2,4X,3A1,I3,F5.0,I2,I3) C LTHR = 10 * LTH C IF (idump.NE.0) THEN WRITE (LOUT,9021) IREC, NU, LOGREC, LTHR 9021 FORMAT (/,1X,9('##########'),'##', F //,1X,'REPORT DECODE FROM RECORD', F I6,', STARTING BYTE',I5,' OF ',I5,', LENGTH',I5) WRITE (LOUT,9022) IREC, NU, W NBF(NU :NU+ 119), NBF(NU+ 120:NU+ 239), W NBF(NU+ 240:NU+ 359), NBF(NU+ 360:NU+ 479), W NBF(NU+ 480:NU+ 599), NBF(NU+ 600:NU+ 719), W NBF(NU+ 720:NU+ 839), NBF(NU+ 840:NU+ 959), W NBF(NU+ 960:NU+1079), NBF(NU+1080:NU+1199) 9022 FORMAT (/1X,'RDADP: DUMP RECORD IREC=',I5,', NU=',I5, F /,1X,'# 1 2 3 4 5', F ' 6 7 8 9 10', F ' 11 12', F /,1X,' 12345678901234567890123456789012345678901234567890', F '12345678901234567890123456789012345678901234567890', F '12345678901234567890', F /,1X,'NBF(1:960)- ', F /,1X,'#',A120,'# 120', /,1X,'#',A120,'# 240', F /,1X,'#',A120,'# 360', /,1X,'#',A120,'# 480', F /,1X,'#',A120,'# 600', /,1X,'#',A120,'# 720', F /,1X,'#',A120,'# 840', /,1X,'#',A120,'# 960', F /,1X,'#',A120,'# 1080', /,1X,'#',A120,'# 1200') ENDIF ISTAT = 0 IF (NU+LTHR.GT.LOGREC) GO TO 5 IF (LTHR.GT.40) RETURN C C PRIOR TO 1992JAN22.12, INSTYP FROM TABLE R.2.A C THEN FROM TABLE R.2.B C C BUT ON 1991JAN09.12, NMC MOVED INSTYP FROM THE REPORT ID TO C CATEGORY 08... C NYRMO = 100*IYR + IMO JHR = (IHR + 50) / 100 IDATE = 10000*NYRMO + IDY*100 + JHR ! SYNOPTIC TIME IF (IDATE.GE.1991010912) THEN C C EFFECTIVE 1200 UTC 1/9/91 (1991010912) THE INSTRUMENT TYPE C IS ENCODED IN CATEGORY 08, UNDER CODE FIGURE 106 C (DECODED IN SUBROUTINE ADDADP) C C I HOPE THE FOLLOWING SETTING IS OK - I.E., IF NO CATEGORY C 08, AND A VALID VALUE IS HERE IN THE ID, THIS WOULD C CLOBBER IT... C INSTYP = 99 ENDIF IRC = 0 80 CONTINUE WRITE (LOUT,9080) IREC, IREP, NU, NBF(NU:NU+119) 9080 FORMAT (/1X,'RDADP: READ ERROR AT IREC=',I5,', IREP=',I5, F ', NU=',I5, F /,1X,'# 1 2 3 4 5', F ' 6 7 8 9 10', F ' 11 12', F /,1X,' 12345678901234567890123456789012345678901234567890', F '12345678901234567890123456789012345678901234567890', F '12345678901234567890', F /,1X,'NBF(1:120)- ', F /,1X,'#',A120,'#') GO TO 5 90 CONTINUE ISTAT = IST RETURN END SUBROUTINE STKADP (IREC,KREP,IDUM,NLV,MLIM,PSFC,TSFC,JTPP,JWPP, S JWZZ) C C COMBINE ALL THE PRESSURE LEVEL DATA INTO A SINGLE STACK. C AND LOOK FOR WIND BY HEIGHT DATA C C LEAVE THE 10000 ALONE, EVEN THOUGH IT IS BIGGER THAN THE ORIGINAL C 6440 LOGICAL RECORD SIZE C CHARACTER NBF*10000 COMMON / ADPB / NBF COMMON / ADPC / LOGREC, NU, NA, LTHR, LOUT, idump, irep, ireplim C CHARACTER*8 EOREP, EOREC, XS, WASH, EOFIL COMMON / ADP / EOREP, EOREC, XS, WASH, EOFIL C PARAMETER (JX=21) COMMON / PRESS / PM(JX), KTOP(JX), ICRITR, MANTHRU C C REAL*8 TIME, XLAT, XLON, ELEV CHARACTER*16 IDATSHO CHARACTER*8 IDSTYP, IDTPRT, ASTA COMMON / CRDADP / IDATSHO, IDSTYP, IDTPRT, ASTA, XLAT, XLON, 2 ELEV, IRTYP, INSTYP, IRC, IYR, IMO, IDY, IHR, TIME, TIME08 C PARAMETER (MX=500) CHARACTER*8 QSHO, D08, A08, M08 COMMON / ARRAYS / P(MX), Z(MX), T(MX), H(MX), D(MX), F(MX), A C(MX), QSHO(MX), D08(MX), A08(MX), M08(MX), IC08(MX), R PMSG, ZMSG, TMSG, HMSG, DMSG, FMSG, CMSG C CHARACTER*8 XQ C SAVE C IF (idump.NE.0) THEN WRITE (LOUT,8999) IREC, KREP, NU, NA, LTHR, IYR 8999 FORMAT (1x,'STKADP TOP: irec, krep, nu, na, lthr, iyr', f 5i10,i10) ENDIF C C MLEV IS THE NUMBER OF REMAINING SLOTS IN THE DATA ARRAYS, C INITIALLY THE DIMENSION OF THESE ARRAYS C NLV = 0 1 CONTINUE MLEV = MLIM NEXT = 1 NMLV = 0 CALL MANADP (IREC,KREP,NEXT,NMLV,MLEV) KMLV = NMLV IF (NMLV.LE.0) THEN ! DODGE NMLV = -1 (DECODE ERRORS) KMLV = 0 ELSE NLV = KMLV ENDIF C MLEV = MLEV - KMLV NEXT = 1 + KMLV NSLV = 0 CALL SIGADP (IREC,KREP,NEXT,NSLV,MLEV,PSFC) KSLV = NSLV IF (NSLV.LE.0) THEN ! DODGE NSLV = -1 (DECODE ERRORS) KSLV = 0 ELSE NLV = NLV + KSLV ENDIF JTPP = KSLV C MLEV = MLEV - KSLV NEXT = NEXT + KSLV NTLV = 0 CALL TRPADP (IREC,KREP,NEXT,NTLV,MLEV,TSFC) KTLV = NTLV IF (NTLV.LE.0) THEN ! DODGE NTLV = -1 (DECODE ERRORS) KTLV = 0 ELSE NLV = NLV + KTLV ENDIF C MLEV = MLEV - KTLV NEXT = NEXT + KTLV NPLV = 0 CALL WPPADP (IREC,KREP,NEXT,NPLV,MLEV,PSFC) KPLV = NPLV IF (NPLV.LE.0) THEN ! DODGE NPLV = -1 (DECODE ERRORS) KPLV = 0 ELSE NLV = NLV + KPLV ENDIF JWPP = KPLV C MLEV = MLEV - KPLV NEXT = NEXT + KPLV C C CAN'T STACK WIND BY HEIGHT - THERE ARE NO PRESSURE VALUES - COULDN'T SORT C PROPERLY SIGNIFICANT LEVEL OR TROPOPAUSE LEVEL DATA WHICH HAVE NO C HEIGHT VALUES, BUT WE NEED TO RETURN THE LEVEL COUNT C NZLV = 0 IUNP = 0 ! DON'T UNPACK CALL WZZADP (IREC,KREP,NEXT,NZLV,MLEV,ZSFC,IUNP) KZLV = NZLV IF (IUNP.EQ.0) THEN ! CHECKING FOR PRESENCE OF 2 OR MORE LEVELS KZLV = 0 ELSE IF (NZLV.LE.0) THEN ! DODGE NZLV = -1 (DECODE ERRORS) KZLV = 0 ELSE NLV = NLV + KZLV ENDIF ENDIF JWZZ = KZLV C MLEV = MLEV - KZLV NEXT = NEXT + KZLV IPASS = 0 ! IPASS SUBTLY DIFFERS FROM WHAT WOULD BE NALV CALL ADDADP (IREC,KREP,NEXT,IPASS,MLEV) KALV = IPASS IF (IPASS.LE.0) THEN ! DODGE IPASS = -1 (DECODE ERRORS) KALV = 0 ELSE NLV = NLV + KALV ENDIF C C *** NEXT WE SORT THE STACK ON PRESSURE C DO 95 KL = 1, 1000 KHIT = 0 DO 90 KK = 1, NLV-1 IF (P(KK).GE.P(KK+1)) GO TO 90 KHIT = 1 C C SWAP C XP = P(KK) XZ = Z(KK) XT = T(KK) XH = H(KK) XD = D(KK) XF = F(KK) XC = C(KK) XQ = QSHO(KK) C P(KK) = P(KK+1) Z(KK) = Z(KK+1) T(KK) = T(KK+1) H(KK) = H(KK+1) D(KK) = D(KK+1) F(KK) = F(KK+1) C(KK) = C(KK+1) QSHO(KK) = QSHO(KK+1) C P(KK+1) = XP Z(KK+1) = XZ T(KK+1) = XT H(KK+1) = XH D(KK+1) = XD F(KK+1) = XF C(KK+1) = XC QSHO(KK+1) = XQ 90 CONTINUE IF (KHIT.EQ.0) GO TO 100 95 CONTINUE 100 CONTINUE IF (idump.NE.0) THEN WRITE (LOUT,9100) 9100 FORMAT (1X,'STKADP 100') ENDIF C C *** NEXT WE ELIMINATE REDUNDANT INFORMATION. WHERE PRESSURES MATCH, C KEEP ONLY ONE ENTRY, COLLECTING ALL THE NON-MISSING VALUES. C NBEG = 1 C NEND = NLV ! HEY NEND = NLV - 1 ! HEY C C C C NX = NLV NELIM = 0 DO 160 NC = NBEG, NEND 120 CONTINUE IF (P(NC).EQ.P(NC+1)) THEN C C STRATEGY: IF MISSING IN FIRST OCCURRENCE, TAKE WHAT IS IN NEXT C OCCURRENCE, EVEN IF MISSING C C IF (P(NC).EQ.PMSG) P(NC) = P(NC+1) IF (Z(NC).EQ.ZMSG) Z(NC) = Z(NC+1) IF (T(NC).EQ.TMSG) T(NC) = T(NC+1) IF (H(NC).EQ.HMSG) H(NC) = H(NC+1) IF (D(NC).EQ.DMSG) D(NC) = D(NC+1) IF (F(NC).EQ.FMSG) F(NC) = F(NC+1) IF (C(NC).EQ.CMSG) C(NC) = C(NC+1) IF (QSHO(NC)(1:1).EQ.' ') QSHO(NC)(1:1) = QSHO(NC+1)(1:1) IF (QSHO(NC)(2:2).EQ.' ') QSHO(NC)(2:2) = QSHO(NC+1)(2:2) IF (QSHO(NC)(3:3).EQ.' ') QSHO(NC)(3:3) = QSHO(NC+1)(3:3) IF (QSHO(NC)(4:4).EQ.' ') QSHO(NC)(4:4) = QSHO(NC+1)(4:4) IF (QSHO(NC)(5:5).EQ.' ') QSHO(NC)(5:5) = QSHO(NC+1)(5:5) IF (QSHO(NC)(6:6).EQ.' ') QSHO(NC)(6:6) = QSHO(NC+1)(6:6) IF (QSHO(NC)(7:7).EQ.' ') QSHO(NC)(7:7) = QSHO(NC+1)(7:7) IF (QSHO(NC)(8:8).EQ.' ') QSHO(NC)(8:8) = QSHO(NC+1)(8:8) DO 150 NN = NC+1, NX C C TOSS THE REDUNDANT LEVEL BY SHIFTING THE STACK DOWN C P(NN) = P(NN+1) Z(NN) = Z(NN+1) T(NN) = T(NN+1) H(NN) = H(NN+1) D(NN) = D(NN+1) F(NN) = F(NN+1) QSHO(NN) = QSHO(NN+1) 150 CONTINUE NELIM = NELIM + 1 NX = NX - 1 IF (NC.GE.NX) GO TO 190 GO TO 120 ! GOTTA HOLD AT NC TO SEE IF NEXT PRESSURE ALSO MATCHES ENDIF IF (NC.GE.NX) GO TO 190 160 CONTINUE 190 CONTINUE IF (idump.NE.0) THEN WRITE (LOUT,9190) 9190 FORMAT (1X,'STKADP 190') ENDIF NLV = NLV - NELIM RETURN END SUBROUTINE MANADP (IREC,KREP,IPT,NCNT,MLEV) C C UNPACK CATEGORY 01 DATA, MANDATORY LEVEL DATA C C LEAVE THE 10000 ALONE, EVEN THOUGH IT IS BIGGER THAN THE ORIGINAL C 6440 LOGICAL RECORD SIZE C CHARACTER NBF*10000 COMMON / ADPB / NBF COMMON / ADPC / LOGREC, NU, NA, LTHR, LOUT, idump, irep, ireplim C CHARACTER*8 EOREP, EOREC, XS, WASH, EOFIL COMMON / ADP / EOREP, EOREC, XS, WASH, EOFIL C PARAMETER (JX=21) COMMON / PRESS / PM(JX), KTOP(JX), ICRITR, MANTHRU C C REAL*8 TIME, XLAT, XLON, ELEV CHARACTER*16 IDATSHO CHARACTER*8 IDSTYP, IDTPRT, ASTA COMMON / CRDADP / IDATSHO, IDSTYP, IDTPRT, ASTA, XLAT, XLON, 2 ELEV, IRTYP, INSTYP, IRC, IYR, IMO, IDY, IHR, TIME, TIME08 C PARAMETER (MX=500) CHARACTER*8 QSHO, D08, A08, M08 COMMON / ARRAYS / P(MX), Z(MX), T(MX), H(MX), D(MX), F(MX), A C(MX), QSHO(MX), D08(MX), A08(MX), M08(MX), IC08(MX), R PMSG, ZMSG, TMSG, HMSG, DMSG, FMSG, CMSG C CHARACTER*8 Q(MX) C SAVE C IF (idump.NE.0) THEN WRITE (LOUT,8998) IPT, NCNT, MAXLEV 8998 FORMAT (1x,'MANADP TOP: ipt, ncnt, maxlev', F 5I10,I10) WRITE (LOUT,8999) IREC, KREP, NU, NA, LTHR, IYR 8999 FORMAT (1x,'MANADP TOP: irec, krep, nu, na, lthr, iyr', F 5I10,I10) ENDIF NTU = NU + 40 NCNT = 0 NLV = 0 2 CONTINUE C C LOOK FOR CATEGORY 01 C IF (NBF(NTU:NTU+7).EQ.EOREP) GO TO 90 READ (NBF(NTU:NTU+6),8005,ERR=95) NCC, NTN, NENT 8005 FORMAT (I2,I3,I2) IF (NTN.LE.0) GO TO 95 IF (NCC.EQ.1) GO TO 3 NTU = NU + (10 * (NTN-1)) GO TO 2 3 CONTINUE NENT = NENT + 1 ! WE WILL BE ADDING (INSERTING) A 925MB LEVEL C ! INTO THE USUAL ADP STACK 10 CONTINUE NLV = NENT IF (NLV.GT.MLEV) THEN WRITE (LOUT,9010) IREC, KREP, NLV, MLEV 9010 FORMAT (1X,'MANADP: IREC=',I5,', KREP=',I5, F ', TOO MANY LEVELS, NLV',I4,', MLEV',I4) NLV = MLEV ENDIF NTU = NTU + 10 IBEG = IPT ! ALWAYS = 1 IN A MANADP CALL IEND = (IPT-1) + NLV DO 30 I = IBEG, IEND IF (I.NE.2) THEN READ (NBF(NTU:NTU+21),8030,ERR=95) Z(I), T(I), H(I), R D(I), F(I), Q(I)(1:4) 8030 FORMAT(F5.0,F4.1,F3.1,2F3.0,A4) P(I) = PM(I) C Z(I) = ZMSG C T(I) = TMSG C H(I) = HMSG C D(I) = DMSG C F(I) = FMSG NTU = NTU + 22 ELSE C C SEED IN THE 925MB LEVEL C P(I) = PM(I) Z(I) = ZMSG T(I) = TMSG H(I) = HMSG D(I) = DMSG F(I) = FMSG Q(I) = ' ' ENDIF QSHO(I) = ' ' QSHO(I)(1:1) = ' ' ! P QSHO(I)(2:2) = Q(I)(1:1) ! Z QSHO(I)(3:3) = Q(I)(2:2) ! T QSHO(I)(4:4) = Q(I)(3:3) ! H QSHO(I)(5:5) = Q(I)(4:4) ! W QSHO(I)(6:6) = ' ' ! C 30 CONTINUE 90 CONTINUE IF (idump.NE.0) THEN WRITE (LOUT,9090) P(IPT), Z(IPT), T(IPT), H(IPT), W D(IPT), F(IPT), Q(IPT)(1:6) 9090 FORMAT (1X,'MANADP ',6F8.1,1X,A) ENDIF NCNT = NLV RETURN 95 CONTINUE IF (idump.NE.0) THEN WRITE (LOUT,9095) IREC, KREP, NBF(NTU:NTU+21) 9095 FORMAT (1X,'MANADP: IREC=',I5,', KREP=',I5, F ', DECODE ERROR IN CAT 01 ',A22) ENDIF NCNT = -1 RETURN END SUBROUTINE SIGADP (IREC,KREP,IPT,NLV,MLEV,PSFC) C C UNPACK CATEGORY 02 DATA, SIGNIFICANT LEVEL DATA C C LEAVE THE 10000 ALONE, EVEN THOUGH IT IS BIGGER THAN THE ORIGINAL C 6440 LOGICAL RECORD SIZE C CHARACTER NBF*10000 COMMON / ADPB / NBF COMMON / ADPC / LOGREC, NU, NA, LTHR, LOUT, idump, irep, ireplim C CHARACTER*8 EOREP, EOREC, XS, WASH, EOFIL COMMON / ADP / EOREP, EOREC, XS, WASH, EOFIL C PARAMETER (JX=21) COMMON / PRESS / PM(JX), KTOP(JX), ICRITR, MANTHRU C C REAL*8 TIME, XLAT, XLON, ELEV CHARACTER*16 IDATSHO CHARACTER*8 IDSTYP, IDTPRT, ASTA COMMON / CRDADP / IDATSHO, IDSTYP, IDTPRT, ASTA, XLAT, XLON, 2 ELEV, IRTYP, INSTYP, IRC, IYR, IMO, IDY, IHR, TIME, TIME08 C PARAMETER (MX=500) CHARACTER*8 QSHO, D08, A08, M08 COMMON / ARRAYS / P(MX), Z(MX), T(MX), H(MX), D(MX), F(MX), A C(MX), QSHO(MX), D08(MX), A08(MX), M08(MX), IC08(MX), R PMSG, ZMSG, TMSG, HMSG, DMSG, FMSG, CMSG C CHARACTER*8 Q(MX), QQR C SAVE C IF (idump.NE.0) THEN WRITE (LOUT,8998) IPT, NCNT, MAXLEV 8998 FORMAT (1x,'SIGADP TOP: ipt, ncnt, maxlev', F 5I10,I10) WRITE (LOUT,8999) IREC, KREP, NU, NA, LTHR, IYR 8999 FORMAT (1x,'SIGADP TOP: irec, krep, nu, na, lthr, iyr', F 5I10,I10) ENDIF NTU = NU + 40 NCNT = 0 NLV = 0 2 CONTINUE C C LOOK FOR CATEGORY 02 C IF (NBF(NTU:NTU+7).EQ.EOREP) GO TO 90 READ (NBF(NTU:NTU+6),8005,ERR=95) NCC, NTN, NENT 8005 FORMAT (I2,I3,I2) IF (NTN.LE.0) GO TO 95 IF (NCC.EQ.2) GO TO 3 NTU = NU + (10 * (NTN-1)) GO TO 2 3 CONTINUE 10 CONTINUE NLV = NENT IF (NLV.GT.MLEV) THEN WRITE (LOUT,9010) IREC, KREP, NLV, MLEV 9010 FORMAT (1X,'SIGADP: IREC=',I5,', KREP=',I5, F ', TOO MANY LEVELS, NLV',I4,', MLEV',I4) NLV = MLEV ENDIF NTU = NTU + 10 IBEG = IPT IEND = (IPT-1) + NLV IPUT = IBEG - 1 DO 30 I = IBEG, IEND READ (NBF(NTU:NTU+14),8030,ERR=95) PPR, TTR, HHR, QQR(1:3) C 8030 FORMAT (F5.1,F4.1,F3.1,A3) IF (PPR.EQ.9999.9) GO TO 28 ! CAN'T STACK WITHOUT THE PRESSURE IPUT = IPUT + 1 P(IPUT) = PPR C Z(IPUT) = ZMSG T(IPUT) = TTR H(IPUT) = HHR D(IPUT) = DMSG F(IPUT) = FMSG QSHO(IPUT) = ' ' QSHO(IPUT)(1:1) = QQR(1:1) ! P QSHO(IPUT)(2:2) = ' ' ! Z QSHO(IPUT)(3:3) = QQR(2:2) ! T QSHO(IPUT)(4:4) = QQR(3:3) ! H QSHO(IPUT)(5:5) = ' ' ! W QSHO(IPUT)(6:6) = ' ' ! C C C FIRST LEVEL IS SUPPOSED TO BE THE SURFACE LEVEL. ENSURE THAT C THIS FIRST LEVEL'S PRESSURE IS REASONABLE FOR THE ELEVATION C OF THE STATION. THINGS MAY OTHERWISE GET GOOFY. C IF (ELEV.NE.-999999.) THEN CALL STDZ2P (PREAS,ELEV,0,TCENT,RHO) PREAS = 0.9 * PREAS C IF (I.EQ.IPT.AND.P(IPUT).GE.PREAS) XSFC = P(IPUT) IF (I.EQ.IPT.AND.P(IPUT).GE.PREAS) PSFC = P(IPUT) ENDIF 28 CONTINUE NTU = NTU + 15 30 CONTINUE 90 CONTINUE IF (idump.NE.0) THEN WRITE (LOUT,9090) P(IPT), Z(IPT), T(IPT), H(IPT), W D(IPT), F(IPT), Q(IPT)(1:6) 9090 FORMAT (1X,'SIGADP ',6F8.1,1X,A) ENDIF NCNT = NLV RETURN 95 CONTINUE IF (idump.NE.0) THEN WRITE (LOUT,9095) IREC, KREP, NBF(NTU:NTU+14) 9095 FORMAT (1X,'SIGADP: IREC=',I5,', KREP=',I5, F ', DECODE ERROR IN CAT 02 ',A15) ENDIF NCNT = -1 RETURN END SUBROUTINE TRPADP (IREC,KREP,IPT,NCNT,MLEV,TSFC) C C UNPACK CATEGORY 05 DATA, TROPOPAUSE DATA C C LEAVE THE 10000 ALONE, EVEN THOUGH IT IS BIGGER THAN THE ORIGINAL C 6440 LOGICAL RECORD SIZE C CHARACTER NBF*10000 COMMON / ADPB / NBF COMMON / ADPC / LOGREC, NU, NA, LTHR, LOUT, idump, irep, ireplim C CHARACTER*8 EOREP, EOREC, XS, WASH, EOFIL COMMON / ADP / EOREP, EOREC, XS, WASH, EOFIL C PARAMETER (JX=21) COMMON / PRESS / PM(JX), KTOP(JX), ICRITR, MANTHRU C C REAL*8 TIME, XLAT, XLON, ELEV CHARACTER*16 IDATSHO CHARACTER*8 IDSTYP, IDTPRT, ASTA COMMON / CRDADP / IDATSHO, IDSTYP, IDTPRT, ASTA, XLAT, XLON, 2 ELEV, IRTYP, INSTYP, IRC, IYR, IMO, IDY, IHR, TIME, TIME08 C PARAMETER (MX=500) CHARACTER*8 QSHO, D08, A08, M08 COMMON / ARRAYS / P(MX), Z(MX), T(MX), H(MX), D(MX), F(MX), A C(MX), QSHO(MX), D08(MX), A08(MX), M08(MX), IC08(MX), R PMSG, ZMSG, TMSG, HMSG, DMSG, FMSG, CMSG C CHARACTER*8 Q(MX) C SAVE C IF (idump.NE.0) THEN WRITE (LOUT,8998) IPT, NCNT, MAXLEV 8998 FORMAT (1x,'TRPADP TOP: ipt, ncnt, maxlev', F 5I10,I10) WRITE (LOUT,8999) IREC, KREP, NU, NA, LTHR, IYR 8999 FORMAT (1x,'TRPADP TOP: irec, krep, nu, na, lthr, iyr', F 5I10,I10) ENDIF NTU = NU + 40 NCNT = 0 NLV = 0 2 CONTINUE C C LOOK FOR CATEGORY 05 C IF (NBF(NTU:NTU+7).EQ.EOREP) GO TO 90 READ (NBF(NTU:NTU+6),8005,ERR=95) NCC, NTN, NENT 8005 FORMAT (I2,I3,I2) IF (NTN.LE.0) GO TO 95 IF (NCC.EQ.5) GO TO 3 NTU = NU + (10 * (NTN-1)) GO TO 2 3 CONTINUE 10 CONTINUE NLV = NENT IF (NLV.GT.MLEV) THEN WRITE (LOUT,9010) IREC, KREP, NLV, MLEV 9010 FORMAT (1X,'TRPADP: IREC=',I5,', KREP=',I5, F ', TOO MANY LEVELS, NLV',I4,', MLEV',I4) NLV = MLEV ENDIF NTU = NTU + 10 IBEG = IPT IEND = (IPT-1) + NLV DO 30 I = IBEG, IEND READ (NBF(NTU:NTU+21),8030,ERR=95) P(I), T(I), H(I), D(I), F(I), R Q(I) 8030 FORMAT (F5.1,F4.1,F3.1,2F3.0,A4) C P(I) = PMSG C Z(I) = ZMSG C T(I) = TMSG C H(I) = HMSG C D(I) = DMSG C F(I) = FMSG QSHO(I) = ' ' QSHO(I)(1:1) = Q(I)(1:1) ! P QSHO(I)(2:2) = ' ' ! Z QSHO(I)(3:3) = Q(I)(2:2) ! T QSHO(I)(4:4) = Q(I)(3:3) ! H QSHO(I)(5:5) = Q(I)(4:4) ! W QSHO(I)(6:6) = ' ' ! C C C TAKE FIRST LEVEL AS TROPOPAUSE C IF (I.EQ.IPT) TSFC = P(I) NTU = NTU + 22 30 CONTINUE 90 CONTINUE IF (idump.NE.0) THEN WRITE (LOUT,9090) P(IPT), Z(IPT), T(IPT), H(IPT), W D(IPT), F(IPT), Q(IPT)(1:6) 9090 FORMAT (1X,'TRPADP ',6F8.1,1X,A) ENDIF NCNT = NLV RETURN 95 CONTINUE IF (idump.NE.0) THEN WRITE (LOUT,9095) IREC, KREP, NBF(NTU:NTU+12) 9095 FORMAT (1X,'TRPADP: IREC=',I5,', KREP=',I5, F ', DECODE ERROR IN CAT 05 ',A13) ENDIF NCNT = -1 RETURN END SUBROUTINE WPPADP (IREC,KREP,IPT,NCNT,MLEV,PSFC) C C UNPACK CATEGORY 03 DATA, WIND BY PRESSURE C C LEAVE THE 10000 ALONE, EVEN THOUGH IT IS BIGGER THAN THE ORIGINAL C 6440 LOGICAL RECORD SIZE C CHARACTER NBF*10000 COMMON / ADPB / NBF COMMON / ADPC / LOGREC, NU, NA, LTHR, LOUT, idump, irep, ireplim C CHARACTER*8 EOREP, EOREC, XS, WASH, EOFIL COMMON / ADP / EOREP, EOREC, XS, WASH, EOFIL C PARAMETER (JX=21) COMMON / PRESS / PM(JX), KTOP(JX), ICRITR, MANTHRU C C REAL*8 TIME, XLAT, XLON, ELEV CHARACTER*16 IDATSHO CHARACTER*8 IDSTYP, IDTPRT, ASTA COMMON / CRDADP / IDATSHO, IDSTYP, IDTPRT, ASTA, XLAT, XLON, 2 ELEV, IRTYP, INSTYP, IRC, IYR, IMO, IDY, IHR, TIME, TIME08 C PARAMETER (MX=500) CHARACTER*8 QSHO, D08, A08, M08 COMMON / ARRAYS / P(MX), Z(MX), T(MX), H(MX), D(MX), F(MX), A C(MX), QSHO(MX), D08(MX), A08(MX), M08(MX), IC08(MX), R PMSG, ZMSG, TMSG, HMSG, DMSG, FMSG, CMSG C CHARACTER*8 Q(MX), QQR C SAVE C IF (idump.NE.0) THEN WRITE (LOUT,8998) IPT, NCNT, MAXLEV 8998 FORMAT (1x,'WPPADP TOP: ipt, ncnt, maxlev', F 5I10,I10) WRITE (LOUT,8999) IREC, KREP, NU, NA, LTHR, IYR 8999 FORMAT (1x,'WPPADP TOP: irec, krep, nu, na, lthr, iyr', F 5I10,I10) ENDIF NTU = NU + 40 NCNT = 0 NLV = 0 2 CONTINUE C C LOOK FOR CATEGORY 03 C IF (NBF(NTU:NTU+7).EQ.EOREP) GO TO 90 READ (NBF(NTU:NTU+6),8005,ERR=95) NCC, NTN, NENT 8005 FORMAT (I2,I3,I2) IF (NTN.LE.0) GO TO 95 IF (NCC.EQ.3) GO TO 3 NTU = NU + (10 * (NTN-1)) GO TO 2 3 CONTINUE 10 CONTINUE NLV = NENT IF (NLV.GT.MLEV) THEN WRITE (LOUT,9010) IREC, KREP, NLV, MLEV 9010 FORMAT (1X,'WPPADP: IREC=',I5,', KREP=',I5, F ', TOO MANY LEVELS, NLV',I4,', MLEV',I4) NLV = MLEV ENDIF NTU = NTU + 10 IBEG = IPT IEND = (IPT-1) + NLV IPUT = IBEG - 1 DO 30 I = IBEG, IEND READ (NBF(NTU:NTU+12),8030,ERR=95) PPR, DDR, FFR, QQR(1:2) C 8030 FORMAT (F5.1,2F3.0,A2) IF (PPR.EQ.9999.9) GO TO 28 ! CAN'T STACK WITHOUT THE PRESSURE IPUT = IPUT + 1 P(IPUT) = PPR C Z(IPUT) = ZMSG T(IPUT) = TMSG H(IPUT) = HMSG D(IPUT) = DDR F(IPUT) = FFR QSHO(IPUT) = ' ' QSHO(IPUT)(1:1) = QQR(1:1) ! P QSHO(IPUT)(2:2) = ' ' ! Z QSHO(IPUT)(3:3) = ' ' ! T QSHO(IPUT)(4:4) = ' ' ! H QSHO(IPUT)(5:5) = QQR(2:2) ! W QSHO(IPUT)(6:6) = ' ' ! C C C FIRST LEVEL IS SUPPOSED TO BE THE SURFACE LEVEL. ENSURE THAT C THIS FIRST LEVEL'S PRESSURE IS REASONABLE FOR THE ELEVATION C OF THE STATION. THINGS MAY OTHERWISE GET GOOFY. C IF (ELEV.NE.-999999.) THEN CALL STDZ2P (PREAS,ELEV,0,TCENT,RHO) PREAS = 0.9 * PREAS C IF (I.EQ.IPT.AND.P(IPUT).GE.PREAS) XSFC = P(IPUT) IF (I.EQ.IPT.AND.P(IPUT).GE.PREAS) PSFC = P(IPUT) ENDIF 28 CONTINUE NTU = NTU + 13 30 CONTINUE 90 CONTINUE IF (idump.NE.0) THEN WRITE (LOUT,9090) P(IPT), Z(IPT), T(IPT), H(IPT), W D(IPT), F(IPT), Q(IPT)(1:6) 9090 FORMAT (1X,'WPPADP ',6F8.1,1X,A) ENDIF NCNT = NLV RETURN 95 CONTINUE IF (idump.NE.0) THEN WRITE (LOUT,9095) IREC, KREP, NBF(NTU:NTU+12) 9095 FORMAT (1X,'WPPADP: IREC=',I5,', KREP=',I5, F ', DECODE ERROR IN CAT 03 ',A13) ENDIF NCNT = -1 RETURN END SUBROUTINE WZZADP (IREC,KREP,IPT,NCNT,MLEV,ZSFC,IUNP) C C UNPACK CATEGORY 04 DATA, WIND BY HEIGHT C C LEAVE THE 10000 ALONE, EVEN THOUGH IT IS BIGGER THAN THE ORIGINAL C 6440 LOGICAL RECORD SIZE C CHARACTER NBF*10000 COMMON / ADPB / NBF COMMON / ADPC / LOGREC, NU, NA, LTHR, LOUT, idump, irep, ireplim C CHARACTER*8 EOREP, EOREC, XS, WASH, EOFIL COMMON / ADP / EOREP, EOREC, XS, WASH, EOFIL C PARAMETER (JX=21) COMMON / PRESS / PM(JX), KTOP(JX), ICRITR, MANTHRU C C REAL*8 TIME, XLAT, XLON, ELEV CHARACTER*16 IDATSHO CHARACTER*8 IDSTYP, IDTPRT, ASTA COMMON / CRDADP / IDATSHO, IDSTYP, IDTPRT, ASTA, XLAT, XLON, 2 ELEV, IRTYP, INSTYP, IRC, IYR, IMO, IDY, IHR, TIME, TIME08 C PARAMETER (MX=500) CHARACTER*8 QSHO, D08, A08, M08 COMMON / ARRAYS / P(MX), Z(MX), T(MX), H(MX), D(MX), F(MX), A C(MX), QSHO(MX), D08(MX), A08(MX), M08(MX), IC08(MX), R PMSG, ZMSG, TMSG, HMSG, DMSG, FMSG, CMSG C CHARACTER*8 Q(MX) C SAVE C IF (idump.NE.0) THEN WRITE (LOUT,8998) IPT, NCNT, MAXLEV 8998 FORMAT (1x,'WZZADP TOP: ipt, ncnt, maxlev', F 5I10,I10) WRITE (LOUT,8999) IREC, KREP, NU, NA, LTHR, IYR 8999 FORMAT (1x,'WZZADP TOP: irec, krep, nu, na, lthr, iyr', F 5I10,I10) ENDIF NTU = NU + 40 NCNT = 0 NLV = 0 2 CONTINUE C C LOOK FOR CATEGORY 04 C IF (NBF(NTU:NTU+7).EQ.EOREP) GO TO 90 READ (NBF(NTU:NTU+6),8005,ERR=95) NCC, NTN, NENT 8005 FORMAT (I2,I3,I2) IF (NTN.LE.0) GO TO 95 IF (NCC.EQ.4) GO TO 3 NTU = NU + (10 * (NTN-1)) GO TO 2 3 CONTINUE NLV = NENT IF (IUNP.EQ.0) GO TO 93 10 CONTINUE NLV = NENT IF (NLV.GT.MLEV) THEN WRITE (LOUT,9010) IREC, KREP, NLV, MLEV 9010 FORMAT (1X,'WZZADP: IREC=',I5,', KREP=',I5, F ', TOO MANY LEVELS, NLV',I4,', MLEV',I4) NLV = MLEV ENDIF NTU = NTU + 10 IBEG = IPT IEND = (IPT-1) + NLV DO 30 I = IBEG, IEND READ (NBF(NTU:NTU+12),8030,ERR=95) Z(I), D(I), F(I), Q(I)(1:2) C 8030 FORMAT (F5.0,2F3.0,A2) P(I) = PMSG C C Z(I) = ZMSG T(I) = TMSG H(I) = HMSG C D(I) = DMSG C F(I) = FMSG QSHO(I) = ' ' QSHO(I)(1:1) = ' ' ! P QSHO(I)(2:2) = Q(I)(1:1) ! Z QSHO(I)(3:3) = ' ' ! T QSHO(I)(4:4) = ' ' ! H QSHO(I)(5:5) = Q(I)(2:2) ! W QSHO(I)(6:6) = ' ' ! C C C FIRST LEVEL IS SUPPOSED TO BE THE SURFACE LEVEL C C IF (I.EQ.1) YSFC = Z(I) IF (I.EQ.1) ZSFC = Z(I) NTU = NTU + 13 30 CONTINUE 90 CONTINUE IF (idump.NE.0) THEN WRITE (LOUT,9090) P(IPT), Z(IPT), T(IPT), H(IPT), W D(IPT), F(IPT), Q(IPT)(1:6) 9090 FORMAT (1X,'WZZADP ',6F8.1,1X,A) ENDIF 93 CONTINUE NCNT = NLV ! WHEN IUNP=0, JUST RETURN LEVEL COUNT, RETURN ! TO ALLOW CALLING ROUTINE TO DECIDE C ! WHETHER WE HAVE ENOUGH DATA FOR A PIBAL 95 CONTINUE IF (idump.NE.0) THEN WRITE (LOUT,9095) IREC, KREP, NBF(NTU:NTU+12) 9095 FORMAT (1X,'WZZADP: IREC=',I5,', KREP=',I5, F ', DECODE ERROR IN CAT 04 ',A13) ENDIF NCNT = -1 RETURN END SUBROUTINE AFTADP (IREC,KREP,IPT,NCNT,MLEV) C C UNPACK CATEGORY 06 DATA, KNOWN AS AIRCFT DATA C BUT ALSO USED FOR SATWND DATA C AND AIRCAR DATA C C LEAVE THE 10000 ALONE, EVEN THOUGH IT IS BIGGER THAN THE ORIGINAL C 6440 LOGICAL RECORD SIZE C CHARACTER NBF*10000 COMMON / ADPB / NBF COMMON / ADPC / LOGREC, NU, NA, LTHR, LOUT, idump, irep, ireplim C CHARACTER*8 EOREP, EOREC, XS, WASH, EOFIL COMMON / ADP / EOREP, EOREC, XS, WASH, EOFIL C PARAMETER (JX=21) COMMON / PRESS / PM(JX), KTOP(JX), ICRITR, MANTHRU C C REAL*8 TIME, XLAT, XLON, ELEV CHARACTER*16 IDATSHO CHARACTER*8 IDSTYP, IDTPRT, ASTA COMMON / CRDADP / IDATSHO, IDSTYP, IDTPRT, ASTA, XLAT, XLON, 2 ELEV, IRTYP, INSTYP, IRC, IYR, IMO, IDY, IHR, TIME, TIME08 C PARAMETER (MX=500) CHARACTER*8 QSHO, D08, A08, M08 COMMON / ARRAYS / P(MX), Z(MX), T(MX), H(MX), D(MX), F(MX), A C(MX), QSHO(MX), D08(MX), A08(MX), M08(MX), IC08(MX), R PMSG, ZMSG, TMSG, HMSG, DMSG, FMSG, CMSG C CHARACTER*8 Q(MX) C SAVE C IF (idump.NE.0) THEN WRITE (LOUT,8998) IPT, NCNT, MAXLEV 8998 FORMAT (1x,'AFTADP TOP: ipt, ncnt, maxlev', F 5I10,I10) WRITE (LOUT,8999) IREC, KREP, NU, NA, LTHR, IYR 8999 FORMAT (1x,'AFTADP TOP: irec, krep, nu, na, lthr, iyr', F 5I10,I10) ENDIF NTU = NU + 40 NCNT = 0 NLV = 0 2 CONTINUE C C LOOK FOR CATEGORY 06 C IF (NBF(NTU:NTU+7).EQ.EOREP) GO TO 90 READ (NBF(NTU:NTU+6),8005,ERR=95) NCC, NTN, NENT 8005 FORMAT (I2,I3,I2) IF (NTN.LE.0) GO TO 95 IF (NCC.EQ.6) GO TO 3 NTU = NU + (10 * (NTN-1)) GO TO 2 3 CONTINUE 10 CONTINUE NLV = NENT IF (NLV.GT.MLEV) THEN WRITE (LOUT,9010) IREC, KREP, NLV, MLEV 9010 FORMAT (1X,'AFTADP: IREC=',I5,', KREP=',I5, F ', TOO MANY LEVELS, NLV',I4,', MLEV',I4) NLV = MLEV ENDIF NTU = NTU + 10 IBEG = IPT IEND = (IPT-1) + NLV DO 30 I = IBEG, IEND READ (NBF(NTU:NTU+21),8030,ERR=95) Z(I), T(I), H(I), D(I), F(I), R Q(I) 8030 FORMAT (F5.0,F4.1,F3.1,2F3.0,A4) P(I) = PMSG C Z(I) = ZMSG C T(I) = TMSG C H(I) = HMSG C D(I) = DMSG C F(I) = FMSG QSHO(I) = ' ' QSHO(I)(1:1) = ' ' ! P QSHO(I)(2:2) = Q(I)(1:1) ! Z QSHO(I)(3:3) = Q(I)(2:2) ! T QSHO(I)(4:4) = Q(I)(3:3) ! H QSHO(I)(5:5) = Q(I)(4:4) ! W QSHO(I)(6:6) = ' ' ! C NTU = NTU + 22 30 CONTINUE 90 CONTINUE IF (idump.NE.0) THEN WRITE (LOUT,9090) P(IPT), Z(IPT), T(IPT), H(IPT), W D(IPT), F(IPT), Q(IPT)(1:6) 9090 FORMAT (1X,'AFTADP ',6F8.1,1X,A) ENDIF NCNT = NLV RETURN 95 CONTINUE IF (idump.NE.0) THEN WRITE (LOUT,9095) IREC, KREP, NBF(NTU:NTU+12) 9095 FORMAT (1X,'AFTADP: IREC=',I5,', KREP=',I5, F ', DECODE ERROR IN CAT 06 ',A13) ENDIF NCNT = -1 RETURN END SUBROUTINE STWADP (IREC,KREP,IPT,NCNT,MLEV) C C UNPACK CATEGORY 06 DATA, KNOWN AS AIRCFT DATA C BUT ALSO USED FOR SATWND DATA C AND AIRCAR DATA C C LEAVE THE 10000 ALONE, EVEN THOUGH IT IS BIGGER THAN THE ORIGINAL C 6440 LOGICAL RECORD SIZE C CHARACTER NBF*10000 COMMON / ADPB / NBF COMMON / ADPC / LOGREC, NU, NA, LTHR, LOUT, idump, irep, ireplim C CHARACTER*8 EOREP, EOREC, XS, WASH, EOFIL COMMON / ADP / EOREP, EOREC, XS, WASH, EOFIL C PARAMETER (JX=21) COMMON / PRESS / PM(JX), KTOP(JX), ICRITR, MANTHRU C C REAL*8 TIME, XLAT, XLON, ELEV CHARACTER*16 IDATSHO CHARACTER*8 IDSTYP, IDTPRT, ASTA COMMON / CRDADP / IDATSHO, IDSTYP, IDTPRT, ASTA, XLAT, XLON, 2 ELEV, IRTYP, INSTYP, IRC, IYR, IMO, IDY, IHR, TIME, TIME08 C PARAMETER (MX=500) CHARACTER*8 QSHO, D08, A08, M08 COMMON / ARRAYS / P(MX), Z(MX), T(MX), H(MX), D(MX), F(MX), A C(MX), QSHO(MX), D08(MX), A08(MX), M08(MX), IC08(MX), R PMSG, ZMSG, TMSG, HMSG, DMSG, FMSG, CMSG C CHARACTER*8 Q(MX) C SAVE C IF (idump.NE.0) THEN WRITE (LOUT,8998) IPT, NCNT, MAXLEV 8998 FORMAT (1x,'STWADP TOP: ipt, ncnt, maxlev', F 5I10,I10) WRITE (LOUT,8999) IREC, KREP, NU, NA, LTHR, IYR 8999 FORMAT (1x,'STWADP TOP: irec, krep, nu, na, lthr, iyr', F 5I10,I10) ENDIF NTU = NU + 40 NCNT = 0 NLV = 0 2 CONTINUE C C LOOK FOR CATEGORY 06 C IF (NBF(NTU:NTU+7).EQ.EOREP) GO TO 90 READ (NBF(NTU:NTU+6),8005,ERR=95) NCC, NTN, NENT 8005 FORMAT (I2,I3,I2) IF (NTN.LE.0) GO TO 95 IF (NCC.EQ.6) GO TO 3 NTU = NU + (10 * (NTN-1)) GO TO 2 3 CONTINUE 10 CONTINUE NLV = NENT IF (NLV.GT.MLEV) THEN WRITE (LOUT,9010) IREC, KREP, NLV, MLEV 9010 FORMAT (1X,'STWADP: IREC=',I5,', KREP=',I5, F ', TOO MANY LEVELS, NLV',I4,', MLEV',I4) NLV = MLEV ENDIF NTU = NTU + 10 IBEG = IPT IEND = (IPT-1) + NLV DO 30 I = IBEG, IEND READ (NBF(NTU:NTU+21),8030,ERR=95) Z(I), T(I), H(I), D(I), F(I), R Q(I) 8030 FORMAT (F5.0,F4.1,F3.1,2F3.0,A4) P(I) = PMSG C Z(I) = ZMSG C T(I) = TMSG C H(I) = HMSG C D(I) = DMSG C F(I) = FMSG QSHO(I) = ' ' QSHO(I)(1:1) = ' ' ! P QSHO(I)(2:2) = Q(I)(1:1) ! Z QSHO(I)(3:3) = Q(I)(2:2) ! T QSHO(I)(4:4) = Q(I)(3:3) ! H QSHO(I)(5:5) = Q(I)(4:4) ! W QSHO(I)(6:6) = ' ' ! C NTU = NTU + 22 30 CONTINUE 90 CONTINUE IF (idump.NE.0) THEN WRITE (LOUT,9090) P(IPT), Z(IPT), T(IPT), H(IPT), W D(IPT), F(IPT), Q(IPT)(1:6) 9090 FORMAT (1X,'STWADP ',6F8.1,1X,A) ENDIF NCNT = NLV RETURN 95 CONTINUE IF (idump.NE.0) THEN WRITE (LOUT,9095) IREC, KREP, NBF(NTU:NTU+12) 9095 FORMAT (1X,'STWADP: IREC=',I5,', KREP=',I5, F ', DECODE ERROR IN CAT 06 ',A13) ENDIF NCNT = -1 RETURN END SUBROUTINE CARADP (IREC,KREP,IPT,NCNT,MLEV) C C UNPACK CATEGORY 06 DATA, KNOWN AS AIRCFT DATA C BUT ALSO USED FOR SATWND DATA C AND AIRCAR DATA C C LEAVE THE 10000 ALONE, EVEN THOUGH IT IS BIGGER THAN THE ORIGINAL C 6440 LOGICAL RECORD SIZE C CHARACTER NBF*10000 COMMON / ADPB / NBF COMMON / ADPC / LOGREC, NU, NA, LTHR, LOUT, idump, irep, ireplim C CHARACTER*8 EOREP, EOREC, XS, WASH, EOFIL COMMON / ADP / EOREP, EOREC, XS, WASH, EOFIL C PARAMETER (JX=21) COMMON / PRESS / PM(JX), KTOP(JX), ICRITR, MANTHRU C C REAL*8 TIME, XLAT, XLON, ELEV CHARACTER*16 IDATSHO CHARACTER*8 IDSTYP, IDTPRT, ASTA COMMON / CRDADP / IDATSHO, IDSTYP, IDTPRT, ASTA, XLAT, XLON, 2 ELEV, IRTYP, INSTYP, IRC, IYR, IMO, IDY, IHR, TIME, TIME08 C PARAMETER (MX=500) CHARACTER*8 QSHO, D08, A08, M08 COMMON / ARRAYS / P(MX), Z(MX), T(MX), H(MX), D(MX), F(MX), A C(MX), QSHO(MX), D08(MX), A08(MX), M08(MX), IC08(MX), R PMSG, ZMSG, TMSG, HMSG, DMSG, FMSG, CMSG C CHARACTER*8 Q(MX) C SAVE C IF (idump.NE.0) THEN WRITE (LOUT,8998) IPT, NCNT, MAXLEV 8998 FORMAT (1x,'CARADP TOP: ipt, ncnt, maxlev', F 5I10,I10) WRITE (LOUT,8999) IREC, KREP, NU, NA, LTHR, IYR 8999 FORMAT (1x,'CARADP TOP: irec, krep, nu, na, lthr, iyr', F 5I10,I10) ENDIF NTU = NU + 40 NCNT = 0 NLV = 0 2 CONTINUE C C LOOK FOR CATEGORY 06 C IF (NBF(NTU:NTU+7).EQ.EOREP) GO TO 90 READ (NBF(NTU:NTU+6),8005,ERR=95) NCC, NTN, NENT 8005 FORMAT (I2,I3,I2) IF (NTN.LE.0) GO TO 95 IF (NCC.EQ.6) GO TO 3 NTU = NU + (10 * (NTN-1)) GO TO 2 3 CONTINUE 10 CONTINUE NLV = NENT IF (NLV.GT.MLEV) THEN WRITE (LOUT,9010) IREC, KREP, NLV, MLEV 9010 FORMAT (1X,'CARADP: IREC=',I5,', KREP=',I5, F ', TOO MANY LEVELS, NLV',I4,', MLEV',I4) NLV = MLEV ENDIF NTU = NTU + 10 IBEG = IPT IEND = (IPT-1) + NLV DO 30 I = IBEG, IEND READ (NBF(NTU:NTU+21),8030,ERR=95) Z(I), T(I), H(I), D(I), F(I), R Q(I) 8030 FORMAT (F5.0,F4.1,F3.1,2F3.0,A4) P(I) = PMSG C Z(I) = ZMSG C T(I) = TMSG C H(I) = HMSG C D(I) = DMSG C F(I) = FMSG QSHO(I) = ' ' QSHO(I)(1:1) = ' ' ! P QSHO(I)(2:2) = Q(I)(1:1) ! Z QSHO(I)(3:3) = Q(I)(2:2) ! T QSHO(I)(4:4) = Q(I)(3:3) ! H QSHO(I)(5:5) = Q(I)(4:4) ! W QSHO(I)(6:6) = ' ' ! C NTU = NTU + 22 30 CONTINUE 90 CONTINUE IF (idump.NE.0) THEN WRITE (LOUT,9090) P(IPT), Z(IPT), T(IPT), H(IPT), W D(IPT), F(IPT), Q(IPT)(1:6) 9090 FORMAT (1X,'CARADP ',6F8.1,1X,A) ENDIF NCNT = NLV RETURN 95 CONTINUE IF (idump.NE.0) THEN WRITE (LOUT,9095) IREC, KREP, NBF(NTU:NTU+12) 9095 FORMAT (1X,'CARADP: IREC=',I5,', KREP=',I5, F ', DECODE ERROR IN CAT 06 ',A13) ENDIF NCNT = -1 RETURN END SUBROUTINE CLDADP (IREC,KREP,IPT,NCNT,MLEV) C C UNPACK CATEGORY 07 DATA, CLOUD COVER DATA C C LEAVE THE 10000 ALONE, EVEN THOUGH IT IS BIGGER THAN THE ORIGINAL C 6440 LOGICAL RECORD SIZE C CHARACTER NBF*10000 COMMON / ADPB / NBF COMMON / ADPC / LOGREC, NU, NA, LTHR, LOUT, idump, irep, ireplim C CHARACTER*8 EOREP, EOREC, XS, WASH, EOFIL COMMON / ADP / EOREP, EOREC, XS, WASH, EOFIL C PARAMETER (JX=21) COMMON / PRESS / PM(JX), KTOP(JX), ICRITR, MANTHRU C C REAL*8 TIME, XLAT, XLON, ELEV CHARACTER*16 IDATSHO CHARACTER*8 IDSTYP, IDTPRT, ASTA COMMON / CRDADP / IDATSHO, IDSTYP, IDTPRT, ASTA, XLAT, XLON, 2 ELEV, IRTYP, INSTYP, IRC, IYR, IMO, IDY, IHR, TIME, TIME08 C PARAMETER (MX=500) CHARACTER*8 QSHO, D08, A08, M08 COMMON / ARRAYS / P(MX), Z(MX), T(MX), H(MX), D(MX), F(MX), A C(MX), QSHO(MX), D08(MX), A08(MX), M08(MX), IC08(MX), R PMSG, ZMSG, TMSG, HMSG, DMSG, FMSG, CMSG C CHARACTER*8 Q(MX) C SAVE C IF (idump.NE.0) THEN WRITE (LOUT,8998) IPT, NCNT, MAXLEV 8998 FORMAT (1x,'CLDADP TOP: ipt, ncnt, maxlev', F 5I10,I10) WRITE (LOUT,8999) IREC, KREP, NU, NA, LTHR, IYR 8999 FORMAT (1x,'CLDADP TOP: irec, krep, nu, na, lthr, iyr', F 5I10,I10) ENDIF NTU = NU + 40 NCNT = 0 NLV = 0 2 CONTINUE C C LOOK FOR CATEGORY 07 C IF (NBF(NTU:NTU+7).EQ.EOREP) GO TO 90 READ (NBF(NTU:NTU+6),8005,ERR=95) NCC, NTN, NENT 8005 FORMAT (I2,I3,I2) IF (NTN.LE.0) GO TO 95 IF (NCC.EQ.7) GO TO 3 NTU = NU + (10 * (NTN-1)) GO TO 2 3 CONTINUE 10 CONTINUE NLV = NENT IF (NLV.GT.MLEV) THEN WRITE (LOUT,9010) IREC, KREP, NLV, MLEV 9010 FORMAT (1X,'CLDADP: IREC=',I5,', KREP=',I5, F ', TOO MANY LEVELS, NLV',I4,', MLEV',I4) NLV = MLEV ENDIF NTU = NTU + 10 IBEG = IPT IEND = (IPT-1) + NLV DO 30 I = IBEG, IEND READ (NBF(NTU:NTU+9),8030,ERR=95) P(I), C(I), Q(I)(1:2) C 8030 FORMAT (F5.1,I3,A2) C P(I) = PMSG Z(I) = ZMSG T(I) = TMSG H(I) = HMSG D(I) = DMSG F(I) = FMSG QSHO(I) = ' ' QSHO(I)(1:1) = Q(I)(1:1) ! P QSHO(I)(2:2) = ' ' ! Z QSHO(I)(3:3) = ' ' ! T QSHO(I)(4:4) = ' ' ! H QSHO(I)(5:5) = ' ' ! W QSHO(I)(6:6) = Q(I)(2:2) ! C NTU = NTU + 10 30 CONTINUE 90 CONTINUE IF (idump.NE.0) THEN WRITE (LOUT,9090) P(IPT), Z(IPT), T(IPT), H(IPT), W D(IPT), F(IPT), Q(IPT)(1:6) 9090 FORMAT (1X,'CLDADP ',6F8.1,1X,A) ENDIF NCNT = NLV RETURN 95 CONTINUE IF (idump.NE.0) THEN WRITE (LOUT,9095) IREC, KREP, NBF(NTU:NTU+12) 9095 FORMAT (1X,'CLDADP: IREC=',I5,', KREP=',I5, F ', DECODE ERROR IN CAT 07 ',A13) ENDIF NCNT = -1 900 CONTINUE RETURN END SUBROUTINE ADDADP (IREC,KREP,IPT,NCNT,MLEV) C C UNPACK CATEGORY 08 DATA, ADDITIONAL DATA C (FOR THE SUPER INVENTORIES, WE JUST UNPACK THE C 925MB LEVEL IF AVAILABLE, AND THE INSTRUMENT TYPE IF C AVAILABLE) C C LEAVE THE 10000 ALONE, EVEN THOUGH IT IS BIGGER THAN THE ORIGINAL C 6440 LOGICAL RECORD SIZE C CHARACTER NBF*10000 COMMON / ADPB / NBF COMMON / ADPC / LOGREC, NU, NA, LTHR, LOUT, idump, irep, ireplim C CHARACTER*8 EOREP, EOREC, XS, WASH, EOFIL COMMON / ADP / EOREP, EOREC, XS, WASH, EOFIL C PARAMETER (JX=21) COMMON / PRESS / PM(JX), KTOP(JX), ICRITR, MANTHRU C C REAL*8 TIME, XLAT, XLON, ELEV CHARACTER*16 IDATSHO CHARACTER*8 IDSTYP, IDTPRT, ASTA COMMON / CRDADP / IDATSHO, IDSTYP, IDTPRT, ASTA, XLAT, XLON, 2 ELEV, IRTYP, INSTYP, IRC, IYR, IMO, IDY, IHR, TIME, TIME08 C PARAMETER (MX=500) CHARACTER*8 QSHO, D08, A08, M08 COMMON / ARRAYS / P(MX), Z(MX), T(MX), H(MX), D(MX), F(MX), A C(MX), QSHO(MX), D08(MX), A08(MX), M08(MX), IC08(MX), R PMSG, ZMSG, TMSG, HMSG, DMSG, FMSG, CMSG C C C SAVE C IF (idump.NE.0) THEN WRITE (LOUT,8998) IPT, NCNT, MAXLEV 8998 FORMAT (1x,'ADDADP TOP: ipt, ncnt, maxlev', F 5I10,I10) WRITE (LOUT,8999) IREC, KREP, NU, NA, LTHR, IYR 8999 FORMAT (1x,'ADDADP TOP: irec, krep, nu, na, lthr, iyr', F 5I10,I10) ENDIF NTU = NU + 40 NCNT = 0 NLV = 0 IPASS = 0 2 CONTINUE C C LOOK FOR CATEGORY 08 C IF (NBF(NTU:NTU+7).EQ.EOREP) GO TO 90 READ (NBF(NTU:NTU+6),8005,ERR=95) NCC, NTN, NENT 8005 FORMAT (I2,I3,I2) IF (NTN.LE.0) GO TO 95 IF (NCC.EQ.8) GO TO 3 NTU = NU + (10 * (NTN-1)) GO TO 2 3 CONTINUE C NYRMO = 100*IYR + IMO JHR = (IHR + 50) / 100 IDATE = 10000*NYRMO + IDY*100 + JHR ! SYNOPTIC TIME C C DECODE CATEGORY 08, PARTIALLY. C C FROM NCEP'S FINAL VERSION OF ON29: C C NO. OF PARAMETER UNIT C CHARACTERS C 5 DATA GIVEN BY SPECIFICATIONS VARIABLE C IN TABLE 101.1 (SEE NOTE 1) C 3 FORM OF ADDITIONAL DATA IN CODE FIGURE FROM C REPORT (SEE NOTE 2) TABLE 101 C 1 INDICATOR FOR DATA CHARACTER FROM C SPECIFICATION TABLE Q.8 C 1 INDICATOR FOR FORM CHARACTER FROM C OF ADDITIONAL DATA TABLE Q.A C C * - VALUE SET "MISSING" (99999) INDICATES TRANSMITTED AS MISSING. C C WE PARSE TWO THINGS BELOW, FOR DATA IN FORMS 106 AND 925 C C WE LEAVE IT TO THE USER TO DEVELOP THE CODE DO DEAL WITH SPECIFIC C NEEDS - THERE ARE TOO MANY POSSIBILITIES, ALL SUBJECT TO CHANGE, C FOR US TO DEVELOP ALL THE NECESSARY SOFTWARE. C 10 CONTINUE NLV = NENT IF (NLV.GT.MLEV) THEN WRITE (LOUT,9010) IREC, KREP, NLV, MLEV 9010 FORMAT (1X,'ADDADP: IREC=',I5,', KREP=',I5, F ', TOO MANY LEVELS, NLV',I4,', MLEV',I4) NLV = MLEV ENDIF NTU = NTU + 10 IBEG = IPT IEND = (IPT-1) + NLV IGO = IBEG - 1 DO 30 I = IBEG, IEND IGO = IGO + 1 READ (NBF(NTU:NTU+9),8030,ERR=95) D08(I)(1:5), IC08(I), R A08(I)(1:1), M08(I)(1:1) 8030 FORMAT (A5,I3,A1,A1) C P(IGO) = PMSG C Z(IGO) = ZMSG T(IGO) = TMSG H(IGO) = HMSG D(IGO) = DMSG F(IGO) = FMSG 25 CONTINUE IF (IC08(I).EQ.104) THEN C C WATCH FOR SOUNDING RELEASE TIME C READ (D08(I)(1:5),8021,ERR=29) TIME08 ENDIF C IF (IC08(I).EQ.106) THEN C C WATCH FOR INSTRUMENT TYPE C (AND RADIATION CORRECTION AS IN WMO CODE TABLE 3849) C IGO = IGO - 1 IF (IDATE.GE.1991010912) THEN INSTYP = 0 IRC = 0 IF (IDATE.LT.1992010812) THEN READ (D08(I)(1:2),9022,ERR=23) INSTYP 9022 FORMAT (I2) 9021 FORMAT (I1) READ (D08(I)(3:3),9021,ERR=23) IRC ! =0 MEANS NO CORRECTION ENDIF IF (IDATE.GE.1992010812) THEN READ (D08(I)(1:1),9021,ERR=23) IRC ! =0 MEANS NO CORRECTION READ (D08(I)(2:3),9022,ERR=23) INSTYP ENDIF GO TO 29 23 CONTINUE INSTYP = 0 IRC = 0 GO TO 29 ENDIF ENDIF C IF (IC08(I).EQ.925) THEN C C WATCH FOR 925MB LEVEL HEIGHT (TOGETHER WITH 925MB SIGNIFICANT C LEVEL DATA STKADP CAN REASSEMBLE THE NEW 925MB MANDATORY LEVEL) C P(IPT) = 925.0 READ (D08(I)(1:5),8021,ERR=29) Z(IPT) 8021 FORMAT (F5.0) IPASS = 1 IF (IPT.NE.1) THEN ! STKADP SHOULD ALREADY HAVE MANDATORY LEVEL DATA NCNT = IPASS ! PASS JUST THE 925 LEVEL WHEN CALLED BY STKADP GO TO 29 ENDIF ENDIF C QSHO(I) = ' ' QSHO(I)(1:1) = ' ' ! P QSHO(I)(2:2) = ' ' ! Z QSHO(I)(3:3) = ' ' ! T QSHO(I)(4:4) = ' ' ! H QSHO(I)(5:5) = ' ' ! W QSHO(I)(6:6) = ' ' ! C 22 CONTINUE IF (M08(I)(1:1).EQ.' ') M08(I)(1:6) = ' AUTO ' IF (M08(I)(1:1).EQ.'1') M08(I)(1:6) = '1000MB' IF (M08(I)(1:1).EQ.'2') M08(I)(1:6) = ' 850MB' IF (M08(I)(1:1).EQ.'3') M08(I)(1:6) = ' 700MB' IF (M08(I)(1:1).EQ.'4') M08(I)(1:6) = ' 500MB' IF (M08(I)(1:1).EQ.'5') M08(I)(1:6) = ' 600MB' IF (M08(I)(1:1).EQ.'6') M08(I)(1:6) = ' 300MB' IF (M08(I)(1:1).EQ.'7') M08(I)(1:6) = ' 250MB' IF (M08(I)(1:1).EQ.'8') M08(I)(1:6) = ' 200MB' IF (M08(I)(1:1).EQ.'9') M08(I)(1:6) = ' 150MB' IF (M08(I)(1:1).EQ.'A') M08(I)(1:6) = ' 100MB' IF (M08(I)(1:1).EQ.'B') M08(I)(1:6) = ' 70MB' IF (M08(I)(1:1).EQ.'C') M08(I)(1:6) = ' 50MB' IF (M08(I)(1:1).EQ.'D') M08(I)(1:6) = ' 30MB' IF (M08(I)(1:1).EQ.'E') M08(I)(1:6) = ' 20MB' IF (M08(I)(1:1).EQ.'F') M08(I)(1:6) = ' 10MB' IF (M08(I)(1:1).EQ.'$') M08(I)(1:6) = 'MANUAL' 29 CONTINUE NTU = NTU + 10 30 CONTINUE 90 CONTINUE IF (idump.NE.0) THEN WRITE (LOUT,9090) P(IPT), Z(IPT) 9090 FORMAT (1X,'ADDADP P(IPT), Z(IPT)',2F8.1) ENDIF RETURN 95 CONTINUE IF (idump.NE.0) THEN WRITE (LOUT,9095) IREC, KREP, NBF(NTU:NTU+12) 9095 FORMAT (1X,'ADDADP: IREC=',I5,', KREP=',I5, F ', DECODE ERROR IN CAT 08 ',A13) ENDIF NCNT = -1 RETURN END SUBROUTINE DADJUST (IYR,IMO,IDY,IHR,TIME,JYR,JMO,JDY,JHR) C C ADJUST THE REPORT DATE (WHICH COMES FROM THE SYNOPTIC DATE) C SO THAT IT AGREES WITH THE REPORT TIME C C THE RECOMPUTED REPORT DATE WILL BE RETURNED IN THE J VARIABLES C C REPORT TIMES AT 00Z OFTEN DO NOT MATCH THE SYNOPTIC TIME, AND MAY ALSO C CORRESPOND TO THE PREVIOUS OR FOLLOWING DATE, RELATIVE TO THE C SYNOPTIC TIME. EXAMPLES (ALL UTC, ALSO KNOWN AS Z): C C SYNOPTIC REPORT ACTUAL REPORT C DATE/TIME TIME DATE/TIME C (YYMMDDHHHH) HH.HH (YYMMDDHH.HH) C 0003010000 23.03 00022923.03 C 0012311800 02.04 01010102.04 C SAVE C JYR = IYR JMO = IMO JDY = IDY JHR = IHR C C NEED LHR TO BE IN HUNDREDTHS C LHR = 100.* TIME C C WHEN ADJUSTING THE REPORT DATE, WE NEED TO TEST FOR +/- 12 HOURS C AROUND THE SYNOPTIC HOUR, AND WE MUST MAKE THE TESTS WORK SO C AS TO CONFORM TO THE FACT THAT 0000 (SOMETIMES 2400) BELONGS C TO THE SAME DAY AS 0001. C IADJDY = 0 IF (IHR.EQ. 0.AND.LHR.GE.1200) IADJDY = -1 IF (IHR.EQ. 300.AND.LHR.GE.1500) IADJDY = -1 IF (IHR.EQ. 600.AND.LHR.GE.1800) IADJDY = -1 IF (IHR.EQ. 900.AND.LHR.GE.2100) IADJDY = -1 C IF (IHR.EQ.1200.AND.LHR.GE. 0) IADJDY = 0 ! WILL ALWAYS BE SAME DAY... IF (IHR.EQ.1500.AND.LHR.LT. 300) IADJDY = 1 IF (IHR.EQ.1800.AND.LHR.LT. 600) IADJDY = 1 IF (IHR.EQ.2100.AND.LHR.LT. 900) IADJDY = 1 C IF (IADJDY.NE.0) THEN JDY = JDY + IADJDY ! ADJUST DAY AS NEEDED IF (IADJDY.EQ.-1) THEN IF (JDY.LT.1) THEN JMO = JMO - 1 IF (JMO.LT.1) THEN JMO = 12 JYR = JYR - 1 IF (JYR.LT.0) THEN JYR = 99 ENDIF ENDIF JDY = 30 IF (JMO.EQ.2) THEN JDY = 28 IF (MOD(JYR,4).EQ.0) JDY = 29 ENDIF IF (JMO.EQ. 1.OR.JMO.EQ. 3.OR.JMO.EQ. 5.OR.JMO.EQ. 7 I .OR.JMO.EQ. 8.OR.JMO.EQ.10.OR.JMO.EQ.12) JDY = 31 ENDIF ELSE KDY = 30 IF (JMO.EQ.2) THEN KDY = 28 IF (MOD(JYR,4).EQ.0) KDY = 29 ENDIF IF (JMO.EQ. 1.OR.JMO.EQ. 3.OR.JMO.EQ. 5.OR.JMO.EQ. 7 I .OR.JMO.EQ. 8.OR.JMO.EQ.10.OR.JMO.EQ.12) KDY = 31 IF (JDY.GT.KDY) THEN JDY = 1 JMO = JMO + 1 IF (JMO.GT.12) THEN JMO = 1 JYR = JYR + 1 IF (JYR.GT.99) THEN JYR = 0 ENDIF ENDIF ENDIF ENDIF ENDIF RETURN END SUBROUTINE LLDIST (XLAT,XLON,YLAT,YLON,DIST) C C COMPUTES DISTANCE (KM) BETWEEN TWO LATITUDE-LONGITUDE POINTS ALONG C A GREAT CIRCLE. C C FROM DENNIS JOSEPH - 2002JAN C DATA R, DRAD / 6371.2277, 0.0174533/ C SAVE C DLON = ABS(XLON - YLON) IF (DLON.GT.180.) DLON = 360. - DLON DL = DLON * DRAD XL = (XLAT + 90.) * DRAD YL = (YLAT + 90.) * DRAD DIST = R * ABS(ACOS(COS(XL)*COS(YL) + SIN(XL)*SIN(YL)*COS(DL))) RETURN END SUBROUTINE STDZ2P (P,H1,L,TCENT,RHO) C C COMPUTES PRESSURE, TEMPERATURE, AND DENSITY VALUES FROM INPUT HEIGHTS C BASED ON US STANDARD ATMOSPHERE, 1976 C VALUES NOT VALID ABOVE 84852 KM. C C PROCEDURE IS NOT APPROPRIATE FOR ARBITRARY LOCATION AND DATE C C INPUT C H1 - HEIGHT IN FEET OR METERS C L - UNITS FLAG - 0=METERS, 1=FEET C OUTPUT C P - PRESSURE IN MB C TCENT - TEMPERATURE IN DEG C C RHO - DENSITY IN KG/M3 C DIMENSION HBASE(10),HTOP(10),TB(10),GRAD(10),ABS(10) DIMENSION PB(11),RB(10) DATA HBASE/ 0.,1.1E4,2.E4,3.2E4,4.7E4,5.1E4,7.1E4,3*84852.0/ DATA HTOP /1.1E4,2.E4,3.2E4,4.7E4,5.1E4,7.1E4,4*84852.0/ DATA TB / 15.,2*-56.5,-44.5,2*-2.5,-58.5,3*-86.2/ DATA GRAD/-.0065,0.,.001,.0028,0.,-.0028,-.002,3*0./ DATA CHECK/0./ C SAVE C C H1 IS ALTITUDE, IF IN METERS SET L .LE. 0. IF IN FEET SET L .GE. 1 C P IS PRESSURE IN MB. TCENT IS TEMP CELSIUS. RHO IS DENSITY IN KG/M**3 C IF(CHECK.NE.0.) GO TO 16 ABSZ = 273.15 PZERO=1013.250 G=980.665 R = 83143200./28.9644 PB(1) = PZERO DO 3 I=1,8 ABS(I) = TB(I) + ABSZ 3 CONTINUE DO 15 I=1,8 IF (GRAD(I) .EQ. 0) GO TO 10 C HERE FOR TEMP GRADIENT NOT ZERO 5 PB(I+1) = PB(I)*((ABS(I+1)/ABS(I))**(100.*G/(-GRAD(I)*R))) GO TO 12 C HERE FOR TEMP GRADIENT ZERO 10 PB(I+1) = PB(I)*2.7182818**((-100.*G/(R*ABS(I)))*(HTOP(I)-HBASE(I) X )) 12 RB(I) = 1000.*PB(I)/(R*ABS(I)) * 1000. 15 CONTINUE CHECK=10. 16 CONTINUE C IF(L. LT.1) GO TO 30 C H = H1*.3048 GO TO 4 30 H = H1 C C *** WE ARE USING THIS IN SUPPORT OF THE SUPER INVENTORIES. C *** IT IS A CONVOLUTED MEASURE TO PREVENT PUTTING A C *** NON-SURFACE AS A SURFACE RECORD C *** G. WALTERS, 2001AUG C IF (H.LT.0) H = 0 IF (H.GT.4700) H = 4700 C 4 CONTINUE C FIND THE ATMOSPHERIC LAYER WE ARE IN 35 DO 55 I = 1,8 IF (H .GT. HBASE(I+1)) GO TO 55 37 IF (GRAD(I)) 39,43,39 C TEMP GRADIENT NOT ZERO 39 P= PB(I)*((H-HBASE(I))*GRAD(I)/ABS(I)+1)**(-100.*G/(GRAD(I)*R)) GO TO 45 C ISOTHERMAL LAYER 43 P= PB(I)*EXP((H-HBASE(I))*(-G)/(.01*R*ABS(I))) 45 T = ABS(I) + GRAD(I)*(H-HBASE(I)) TCENT = T - ABSZ RHO = 1.E6* P/(R*T) RETURN 55 CONTINUE 56 WRITE(6,98)H 98 FORMAT(' STDZ2P - ALTITUDE OUT OF RANGE ',F12.2,//) END SUBROUTINE USAFDIC (STATID,NAMEDIC) C C LOOKUP STATION NAME IN USAF STATION DICTIONARY C CHARACTER*5 STATID CHARACTER*6 LOOKUP CHARACTER*8 FNAMI, FILE CHARACTER*32 FMT, FORM, STAT, STATUS CHARACTER ENTRY*256 CHARACTER NAMEDIC*26 C LOOKUP(01:05) = STATID(01:05) LOOKUP(06:06) = '0' NAMEDIC(01:26) = ' ' IUN = 99 FNAMI = 'usafdict' FMT = 'FORMATTED' STAT = 'OLD' OPEN (IUN,FILE=FNAMI,FORM=FMT,STATUS=STAT) C IF (ERR.NE.0) RETURN 10 CONTINUE READ (IUN,9010,END=90) ENTRY 9010 FORMAT (A) IF (ENTRY(01:06).NE.LOOKUP(01:06)) GO TO 80 C C WMO NUMBER MATCH C NAMEDIC(01:20) = ENTRY(16:35) NAMEDIC(21:21) = ' ' NAMEDIC(22:26) = ENTRY(54:58) GO TO 90 80 CONTINUE IF (ENTRY(08:11).NE.LOOKUP(01:04)) GO TO 10 C C CALL SIGN MATCH C NAMEDIC(01:20) = ENTRY(16:35) NAMEDIC(21:21) = ' ' NAMEDIC(22:26) = ENTRY(54:58) 90 CONTINUE CLOSE (IUN) RETURN END