SUBROUTINE W3FI81(IUNIT0,IUNIT1,IUNIT2,IUBTBL,IUDTBL,IBUFTN,IERR) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: W3FI81 READS 3 BUFR RTRVL FILES, REFORMATS DATA C PRGMMR: BERT B. KATZ ORG: W/NMC23 DATE: 93-06-09 C GENERAL C SCIENCES CORP. C C ABSTRACT: READS AND UNPACKS THREE BUFR INTERACTIVE RETRIEVAL FILES : C (1) TOVS 40-LEVEL AND RADIANCE DATA, (2) INTERACTIVE RETRIEVALS, AND C (3) ANALYSIS INTERPOLATION. THE NECESSARY QUANTITIES ARE REARRANGED C INTO THE FORMAT OF A NESDIS FORMATTED FILE, IN INTEGERS THE SIZE C OF THE MACHINE'S WORD LENGTH. C C PROGRAM HISTORY LOG: C 93-06-09 BERT B. KATZ C 93-09-08 BERT B. KATZ -- SUPPLIED MISSING ANALYZED SURFACE PRESSURE C FIELD AND ADDED "STABILITY DEPARTURE" C QUANTITIES AS PER NESDIS REQUEST. C 93-10-22 BERT B. KATZ -- CHANGED UNIVERSAL BUFR DESCRIPTOR 2080 C TO LOCAL BUFR DESCRIPTOR 2280. C 95-05-11 BERT B. KATZ -- CHANGED TO ALLOW PROCESSING OF RETRIEVALS C FROM NOAA-14. C C C USAGE : CALL W3FI81(IUNIT0,IUNIT1,IUNIT2,IUBTBL,IUDTBL,IBUFTN,IERR) C INPUT ARGUMENT LIST: C IUNIT0 - UNIT NUMBER OF INPUT FILE CONTAINING TOVS 40-LEVEL C - RETRIEVALS AND RADIANCES IN BUFR FORMAT. C IUNIT1 - UNIT NUMBER OF INPUT FILE CONTAINING INTERACTIVE C - RETRIEVALS IN BUFR FORMAT. C IUNIT2 - UNIT NUMBER OF INPUT FILE CONTAINING ANALYSIS C - INTERPOLATION DATA IN BUFR FORMAT. C IUBTBL - UNIT NUMBER OF INPUT FILE CONTAINING BUFR TABLE B. C IUDTBL - UNIT NUMBER OF INPUT FILE CONTAINING BUFR TABLE D. C C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) C IBUFTN - CONTAINS THE CONTENTS OF A RECORD IN A NESDIS C - FORMAT IN MACHINE WORD LENGTH INTEGERS. C IERR - ERROR RETURN CODE (= 0 FOR NORMAL COMPLETION) C - (= 3 FOR NORMAL END-OF-FILE ON ALL THREE FILES) C - (= 1111 FOR BUFR DECODING ERROR ON TOVS 40-LEVEL FILE) C - (= 2222 FOR BUFR DECODING ERROR ON TOVS 40-LEVEL FILE) C - (= 3333 FOR BUFR DECODING ERROR ON TOVS 40-LEVEL FILE) C - (= 4444 FOR BUFR DECODING ERROR ON INTER. RTRVL. FILE) C - (= 5555 FOR BUFR DECODING ERROR ON INTER. RTRVL. FILE) C - (= 6666 FOR BUFR DECODING ERROR ON INTER. RTRVL. FILE) C - (= 7777 FOR BUFR DECODING ERROR ON ANALY. INTERP. FILE) C - (= 8888 FOR BUFR DECODING ERROR ON ANALY. INTERP. FILE) C - (=55555 FOR DATA MISMATCH BETWEEN THE THREE FILES) C - (=66666 FOR DATA MISMATCH BETWEEN THE THREE FILES) C - (=77777 FOR DATA MISMATCH BETWEEN THE THREE FILES) C - (=88888 FOR DATA MISMATCH BETWEEN THE THREE FILES) C - (=99999 FOR DATA MISMATCH BETWEEN THE THREE FILES) C C INPUT FILES: C FT(IUNIT0)F001 C - FILE CONTAINING TOVS 40-LEVEL RETRIEVAL AND RADIANCE C - DATA IN BUFR FORM. C FT(IUNIT1)F001 C - FILE CONTAINING INTERACTIVE RETRIEVAL DATA IN C - BUFR FORM. C FT(IUNIT2)F001 C - FILE CONTAINING ANALYSIS INTERPOLATION DATA IN C - BUFR FORM. C FT(IUBTBL)F001 C - FILE CONTAINING BUFR TABLE B. C FT(IUDTBL)F001 C - FILE CONTAINING BUFR TABLE D. C C REMARKS: CALLS SUBROUTINE W3FI78 TO UNPACK BUFR DATA. C CALLS SUBROUTINE FI8101 TO FILL COMMON BLOCK /FI80TV/ WITH C LOCATION AND SCALING OF 40-LEVEL TOVS RETRIEVALS. C CALLS SUBROUTINE FI8102 TO FILL COMMON BLOCK /FI80IA/ WITH C LOCATION AND SCALING OF INTERACTIVE RETRIEVALS. C CALLS SUBROUTINE FI8103 TO FILL COMMON BLOCK /FI80AN/ WITH C LOCATION AND SCALING OF ANALYSIS INTERPOLATION DATA. C CALLS SUBROUTINE FI8104 TO INTERPOLATE MODEL TEMPERATURES C AND MIXING RATIOS TO TOVS 40 PRESSURE LEVELS. C CALLS SUBROUTINE FI8105 TO GENERATE GEOPOTENTIAL HEIGHTS C HYDROSTATICALLY FROM TEMPERATURES AND MIXING RATIOS C INTERPOLATED FROM MODEL TO TOVS LEVELS IN SUBROUTINE C FI8105. C CALL SUBROUTINE FI8106 TO CALCULATE STABILITY DEPARTURES C BETWEEN TOVS OPERATIONAL RETRIEVAL AND THE MODEL FIRST GUESS C FOR 1000 MB - 700 MB LAYER AND 500 MB - 300 MB LAYER. C C ATTRIBUTES: C LANGUAGE: VS FORTRAN, CFT77 C MACHINE: HDS OR CRAY C C$$$ C PARAMETER (MXIRPT=50,MXIDSC=420) PARAMETER (MXRPTR=30,MXDSCR=700) PARAMETER (MXRPTA=100,MXDSCA=200) PARAMETER (NMLO=28) PARAMETER (NML=70,NUL=39) SAVE IFIRST,INDEX0,INDEX1,INDEX2,IPTR0,IPTR1,IPTR2, 1 IDENT0,IDENT1,IDENT2,KDATA0,KDATA1,KDATA2,IENFIL REAL GEOOPR(40),TGES40(40),WGES40(40),GEOGES(40) REAL TGES(NMLO),WGES(NMLO),PGES(NMLO) INTEGER IPTR0(40) INTEGER IDENT0(20) INTEGER ISTCK0(MXIDSC) INTEGER MSTCK0(2,MXIDSC) INTEGER KDATA0(MXIRPT,MXIDSC) INTEGER KNR0(MXIRPT) INTEGER IPTR1(40) INTEGER IDENT1(20) INTEGER ISTCK1(MXDSCR) INTEGER MSTCK1(2,MXDSCR) INTEGER KDATA1(MXRPTR,MXDSCR) INTEGER KNR1(MXRPTR) INTEGER IPTR2(40) INTEGER IDENT2(20) INTEGER ISTCK2(MXDSCA) INTEGER MSTCK2(2,MXDSCA) INTEGER KDATA2(MXRPTA,MXDSCA) INTEGER KNR2(MXRPTA) INTEGER INDEX0,INDEX1,INDEX2 INTEGER IFIRST C C INTEGER IBUFTN(720) INTEGER MSGA(2500) CHARACTER*1 CMSGA(10000) EQUIVALENCE (MSGA(1),CMSGA(1)) C C COMMON /FI81TV/ LCSTII, LCSSBC, LCMBBX, 1 LCINSI, LCRTMI, LCFLFI, 2 LCYRI , LCMONI, LCDAYI, 3 LCHRI , LCMINI, LCSECI, 4 LCLSI , LCNDI , LCFGAP, 5 LCDVHI, LCDVMI, LCDVSI, 6 LCNMCI, LWNMCI, LCRTPI, 7 LCLATI, IXLATI, LCLONI, IXLONI, 8 LCSTUI, LCSSTA, LCST15, IXST15, 9 LCSZAN, IXSZAN, LCLSZA, IXLSZA, A LCSALB, IXSALB, LCSKNI, IXSKNI, B LCH8FI, LCPLSI, IXPLSI, LCSFHI, IXSFHI, C LCICOI, LCOZON, IXOZON, LCAVNS, IXAVNS, D LCICTI, LCPTRI, IXPTRI, LCTTRI, IXTTRI COMMON /FI81TV/ LCP40I(40), IXP40I(40), 1 LCT40I(40), IXT40I(40), 2 LCH40I(40), IXH40I(40), 3 LCM40I(40), IXM40I(40), 4 LCP4GI(40), IXP4GI(40), 5 LCT4GI(40), IXT4GI(40), 6 LCM4GI(40), IXM4GI(40), 7 LCRADI(27), IXRADI(27), 8 LCRDGI(27), IXRDGI(27) COMMON /FI81IA/ LCSTIR , LCLSR , LCNDR , 1 LCNMCR , LWNMCR , LCFCYC , 2 LCINSR , LCRTMR , LCRTPR , 3 LCDVHR , LCDVMR , LCDVSR , 4 LCSTUR , LCICOR , LCFLFR , 5 LCLATR , IXLATR , 6 LCLONR , IXLONR , 7 LCPTRR , IXPTRR , 8 LCTTRR , IXTTRR , LCICTR , 9 LCSKNT , IXSKNT , A LCPLSR , IXPLSR , B LCSFHF , IXSFHF , C LCPSFF , IXPSFF , D LCSKNF , IXSKNF , E LCSKNR , IXSKNR , LCH8FR COMMON /FI81IA/ LCRADF(27) , IXRADF(27) , 1 LCRDFC(27) , IXRDFC(27) , 2 LCSIGI(NMLO), IXSIGI(NMLO), 3 LCTMPI(NMLO), IXTMPI(NMLO), 4 LCRADR(27) , IXRADR(27) , 5 LCRDRC(27) , IXRDRC(27) , 6 LCSIGF(NMLO), IXSIGF(NMLO), 7 LCTMPF(NMLO), IXTMPF(NMLO), 8 LCMIXF(NMLO), IXMIXF(NMLO), 9 LCSIGR(NML) , IXSIGR(NML) , A LCTMPR(NML) , IXTMPR(NML) , B LCMIXR(NML) , IXMIXR(NML) , C LCP41I , IXP41I , D LCT41I , IXT41I , E LCM41I , IXM41I COMMON /FI81AN/ LCSTIA , LCYRA , LCMONA , 1 LCDAYA , LCHRA , LCMINA , 2 LCLATA , IXLATA , 3 LCLONA , IXLONA , 4 LCPSFA , IXPSFA , 5 LCSFHA , IXSFHA , 6 LCNMCA , LWNMCA , 7 LCSIGA(NMLO), IXSIGA(NMLO), 8 LCTMPA(NMLO), IXTMPA(NMLO), 9 LCMIXA(NMLO), IXMIXA(NMLO), A LCRADA(27) , IXRADA(27) , B LCRDAC(27) , IXRDAC(27) C REAL TENS(-75:75) REAL PTOVS(41) INTEGER IDXHGT(18) DATA (TENS(I),I=-75,-1,+1) 1 /1.0E-75,1.0E-74,1.0E-73,1.0E-72,1.0E-71,1.0E-70,1.0E-69,1.0E-68, 2 1.0E-67,1.0E-66,1.0E-65,1.0E-64,1.0E-63,1.0E-62,1.0E-61,1.0E-60, 3 1.0E-59,1.0E-58,1.0E-57,1.0E-56,1.0E-55,1.0E-54,1.0E-53,1.0E-52, 4 1.0E-51,1.0E-50,1.0E-49,1.0E-48,1.0E-47,1.0E-46,1.0E-45,1.0E-44, 5 1.0E-43,1.0E-42,1.0E-41,1.0E-40,1.0E-39,1.0E-38,1.0E-37,1.0E-36, 6 1.0E-35,1.0E-34,1.0E-33,1.0E-32,1.0E-31,1.0E-30,1.0E-29,1.0E-28, 7 1.0E-27,1.0E-26,1.0E-25,1.0E-24,1.0E-23,1.0E-22,1.0E-21,1.0E-20, 8 1.0E-19,1.0E-18,1.0E-17,1.0E-16,1.0E-15,1.0E-14,1.0E-13,1.0E-12, 9 1.0E-11,1.0E-10,1.0E-09,1.0E-08,1.0E-07,1.0E-06,1.0E-05,1.0E-04, A 1.0E-03,1.0E-02,1.0E-01/ DATA (TENS(I),I=75,0,-1) 1 /1.0E+75,1.0E+74,1.0E+73,1.0E+72,1.0E+71,1.0E+70,1.0E+69,1.0E+68, 2 1.0E+67,1.0E+66,1.0E+65,1.0E+64,1.0E+63,1.0E+62,1.0E+61,1.0E+60, 3 1.0E+59,1.0E+58,1.0E+57,1.0E+56,1.0E+55,1.0E+54,1.0E+53,1.0E+52, 4 1.0E+51,1.0E+50,1.0E+49,1.0E+48,1.0E+47,1.0E+46,1.0E+45,1.0E+44, 5 1.0E+43,1.0E+42,1.0E+41,1.0E+40,1.0E+39,1.0E+38,1.0E+37,1.0E+36, 6 1.0E+35,1.0E+34,1.0E+33,1.0E+32,1.0E+31,1.0E+30,1.0E+29,1.0E+28, 7 1.0E+27,1.0E+26,1.0E+25,1.0E+24,1.0E+23,1.0E+22,1.0E+21,1.0E+20, 8 1.0E+19,1.0E+18,1.0E+17,1.0E+16,1.0E+15,1.0E+14,1.0E+13,1.0E+12, 9 1.0E+11,1.0E+10,1.0E+09,1.0E+08,1.0E+07,1.0E+06,1.0E+05,1.0E+04, A 1.0E+03,1.0E+02,1.0E+01,1.0 / DATA PTOVS/0.1,0.2,0.5,1.,1.5,2.,3., 1 4.,5.,7.,10.,15.,20.,25.,30., 2 50.,60.,70.,85.,100.,115.,135., 3 150.,200.,250.,300.,350.,400., 4 430.,475.,500.,570.,620.,670., 5 700.,780.,850.,920.,950.,1000.,1070./ DATA IDXHGT/4,7,10,11,13,15,16,18,20,23,24,25,26,28,31,35,37,40/ C DATA IFIRST/0/ C C READ IN AND DECODE BUFR MESSAGE C IF(IFIRST.EQ.0) THEN IENFIL = 0 INDEX0 = 0 INDEX1 = 0 INDEX2 = 0 ENDIF IF(INDEX0.EQ.0) THEN DO 2 I=1,40 IPTR0(I) = 0 2 CONTINUE DO 4 I=1,20 IDENT0(I) = 0 4 CONTINUE READ(IUNIT0,END=9970) CMSGA REWIND IUBTBL REWIND IUDTBL ENDIF C 1000 CONTINUE CALL W3FI78(IPTR0,IDENT0,MSGA,ISTCK0,MSTCK0,KDATA0,KNR0,INDEX0, 1 MXIRPT,MXIDSC,IUBTBL,IUDTBL) IF(IPTR0(1).EQ.99) THEN INDEX0 = 0 READ(IUNIT0,END=9970) CMSGA GO TO 1000 ENDIF C C CHECK FOR BUFR DECODING ERROR C IF(INDEX0.EQ.1) THEN IF(IPTR0(1).NE.0) THEN IERR = 1111 RETURN ENDIF C C CHECK FOR DELAYED REPLICATION C IF(IPTR0(39).NE.0) THEN IERR = 2222 RETURN ENDIF NRPTS = IDENT0(14) NDESC = IPTR0(31) C C CHECK FOR NON-UNIFORM REPORTS C DO 10 I = 1 , NRPTS IF(KNR0(I).NE.NDESC) THEN IERR = 3333 RETURN ENDIF 10 CONTINUE NDESC = IPTR0(31) + IPTR0(24) ENDIF C IF(IFIRST.EQ.0) THEN CALL FI8101(MSTCK0,KDATA0,NDESC) ENDIF IF(INDEX1.EQ.0) THEN DO 12 I=1,40 IPTR1(I) = 0 12 CONTINUE DO 14 I=1,20 IDENT1(I) = 0 14 CONTINUE READ(IUNIT1,END=9980) CMSGA REWIND IUBTBL REWIND IUDTBL ENDIF C 1100 CONTINUE CALL W3FI78(IPTR1,IDENT1,MSGA,ISTCK1,MSTCK1,KDATA1,KNR1,INDEX1, 1 MXRPTR,MXDSCR,IUBTBL,IUDTBL) IF(IPTR1(1).EQ.99) THEN INDEX1 = 0 READ(IUNIT1,END=9980) CMSGA GO TO 1100 ENDIF C C CHECK FOR BUFR DECODING ERROR C IF(INDEX1.EQ.1) THEN IF(IPTR1(1).NE.0) THEN IERR = 4444 RETURN ENDIF C C CHECK FOR DELAYED REPLICATION C IF(IPTR1(39).NE.0) THEN IERR = 5555 RETURN ENDIF NRPTS = IDENT1(14) NDESC = IPTR1(31) C C CHECK FOR NON-UNIFORM REPORTS C DO 20 I = 1 , NRPTS IF(KNR1(I).NE.NDESC) THEN IERR = 6666 RETURN ENDIF 20 CONTINUE NDESC = IPTR1(31) + IPTR1(24) ENDIF C IF(IFIRST.EQ.0) THEN CALL FI8102(MSTCK1,KDATA1,NDESC) ENDIF IF(INDEX2.EQ.0) THEN DO 22 I=1,40 IPTR2(I) = 0 22 CONTINUE DO 24 I=1,20 IDENT2(I) = 0 24 CONTINUE READ(IUNIT2,END=9990) CMSGA REWIND IUBTBL REWIND IUDTBL ENDIF C 1200 CONTINUE CALL W3FI78(IPTR2,IDENT2,MSGA,ISTCK2,MSTCK2,KDATA2,KNR2,INDEX2, 1 MXRPTA,MXDSCA,IUBTBL,IUDTBL) IF(IPTR2(1).EQ.99) THEN INDEX2 = 0 READ(IUNIT2,END=9990) CMSGA GO TO 1200 ENDIF C C CHECK FOR BUFR DECODING ERROR C IF(INDEX2.EQ.1) THEN IF(IPTR2(1).NE.0) THEN IERR = 7777 RETURN ENDIF C C CHECK FOR DELAYED REPLICATION C IF(IPTR2(39).NE.0) THEN IERR = 8888 RETURN ENDIF NRPTS = IDENT2(14) NDESC = IPTR2(31) C C CHECK FOR NON-UNIFORM REPORTS C DO 30 I = 1 , NRPTS IF(KNR2(I).NE.NDESC) THEN IERR = 9999 RETURN ENDIF 30 CONTINUE NDESC = IPTR2(31) + IPTR2(24) ENDIF C IF(IFIRST.EQ.0) THEN CALL FI8103(MSTCK2,KDATA2,NDESC) IFIRST = 1 ENDIF C IF(LWNMCI.EQ.LWNMCR .AND. LWNMCR.EQ.LWNMCA) THEN DO 1250 K = 1 , LWNMCR IF(KDATA0(INDEX0,LCNMCI+K-1).NE.KDATA1(INDEX1,LCNMCR+K-1) .OR. 1 KDATA1(INDEX1,LCNMCR+K-1).NE.KDATA2(INDEX2,LCNMCA+K-1)) 2 THEN IERR = 99999 RETURN ENDIF 1250 CONTINUE ELSE IERR = 99999 RETURN ENDIF IF(KDATA0(INDEX0,LCLATI).NE.KDATA1(INDEX1,LCLATR) .OR. 1 KDATA1(INDEX1,LCLATR).NE.KDATA2(INDEX2,LCLATA) .OR. 2 IXLATI.NE.IXLATR .OR. IXLATR.NE.IXLATA) THEN IERR = 88888 RETURN ENDIF IF(KDATA0(INDEX0,LCLONI).NE.KDATA1(INDEX1,LCLONR) .OR. 1 KDATA1(INDEX1,LCLONR).NE.KDATA2(INDEX2,LCLONA) .OR. 2 IXLONI.NE.IXLONR .OR. IXLONR.NE.IXLONA) THEN IERR = 77777 RETURN ENDIF IF(KDATA0(INDEX0,LCSTII).NE.KDATA1(INDEX1,LCSTIR) .OR. 1 KDATA1(INDEX1,LCSTIR).NE.KDATA2(INDEX2,LCSTIA)) THEN IERR = 66666 RETURN ENDIF DO 1300 K = 1 , NMLO IF(KDATA1(INDEX1,LCSIGF(K)).NE.KDATA2(INDEX2,LCSIGA(K)) .OR. 1 IXSIGF(K).NE.IXSIGA(K)) THEN IERR = 55555 RETURN ENDIF 1300 CONTINUE ISSBCT = KDATA0(INDEX0,LCSSBC) IBUFTN(1) = ISSBCT / 1000 ISATID = KDATA0(INDEX0,LCSTII) IF(ISATID.EQ.203) THEN IBUFTN(2) = 1 IBUFTN(3) = 1 ELSE IF(ISATID.EQ.204) THEN IBUFTN(2) = 2 IBUFTN(3) = 2 ELSE IF(ISATID.EQ.205) THEN IBUFTN(2) = 3 IBUFTN(3) = 3 ENDIF IBUFTN(12) = MOD(ISSBCT,1000) IBUFTN(13) = KDATA0(INDEX0,LCMBBX) XLAT = KDATA0(INDEX0,LCLATI) * TENS(IXLATI) IBUFTN(14) = 128.0 * XLAT + SIGN(0.5,XLAT) IF(XLAT.GE.60.0) THEN LATZON = 1 ELSE IF(XLAT.GE.45.0) THEN LATZON = 2 ELSE IF(XLAT.GE.30.0) THEN LATZON = 3 ELSE IF(XLAT.GE.15.0) THEN LATZON = 4 ELSE IF(XLAT.GT.-15.0) THEN LATZON = 5 ELSE IF(XLAT.GT.-30.0) THEN LATZON = 6 ELSE IF(XLAT.GT.-45.0) THEN LATZON = 7 ELSE IF(XLAT.GT.-60.0) THEN LATZON = 8 ELSE LATZON = 9 ENDIF XLON = KDATA0(INDEX0,LCLONI) * TENS(IXLONI) IBUFTN(15) = 128.0 * XLON + SIGN(0.5,XLON) IYR = MOD(KDATA0(INDEX0,LCYRI),100) IBUFTN(16) = 100 * IYR + KDATA0(INDEX0,LCMONI) IBUFTN(17) = 100 * KDATA0(INDEX0,LCDAYI) + KDATA0(INDEX0,LCHRI) IBUFTN(18) = 100 * KDATA0(INDEX0,LCMINI) + KDATA0(INDEX0,LCSECI) INSTRU = KDATA0(INDEX0,LCINSI) IRETMT = KDATA0(INDEX0,LCRTMI) IF(MOD(INSTRU,128).GE.64) THEN ISSUFL = 1 ELSE ISSUFL = 0 ENDIF IF(INSTRU.GE.256) THEN IF(INSTRU.GE.384) THEN MCL3 = 1 ELSE MCL3 = 2 ENDIF IF(MOD(IRETMT,64).GE.32) THEN MCL1 = 1 MCL2 = 1 ICLOUD = 110 + MCL3 ELSE IF(MOD(IRETMT,64).GE.16) THEN MCL1 = 2 MCL2 = 1 ICLOUD = 210 + MCL3 ELSE IF(MOD(IRETMT,64).GE.8) THEN MCL1 = 2 MCL2 = 2 ICLOUD = 220 + MCL3 ENDIF ELSE IF(INSTRU.GE.128) THEN MCL1 = 0 MCL2 = 0 ICLOUD = 3 ENDIF IF(INSTRU.EQ.448) THEN ICCFLG = 1 ELSE IF(INSTRU.EQ.384) THEN ICCFLG = 2 ELSE IF(INSTRU.EQ.256) THEN ICCFLG = 3 ELSE IF(INSTRU.EQ.320) THEN ICCFLG = 4 ELSE IF(INSTRU.EQ.128) THEN ICCFLG = 5 ELSE IF(INSTRU.EQ.192) THEN ICCFLG = 6 ELSE IF(INSTRU.EQ.64) THEN ICCFLG = 7 ENDIF IF(IRETMT.GE.64) THEN METRET = 0 ELSE IF(MOD(IRETMT,8).GE.4) THEN METRET = 1 ENDIF PLST = 0.01 * KDATA0(INDEX0,LCPLSI) * TENS(IXPLSI) DO 1500 L=1,40 IF(ABS(PLST - PTOVS(L)).LT.0.1) LSTOVS = L 1500 CONTINUE LNDSEA = KDATA0(INDEX0,LCLSI) NGTDAY = KDATA0(INDEX0,LCNDI) IBUFTN(19) = 10000 * LNDSEA + 1 1000 * NGTDAY + 2 100 * METRET + 3 LSTOVS IF(KDATA0(INDEX0,LCICOI).EQ.20480) THEN ICCO3 = 1 ELSE IF(KDATA0(INDEX0,LCICOI).EQ.16384) THEN ICCO3 = 2 ELSE IF(KDATA0(INDEX0,LCICOI).EQ.12288) THEN ICCO3 = 3 ELSE IF(KDATA0(INDEX0,LCICOI).EQ.8192) THEN ICCO3 = 4 ELSE IF(KDATA0(INDEX0,LCICOI).EQ.0) THEN ICCO3 = 0 ENDIF IF(KDATA0(INDEX0,LCICTI).EQ.262144) THEN ICTROP = 1 ELSE IF(KDATA0(INDEX0,LCICTI).EQ.131072) THEN ICTROP = 2 ENDIF IF(METRET.EQ.0) THEN ICCMVS = 0 ELSE IF(ICCFLG.LE.3) THEN IF(MCL1.GE.1 .AND. MCL2.EQ.1) THEN ICCMVS = 1 ELSE IF(MCL1.EQ.2 .AND. MCL2.EQ.2) THEN IF(LNDSEA.EQ.1) THEN ICCMVS = 2 ELSE ICCMVS = 3 ENDIF ENDIF ELSE IF(ICCFLG.GE.5) THEN IF(LNDSEA.EQ.1) THEN ICCMVS = 4 ELSE ICCMVS = 5 ENDIF ELSE ICCMVS = 6 ENDIF IBUFTN(20) = 10000 * KDATA0(INDEX0,LCSTUI) + 1 100 * ICCMVS + 2 10 * ICCO3 + 3 ICTROP IBUFTN(21) = 1000 * KDATA0(INDEX0,LCH8FI) + 1 100 * ISSUFL + 2 10 * LATZON + 3 ICCFLG IBUFTN(22) = ICLOUD IF(LNDSEA.EQ.0) THEN IPBIN = LATZON ELSE IF(NGTDAY.EQ.1) THEN IPBIN = LATZON + 9 ELSE IPBIN = LATZON + 18 ENDIF IBUFTN(23) = 10000 * KDATA0(INDEX0,LCSSTA) + 1 1000 * KDATA0(INDEX0,LCFGAP) + 2 10 * IPBIN + 3 KDATA0(INDEX0,LCFLFI) SZANG = KDATA0(INDEX0,LCSZAN) * TENS(IXSZAN) IBUFTN(24) = 128.0 * SZANG + SIGN(0.5,SZANG) SZALO = KDATA0(INDEX0,LCLSZA) * TENS(IXLSZA) IBUFTN(25) = 128.0 * SZALO + SIGN(0.5,SZALO) DO 1600 L = 1 , 40 TEMP = KDATA0(INDEX0,LCT40I(L)) * TENS(IXT40I(L)) IBUFTN(L+25) = 64.0 * TEMP + 0.5 1600 CONTINUE IHGT = 0 DO 1700 L = 1 , 40 IF(KDATA0(INDEX0,LCH40I(L)).NE.999999) THEN GEO = KDATA0(INDEX0,LCH40I(L)) * TENS(IXH40I(L)) IHGT = IHGT + 1 GEOOPR(IDXHGT(IHGT)) = GEO IF(IHGT.LE.9) THEN IBUFTN(IHGT+65) = 0.1 * GEO + 0.5 ELSE IBUFTN(IHGT+65) = GEO + 0.5 ENDIF ENDIF 1700 CONTINUE DO 1800 L = 1 , 15 RATMIX = KDATA0(INDEX0,LCM40I(L+25)) * TENS(IXM40I(L+25)) IBUFTN(L+83) = 256000.0 * RATMIX + 0.5 1800 CONTINUE TEMP = KDATA0(INDEX0,LCTTRI) * TENS(IXTTRI) IBUFTN(99) = 64.0 * TEMP + 0.5 PRES = KDATA0(INDEX0,LCPTRI) * TENS(IXPTRI) IBUFTN(100) = 0.01 * PRES + 0.5 OZONE = KDATA0(INDEX0,LCOZON) * TENS(IXOZON) IBUFTN(101) = OZONE + 0.5 DO 1900 L = 1 , 19 IF(KDATA0(INDEX0,LCRADI(L)).NE.999999) THEN RAD = KDATA0(INDEX0,LCRADI(L)) * TENS(IXRADI(L)) IBUFTN(L+101) = 64.0 * RAD + 0.5 ELSE IBUFTN(L+101) = 32767 ENDIF 1900 CONTINUE IF(KDATA0(INDEX0,LCRADI(20)).NE.999999) THEN RAD = KDATA0(INDEX0,LCRADI(20)) * TENS(IXRADI(20)) IBUFTN(121) = 16.0 * RAD + 0.5 ELSE IBUFTN(121) = 32767 ENDIF DO 2000 L = 21 , 27 IF(KDATA0(INDEX0,LCRADI(L)).NE.999999) THEN RAD = KDATA0(INDEX0,LCRADI(L)) * TENS(IXRADI(L)) IBUFTN(L+101) = 64.0 * RAD + 0.5 ELSE IBUFTN(L+101) = 32767 ENDIF 2000 CONTINUE AVGNST = KDATA0(INDEX0,LCAVNS) * TENS(IXAVNS) IBUFTN(142) = 1024.0 * AVGNST + 0.5 IF(KDATA0(INDEX0,LCSALB).NE.999999) THEN SFCALB = KDATA0(INDEX0,LCSALB) * TENS(IXSALB) IBUFTN(143) = SFCALB + 0.5 ELSE IBUFTN(143) = -899 ENDIF SKINT = KDATA0(INDEX0,LCSKNI) * TENS(IXSKNI) IBUFTN(144) = 64.0 * SKINT + 0.5 SFCHGT = KDATA0(INDEX0,LCSFHI) * TENS(IXSFHI) IBUFTN(145) = SFCHGT + 0.5 SST15 = KDATA0(INDEX0,LCST15) * TENS(IXST15) IBUFTN(166) = 64.0 * SST15 + 0.5 DO 2100 L = 1 , 40 TEMP = KDATA0(INDEX0,LCT4GI(L)) * TENS(IXT4GI(L)) IBUFTN(L+167) = 64.0 * TEMP + 0.5 2100 CONTINUE DO 2200 L = 1 , 15 RATMIX = KDATA0(INDEX0,LCM4GI(L+25)) * TENS(IXM4GI(L+25)) IBUFTN(L+207) = 256000.0 * RATMIX + 0.5 2200 CONTINUE DO 2300 L = 1 , 19 IF(KDATA0(INDEX0,LCRDGI(L)).NE.999999) THEN RAD = KDATA0(INDEX0,LCRDGI(L)) * TENS(IXRDGI(L)) IBUFTN(L+222) = 64.0 * RAD + 0.5 ELSE IBUFTN(L+222) = 32767 ENDIF 2300 CONTINUE IF(KDATA0(INDEX0,LCRDGI(20)).NE.999999) THEN RAD = KDATA0(INDEX0,LCRDGI(20)) * TENS(IXRDGI(20)) IBUFTN(242) = 16.0 * RAD + 0.5 ELSE IBUFTN(242) = 32767 ENDIF DO 2400 L = 21 , 27 IF(KDATA0(INDEX0,LCRDGI(L)).NE.999999) THEN RAD = KDATA0(INDEX0,LCRDGI(L)) * TENS(IXRDGI(L)) IBUFTN(L+222) = 64.0 * RAD + 0.5 ELSE IBUFTN(L+222) = 32767 ENDIF 2400 CONTINUE TEMP = KDATA1(INDEX1,LCSKNT) * TENS(IXSKNT) IBUFTN(251) = 64.0 * TEMP + 0.5 XLAT = KDATA1(INDEX1,LCLATR) * TENS(IXLATR) IBUFTN(252) = 128.0 * XLAT + SIGN(0.5,XLAT) IF(XLAT.GE.60.0) THEN LATZON = 1 ELSE IF(XLAT.GE.45.0) THEN LATZON = 2 ELSE IF(XLAT.GE.30.0) THEN LATZON = 3 ELSE IF(XLAT.GE.15.0) THEN LATZON = 4 ELSE IF(XLAT.GT.-15.0) THEN LATZON = 5 ELSE IF(XLAT.GT.-30.0) THEN LATZON = 6 ELSE IF(XLAT.GT.-45.0) THEN LATZON = 7 ELSE IF(XLAT.GT.-60.0) THEN LATZON = 8 ELSE LATZON = 9 ENDIF XLON = KDATA1(INDEX1,LCLONR) * TENS(IXLONR) IBUFTN(253) = 128.0 * XLON + SIGN(0.5,XLON) INSTRU = KDATA1(INDEX1,LCINSR) IRETMT = KDATA1(INDEX1,LCRTMR) IF(MOD(INSTRU,128).GE.64) THEN ISSUFL = 1 ELSE ISSUFL = 0 ENDIF IF(INSTRU.GE.256) THEN IF(INSTRU.GE.384) THEN MCL3 = 1 ELSE MCL3 = 2 ENDIF IF(MOD(IRETMT,64).GE.32) THEN MCL1 = 1 MCL2 = 1 ICLOUD = 110 + MCL3 ELSE IF(MOD(IRETMT,64).GE.16) THEN MCL1 = 2 MCL2 = 1 ICLOUD = 210 + MCL3 ELSE IF(MOD(IRETMT,64).GE.8) THEN MCL1 = 2 MCL2 = 2 ICLOUD = 220 + MCL3 ENDIF ELSE IF(INSTRU.GE.128) THEN MCL1 = 0 MCL2 = 0 ICLOUD = 3 ENDIF IF(INSTRU.EQ.448) THEN ICCFLG = 1 ELSE IF(INSTRU.EQ.384) THEN ICCFLG = 2 ELSE IF(INSTRU.EQ.256) THEN ICCFLG = 3 ELSE IF(INSTRU.EQ.320) THEN ICCFLG = 4 ELSE IF(INSTRU.EQ.128) THEN ICCFLG = 5 ELSE IF(INSTRU.EQ.192) THEN ICCFLG = 6 ELSE IF(INSTRU.EQ.64) THEN ICCFLG = 7 ENDIF IF(IRETMT.GE.64) THEN METRET = 0 ELSE IF(MOD(IRETMT,8).GE.4) THEN METRET = 1 ENDIF LNDSEA = KDATA1(INDEX1,LCLSR) NGTDAY = KDATA1(INDEX1,LCNDR) PLST = 0.01 * KDATA1(INDEX1,LCPLSR) * TENS(IXPLSR) DO 2500 L=1,40 IF(ABS(PLST - PTOVS(L)).LT.0.1) LST = L 2500 CONTINUE IBUFTN(254) = 10000 * LNDSEA + 1 1000 * NGTDAY + 2 100 * METRET + 3 LST IF(METRET.EQ.0) THEN ICCMVS = 0 ELSE IF(ICCFLG.LE.3) THEN IF(MCL1.GE.1 .AND. MCL2.EQ.1) THEN ICCMVS = 1 ELSE IF(MCL1.EQ.2 .AND. MCL2.EQ.2) THEN IF(LNDSEA.EQ.1) THEN ICCMVS = 2 ELSE ICCMVS = 3 ENDIF ENDIF ELSE IF(ICCFLG.GE.5) THEN IF(LNDSEA.EQ.1) THEN ICCMVS = 4 ELSE ICCMVS = 5 ENDIF ELSE ICCMVS = 6 ENDIF IF(KDATA1(INDEX1,LCICOR).EQ.20480) THEN ICCO3 = 1 ELSE IF(KDATA1(INDEX1,LCICOR).EQ.16384) THEN ICCO3 = 2 ELSE IF(KDATA1(INDEX1,LCICOR).EQ.12288) THEN ICCO3 = 3 ELSE IF(KDATA1(INDEX1,LCICOR).EQ.8192) THEN ICCO3 = 4 ELSE IF(KDATA1(INDEX1,LCICOR).EQ.0) THEN ICCO3 = 0 ENDIF IF(KDATA1(INDEX1,LCICTR).EQ.262144) THEN ICTROP = 1 ELSE IF(KDATA1(INDEX1,LCICTR).EQ.131072) THEN ICTROP = 2 ENDIF IBUFTN(255) = 10000 * KDATA1(INDEX1,LCSTUR) + 1 100 * ICCMVS + 2 10 * ICCO3 + 3 ICTROP IBUFTN(256) = 1000 * KDATA1(INDEX1,LCH8FR) + 1 100 * ISSUFL + 2 10 * LATZON + 3 ICCFLG TEMP = KDATA1(INDEX1,LCTTRR) * TENS(IXTTRR) IBUFTN(257) = 64.0 * TEMP + 0.5 PRES = KDATA1(INDEX1,LCPTRR) * TENS(IXPTRR) IBUFTN(258) = 0.01 * PRES + 0.5 DO 2600 L = 1 , 19 IF(KDATA1(INDEX1,LCRADF(L)).NE.999999) THEN RAD = KDATA1(INDEX1,LCRADF(L)) * TENS(IXRADF(L)) IBUFTN(L+258) = 64.0 * RAD + 0.5 ELSE IBUFTN(L+258) = 32767 ENDIF 2600 CONTINUE IF(KDATA1(INDEX1,LCRADF(20)).NE.999999) THEN RAD = KDATA1(INDEX1,LCRADF(20)) * TENS(IXRADF(20)) IBUFTN(278) = 16.0 * RAD + 0.5 ELSE IBUFTN(278) = 32767 ENDIF DO 2700 L = 21 , 27 IF(KDATA1(INDEX1,LCRADF(L)).NE.999999) THEN RAD = KDATA1(INDEX1,LCRADF(L)) * TENS(IXRADF(L)) IBUFTN(L+258) = 64.0 * RAD + 0.5 ELSE IBUFTN(L+258) = 32767 ENDIF 2700 CONTINUE DO 2800 L = 1 , 19 IF(KDATA1(INDEX1,LCRDFC(L)).NE.999999) THEN RAD = KDATA1(INDEX1,LCRDFC(L)) * TENS(IXRDFC(L)) IBUFTN(L+285) = 64.0 * RAD + 0.5 ELSE IBUFTN(L+285) = 32767 ENDIF 2800 CONTINUE IF(KDATA1(INDEX1,LCRDFC(20)).NE.999999) THEN RAD = KDATA1(INDEX1,LCRDFC(20)) * TENS(IXRDFC(20)) IBUFTN(305) = 16.0 * RAD + 0.5 ELSE IBUFTN(305) = 32767 ENDIF DO 2900 L = 21 , 27 IF(KDATA1(INDEX1,LCRDFC(L)).NE.999999) THEN RAD = KDATA1(INDEX1,LCRDFC(L)) * TENS(IXRDFC(L)) IBUFTN(L+285) = 64.0 * RAD + 0.5 ELSE IBUFTN(L+285) = 32767 ENDIF 2900 CONTINUE TEMP = KDATA1(INDEX1,LCSKNF) * TENS(IXSKNF) IBUFTN(313) = 64.0 * TEMP + 0.5 SKINT = KDATA1(INDEX1,LCSKNR) * TENS(IXSKNR) IBUFTN(314) = 64.0 * SKINT + 0.5 DO 3000 L = 1 , NMLO TEMP = KDATA1(INDEX1,LCTMPI(L)) * TENS(IXTMPI(L)) IBUFTN(L+314) = 64.0 * TEMP + 0.5 3000 CONTINUE TEMP = KDATA1(INDEX1,LCT41I) * TENS(IXT41I) IBUFTN(343) = 64.0 * TEMP + 0.5 DO 3100 L = 1 , 19 IF(KDATA1(INDEX1,LCRADR(L)).NE.999999) THEN RAD = KDATA1(INDEX1,LCRADR(L)) * TENS(IXRADR(L)) IBUFTN(L+343) = 64.0 * RAD + 0.5 ELSE IBUFTN(L+343) = 32767 ENDIF 3100 CONTINUE IF(KDATA1(INDEX1,LCRADR(20)).NE.999999) THEN RAD = KDATA1(INDEX1,LCRADR(20)) * TENS(IXRADR(20)) IBUFTN(363) = 16.0 * RAD + 0.5 ELSE IBUFTN(363) = 32767 ENDIF DO 3200 L = 21 , 27 IF(KDATA1(INDEX1,LCRADR(L)).NE.999999) THEN RAD = KDATA1(INDEX1,LCRADR(L)) * TENS(IXRADR(L)) IBUFTN(L+343) = 64.0 * RAD + 0.5 ELSE IBUFTN(L+343) = 32767 ENDIF 3200 CONTINUE DO 3300 L = 1 , 19 IF(KDATA1(INDEX1,LCRDRC(L)).NE.999999) THEN RAD = KDATA1(INDEX1,LCRDRC(L)) * TENS(IXRDRC(L)) IBUFTN(L+370) = 64.0 * RAD + 0.5 ELSE IBUFTN(L+370) = 32767 ENDIF 3300 CONTINUE IF(KDATA1(INDEX1,LCRDRC(20)).NE.999999) THEN RAD = KDATA1(INDEX1,LCRDRC(20)) * TENS(IXRDRC(20)) IBUFTN(390) = 16.0 * RAD + 0.5 ELSE IBUFTN(390) = 32767 ENDIF DO 3400 L = 21 , 27 IF(KDATA1(INDEX1,LCRDRC(L)).NE.999999) THEN RAD = KDATA1(INDEX1,LCRDRC(L)) * TENS(IXRDRC(L)) IBUFTN(L+370) = 64.0 * RAD + 0.5 ELSE IBUFTN(L+370) = 32767 ENDIF 3400 CONTINUE IBUFTN(398) = KDATA1(INDEX1,LCFCYC) SFCHGT = KDATA1(INDEX1,LCSFHF) * TENS(IXSFHF) IBUFTN(399) = SFCHGT + SIGN(0.5,SFCHGT) PSFGES = 0.01 * KDATA1(INDEX1,LCPSFF) * TENS(IXPSFF) IBUFTN(400) = AINT(50.0 * PSFGES + 0.5) - 32000.0 DO 3500 L = 1 , NMLO TGES(L) = KDATA1(INDEX1,LCTMPF(L)) * TENS(IXTMPF(L)) PGES(L) = KDATA1(INDEX1,LCSIGF(L)) * TENS(IXSIGF(L)) * PSFGES IBUFTN(L+400) = 64.0 * TGES(L) + 0.5 3500 CONTINUE DO 3600 L = 1 , NMLO WGES(L) = 1000.0 * KDATA1(INDEX1,LCMIXF(L)) * TENS(IXMIXF(L)) IBUFTN(L+428) = 256.0 * WGES(L) + 0.5 3600 CONTINUE DO 3700 L = 1 , NML TEMP = KDATA1(INDEX1,LCTMPR(L)) * TENS(IXTMPR(L)) IBUFTN(L+456) = 64.0 * TEMP + 0.5 3700 CONTINUE DO 3800 L = 1 , NUL RATMIX = KDATA1(INDEX1,LCMIXR(NML-NUL+L)) * 1 TENS(IXMIXR(NML-NUL+L)) IBUFTN(L+526) = 256000.0 * RATMIX + 0.5 3800 CONTINUE DO 3900 L = 1 , 19 IF(KDATA2(INDEX2,LCRADA(L)).NE.999999) THEN RAD = KDATA2(INDEX2,LCRADA(L)) * TENS(IXRADA(L)) IBUFTN(L+566) = 64.0 * RAD + 0.5 ELSE IBUFTN(L+566) = 32767 ENDIF 3900 CONTINUE IF(LSTOVS.EQ.40) THEN CALL FI8104(PSFGES,PGES,TGES,WGES,PTOVS,TGES40,WGES40,NMLO) CALL FI8105(PTOVS,TGES40,WGES40,GEOGES,NBUG) CALL FI8106(PTOVS,GEOOPR,GEOGES,STDPTT,STDPLW,STDPUP,NBUG) IBUFTN(130) = 512.0 * STDPLW + SIGN(0.5,STDPLW) IBUFTN(131) = 512.0 * STDPUP + SIGN(0.5,STDPUP) IBUFTN(132) = 512.0 * STDPTT + SIGN(0.5,STDPTT) ELSE IBUFTN(130) = 32767 IBUFTN(131) = 32767 IBUFTN(132) = 32767 ENDIF IF(KDATA2(INDEX2,LCRADA(20)).NE.999999) THEN RAD = KDATA2(INDEX2,LCRADA(20)) * TENS(IXRADA(20)) IBUFTN(586) = 16.0 * RAD + 0.5 ELSE IBUFTN(586) = 32767 ENDIF DO 4000 L = 21 , 27 IF(KDATA2(INDEX2,LCRADA(L)).NE.999999) THEN RAD = KDATA2(INDEX2,LCRADA(L)) * TENS(IXRADA(L)) IBUFTN(L+566) = 64.0 * RAD + 0.5 ELSE IBUFTN(L+566) = 32767 ENDIF 4000 CONTINUE DO 4100 L = 1 , 19 IF(KDATA2(INDEX2,LCRDAC(L)).NE.999999) THEN RAD = KDATA2(INDEX2,LCRDAC(L)) * TENS(IXRDAC(L)) IBUFTN(L+593) = 64.0 * RAD + 0.5 ELSE IBUFTN(L+593) = 32767 ENDIF 4100 CONTINUE IF(KDATA2(INDEX2,LCRDAC(20)).NE.999999) THEN RAD = KDATA2(INDEX2,LCRDAC(20)) * TENS(IXRDAC(20)) IBUFTN(613) = 16.0 * RAD + 0.5 ELSE IBUFTN(613) = 32767 ENDIF DO 4200 L = 21 , 27 IF(KDATA2(INDEX2,LCRDAC(L)).NE.999999) THEN RAD = KDATA2(INDEX2,LCRDAC(L)) * TENS(IXRDAC(L)) IBUFTN(L+593) = 64.0 * RAD + 0.5 ELSE IBUFTN(L+593) = 32767 ENDIF 4200 CONTINUE PRES = KDATA2(INDEX2,LCPSFA) * TENS(IXPSFA) IBUFTN(621) = AINT(50.0 * (0.01 * PRES) + 0.5) - 32000.0 DO 4300 L = 1 , NMLO TEMP = KDATA2(INDEX2,LCTMPA(L)) * TENS(IXTMPA(L)) IBUFTN(L+621) = 64.0 * TEMP + 0.5 4300 CONTINUE DO 4400 L = 1 , NMLO RATMIX = KDATA2(INDEX2,LCMIXA(L)) * TENS(IXMIXA(L)) IBUFTN(L+649) = 256000.0 * RATMIX + 0.5 4400 CONTINUE IBUFTN(678) = MOD(KDATA2(INDEX2,LCYRA),100) IBUFTN(679) = KDATA2(INDEX2,LCMONA) IBUFTN(680) = KDATA2(INDEX2,LCDAYA) IBUFTN(681) = KDATA2(INDEX2,LCHRA) IBUFTN(682) = KDATA2(INDEX2,LCMINA) IERR = 0 RETURN C 9970 CONTINUE WRITE(6,1001) IUNIT0 1001 FORMAT(' END OF FILE ON UNIT ',I5) IENFIL = IENFIL + 1 IF(IENFIL.EQ.3) GO TO 99999 ICOUNT = 0 9975 CONTINUE READ(IUNIT1,END=9978) CMSGA ICOUNT = ICOUNT + 1 GO TO 9975 C 9978 CONTINUE INDEX1 = 0 WRITE(6,1002) ICOUNT,IUNIT1 1002 FORMAT(' THERE ARE ',I5,' EXCESS BUFR MESSAGES ON UNIT ',I3) 9980 CONTINUE WRITE(6,1001) IUNIT1 IENFIL = IENFIL + 1 IF(IENFIL.EQ.3) GO TO 99999 ICOUNT = 0 9985 CONTINUE READ(IUNIT2,END=9988) CMSGA ICOUNT = ICOUNT + 1 GO TO 9985 C 9988 CONTINUE INDEX2 = 0 WRITE(6,1002) ICOUNT,IUNIT2 9990 CONTINUE WRITE(6,1001) IUNIT2 IENFIL = IENFIL + 1 IF(IENFIL.EQ.3) GO TO 99999 ICOUNT = 0 9995 CONTINUE READ(IUNIT0,END=9998) CMSGA ICOUNT = ICOUNT + 1 GO TO 9995 C 9998 CONTINUE INDEX0 = 0 WRITE(6,1002) ICOUNT,IUNIT0 GO TO 9970 C 99999 CONTINUE IERR = 3 RETURN END SUBROUTINE FI8101(MSTACK,KDATA,NDESC) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: FI8101 GETS INFO TO UNPACK BUFR 40-LVL TOVS RTRVLS C PRGMMR: BERT B. KATZ ORG: W/NMC23 DATE: 93-06-09 C GENERAL C SCIENCES CORP. C C ABSTRACT: USES BUFR DESCRIPTOR STACK AND DATA TO DETERMINE C ARRAY LOCATIONS AND SCALING FOR TOVS 40-LEVEL RETRIEVAL C QUANTITIES TO BE RETURNED TO W3FI81. C C PROGRAM HISTORY LOG: C 93-06-09 BERT B. KATZ C C USAGE: CALL FI8101(MSTACK,KDATA,NDESC) C INPUT ARGUMENT LIST: C MSTACK - ARRAY CONTAINING BUFR DESCRIPTORS AND SCALING C - FOR TOVS 40-LEVEL RETRIEVALS. C KDATA - BUFR DATA IN INTEGER FORM. C NDESC - NUMBER OF DESCRIPTORS IN ARRAY MSTACK. C C REMARKS: CALLED BY SUBROUTINE W3FI81. RETURNS OUTPUT THOUGH C COMMON BLOCK /FI81TV/. C C ATTRIBUTES: C LANGUAGE: VS FORTRAN, CFT77 C MACHINE: HDS OR CRAY C C$$$ C PARAMETER (MXIRPT=50,MXIDSC=420) PARAMETER (NMLO=28) PARAMETER (NML=70) INTEGER MSTACK(2,MXIDSC) INTEGER KDATA(MXIRPT,MXIDSC) C COMMON /FI81TV/ LCSTII, LCSSBC, LCMBBX, 1 LCINSI, LCRTMI, LCFLFI, 2 LCYRI , LCMONI, LCDAYI, 3 LCHRI , LCMINI, LCSECI, 4 LCLSI , LCNDI , LCFGAP, 5 LCDVHI, LCDVMI, LCDVSI, 6 LCNMCI, LWNMCI, LCRTPI, 7 LCLATI, IXLATI, LCLONI, IXLONI, 8 LCSTUI, LCSSTA, LCST15, IXST15, 9 LCSZAN, IXSZAN, LCLSZA, IXLSZA, A LCSALB, IXSALB, LCSKNI, IXSKNI, B LCH8FI, LCPLSI, IXPLSI, LCSFHI, IXSFHI, C LCICOI, LCOZON, IXOZON, LCAVNS, IXAVNS, D LCICTI, LCPTRI, IXPTRI, LCTTRI, IXTTRI COMMON /FI81TV/ LCP40I(40), IXP40I(40), 1 LCT40I(40), IXT40I(40), 2 LCH40I(40), IXH40I(40), 3 LCM40I(40), IXM40I(40), 4 LCP4GI(40), IXP4GI(40), 5 LCT4GI(40), IXT4GI(40), 6 LCM4GI(40), IXM4GI(40), 7 LCRADI(27), IXRADI(27), 8 LCRDGI(27), IXRDGI(27) C C FIND LOCATIONS AND SCALING C I=0 15 CONTINUE I = I + 1 IF(MSTACK(1,I).EQ.263) THEN LCSTII = I ELSE IF(MSTACK(1,I).EQ.6932) THEN LCSSBC = I ELSE IF(MSTACK(1,I).EQ.6933) THEN LCMBBX = I ELSE IF(MSTACK(1,I).EQ.1025) THEN LCYRI = I ELSE IF(MSTACK(1,I).EQ.1026) THEN LCMONI = I ELSE IF(MSTACK(1,I).EQ.1027) THEN LCDAYI = I ELSE IF(MSTACK(1,I).EQ.1028) THEN LCHRI = I ELSE IF(MSTACK(1,I).EQ.1029) THEN LCMINI = I ELSE IF(MSTACK(1,I).EQ.1030) THEN LCSECI = I ELSE IF(MSTACK(1,I).EQ.1282) THEN LCLATI = I IXLATI = -MSTACK(2,I) ELSE IF(MSTACK(1,I).EQ.1538) THEN LCLONI = I IXLONI = -MSTACK(2,I) ELSE IF(MSTACK(1,I).EQ.2060) THEN LCLSI = I ELSE IF(MSTACK(1,I).EQ.2061) THEN LCNDI = I ELSE IF(MSTACK(1,I).EQ.533) THEN LCINSI = I ELSE IF(MSTACK(1,I).EQ.534) THEN LCRTMI = I ELSE IF(MSTACK(1,I).EQ.6438) THEN LCFLFI = I ELSE IF(MSTACK(1,I).EQ.6435) THEN LCFGAP = I ELSE IF(MSTACK(1,I).EQ.1814) THEN LCSZAN = I IXSZAN = -MSTACK(2,I) ELSE IF(MSTACK(1,I).EQ.1813) THEN LCLSZA = I IXLSZA = -MSTACK(2,I) ELSE IF(MSTACK(1,I).EQ.6436) THEN LCAVNS = I IXAVNS = -MSTACK(2,I) ELSE IF(MSTACK(1,I).EQ.451) THEN IF(MSTACK(1,I-1).NE.451) THEN NBITS = MSTACK(1,I-1) - 34304 IF(NBITS.GT.0) THEN LCNMCI = I LBNMCI = NBITS / 8 LWNMCI = (LBNMCI - 1) / 4 + 1 ENDIF ENDIF ELSE IF(MSTACK(1,I).EQ.1048) THEN LCDVHI = I ELSE IF(MSTACK(1,I).EQ.1049) THEN LCDVMI = I ELSE IF(MSTACK(1,I).EQ.1050) THEN LCDVSI = I ELSE IF(MSTACK(1,I).EQ.14086) THEN LCRTPI = I ENDIF IF(I.LT.NDESC) GO TO 15 C I=0 20 CONTINUE I = I + 1 IF(MSTACK(1,I).EQ.2051) THEN IF(KDATA(1,I).EQ.7) THEN 25 CONTINUE I = I + 1 IF(MSTACK(1,I).EQ.537) THEN LCICOI = I GO TO 25 ELSE IF(MSTACK(1,I).EQ.3841) THEN LCOZON = I IXOZON = -MSTACK(2,I) GO TO 25 ELSE IF(MSTACK(1,I).NE.2051 .AND. MSTACK(1,I).NE.2280) THEN GO TO 25 ELSE I = I - 1 ENDIF ELSE IF(KDATA(1,I).EQ.8) THEN 30 CONTINUE I = I + 1 IF(MSTACK(1,I).EQ.6430) THEN LCSTUI = I GO TO 30 ELSE IF(MSTACK(1,I).EQ.6431) THEN LCSSTA = I GO TO 30 ELSE IF(MSTACK(1,I).EQ.5673) THEN LCST15 = I IXST15 = -MSTACK(2,I) GO TO 30 ELSE IF(MSTACK(1,I).NE.2051 .AND. MSTACK(1,I).NE.2280) THEN GO TO 30 ELSE I = I - 1 ENDIF ELSE IF(KDATA(1,I).EQ.3) THEN 35 CONTINUE I = I + 1 IF(MSTACK(1,I).EQ.537) THEN LCICTI = I GO TO 35 ELSE IF(MSTACK(1,I).EQ.1796) THEN LCPTRI = I IXPTRI = -MSTACK(2,I) GO TO 35 ELSE IF(MSTACK(1,I).EQ.3073) THEN LCTTRI = I IXTTRI = -MSTACK(2,I) GO TO 35 ELSE IF(MSTACK(1,I).NE.2051 .AND. MSTACK(1,I).NE.2280) THEN GO TO 35 ELSE I = I - 1 ENDIF ELSE IF(KDATA(1,I).EQ.0) THEN 40 CONTINUE I = I + 1 IF(MSTACK(1,I).EQ.1793) THEN LCSFHI = I IXSFHI = -MSTACK(2,I) GO TO 40 ELSE IF(MSTACK(1,I).EQ.2564) THEN LCPLSI = I IXPLSI = -MSTACK(2,I) GO TO 40 ELSE IF(MSTACK(1,I).EQ.3133) THEN LCSKNI = I IXSKNI = -MSTACK(2,I) GO TO 40 ELSE IF(MSTACK(1,I).EQ.6437) THEN LCH8FI = I GO TO 40 ELSE IF(MSTACK(1,I).EQ.3603) THEN LCSALB = I IXSALB = -MSTACK(2,I) GO TO 40 ELSE IF(MSTACK(1,I).NE.2051 .AND. MSTACK(1,I).NE.2280) THEN GO TO 40 ELSE I = I - 1 ENDIF ENDIF ELSE IF(MSTACK(1,I).EQ.2280) THEN IF(KDATA(1,I).EQ.4096) THEN I = I + 1 KPROF = MSTACK(1,I) - 16384 KREPL = MOD(KPROF,256) KFLDS = KPROF / 256 DO 45 K = 1 , KREPL DO 45 J = 1 , KFLDS I = I + 1 IF(MSTACK(1,I).EQ.1796) THEN LCP40I(K) = I IXP40I(K) = -MSTACK(2,I) ELSE IF(MSTACK(1,I).EQ.3073) THEN LCT40I(K) = I IXT40I(K) = -MSTACK(2,I) ELSE IF(MSTACK(1,I).EQ.2563) THEN LCH40I(K) = I IXH40I(K) = -MSTACK(2,I) ELSE IF(MSTACK(1,I).EQ.3330) THEN LCM40I(K) = I IXM40I(K) = -MSTACK(2,I) ENDIF 45 CONTINUE ELSE IF(KDATA(1,I).EQ.100 .OR. KDATA(1,I).EQ.98 .OR. 1 KDATA(1,I).EQ.97) THEN IF(KDATA(1,I).EQ.100) THEN ISCHAN = 0 ELSE IF(KDATA(1,I).EQ.98) THEN ISCHAN = 20 ELSE IF(KDATA(1,I).EQ.97) THEN ISCHAN = 24 ENDIF 50 CONTINUE I = I + 1 IF(MSTACK(1,I).EQ.1322) THEN ICHAN = ISCHAN + KDATA(1,I) ICHINC = 0 GO TO 50 ELSE IF(MSTACK(1,I).EQ.1332) THEN ICHINC = KDATA(1,I) GO TO 50 ELSE IF(MSTACK(1,I).GT.16384 .AND. 1 MSTACK(1,I).LT.33024) THEN KPROF = MSTACK(1,I) - 16384 KREPL = MOD(KPROF,256) KFLDS = KPROF / 256 GO TO 50 ELSE IF(MSTACK(1,I).EQ.3135) THEN ICHAN = ICHAN + ICHINC LCRADI(ICHAN) = I IXRADI(ICHAN) = -MSTACK(2,I) IF(ICHAN-ISCHAN.GE.KREPL*ICHINC) THEN ISCHAN = 0 ENDIF GO TO 50 ELSE IF(MSTACK(1,I).GE.33024) THEN GO TO 50 ELSE I = I - 1 ENDIF ELSE IF(KDATA(1,I).EQ.4224) THEN I = I + 1 KPROF = MSTACK(1,I) - 16384 KREPL = MOD(KPROF,256) KFLDS = KPROF / 256 DO 55 K = 1 , KREPL DO 55 J = 1 , KFLDS I = I + 1 IF(MSTACK(1,I).EQ.1796) THEN LCP4GI(K) = I IXP4GI(K) = -MSTACK(2,I) ELSE IF(MSTACK(1,I).EQ.3073) THEN LCT4GI(K) = I IXT4GI(K) = -MSTACK(2,I) ELSE IF(MSTACK(1,I).EQ.3330) THEN LCM4GI(K) = I IXM4GI(K) = -MSTACK(2,I) ENDIF 55 CONTINUE ELSE IF(KDATA(1,I).EQ.228 .OR. KDATA(1,I).EQ.226 .OR. 1 KDATA(1,I).EQ.225) THEN IF(KDATA(1,I).EQ.228) THEN ISCHAN = 0 ELSE IF(KDATA(1,I).EQ.226) THEN ISCHAN = 20 ELSE IF(KDATA(1,I).EQ.225) THEN ISCHAN = 24 ENDIF 60 CONTINUE I = I + 1 IF(MSTACK(1,I).EQ.1322) THEN ICHAN = ISCHAN + KDATA(1,I) ICHINC = 0 GO TO 60 ELSE IF(MSTACK(1,I).EQ.1332) THEN ICHINC = KDATA(1,I) GO TO 60 ELSE IF(MSTACK(1,I).GT.16384 .AND. 1 MSTACK(1,I).LT.33024) THEN KPROF = MSTACK(1,I) - 16384 KREPL = MOD(KPROF,256) KFLDS = KPROF / 256 GO TO 60 ELSE IF(MSTACK(1,I).EQ.3135) THEN ICHAN = ICHAN + ICHINC LCRDGI(ICHAN) = I IXRDGI(ICHAN) = -MSTACK(2,I) IF(ICHAN-ISCHAN.GE.KREPL*ICHINC) THEN ISCHAN = 0 ENDIF GO TO 60 ELSE IF(MSTACK(1,I).GE.33024) THEN GO TO 60 ELSE I = I - 1 ENDIF ENDIF ENDIF IF(I.LT.NDESC) GO TO 20 C RETURN END SUBROUTINE FI8102(MSTACK,KDATA,NDESC) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: FI8102 GETS INFO TO UNPACK BUFR INTERACTIVE RTRVLS C PRGMMR: BERT B. KATZ ORG: W/NMC23 DATE: 93-06-09 C GENERAL C SCIENCES CORP. C C ABSTRACT: USES BUFR DESCRIPTOR STACK AND DATA TO DETERMINE C ARRAY LOCATIONS AND SCALING FOR INTERACTIVE RETRIEVAL C QUANTITIES TO BE RETURNED TO W3FI81. C C PROGRAM HISTORY LOG: C 93-06-09 BERT B. KATZ C C USAGE: CALL FI8102(MSTACK,KDATA,NDESC) C INPUT ARGUMENT LIST: C MSTACK - ARRAY CONTAINING BUFR DESCRIPTORS AND SCALING C - FOR INTERACTIVE RETRIEVALS. C KDATA - BUFR DATA IN INTEGER FORM. C NDESC - NUMBER OF DESCRIPTORS IN ARRAY MSTACK. C C REMARKS: CALLED BY SUBROUTINE W3FI81. RETURNS OUTPUT THOUGH C COMMON BLOCK /FI81IA/. C C ATTRIBUTES: C LANGUAGE: VS FORTRAN, CFT77 C MACHINE: HDS OR CRAY C C$$$ C PARAMETER (MXRPTR=30,MXDSCR=700) PARAMETER (NMLO=28) PARAMETER (NML=70) INTEGER MSTACK(2,MXDSCR) INTEGER KDATA(MXRPTR,MXDSCR) C COMMON /FI81IA/ LCSTIR , LCLSR , LCNDR , 1 LCNMCR , LWNMCR , LCFCYC , 2 LCINSR , LCRTMR , LCRTPR , 3 LCDVHR , LCDVMR , LCDVSR , 4 LCSTUR , LCICOR , LCFLFR , 5 LCLATR , IXLATR , 6 LCLONR , IXLONR , 7 LCPTRR , IXPTRR , 8 LCTTRR , IXTTRR , LCICTR , 9 LCSKNT , IXSKNT , A LCPLSR , IXPLSR , B LCSFHF , IXSFHF , C LCPSFF , IXPSFF , D LCSKNF , IXSKNF , E LCSKNR , IXSKNR , LCH8FR COMMON /FI81IA/ LCRADF(27) , IXRADF(27) , 1 LCRDFC(27) , IXRDFC(27) , 2 LCSIGI(NMLO), IXSIGI(NMLO), 3 LCTMPI(NMLO), IXTMPI(NMLO), 4 LCRADR(27) , IXRADR(27) , 5 LCRDRC(27) , IXRDRC(27) , 6 LCSIGF(NMLO), IXSIGF(NMLO), 7 LCTMPF(NMLO), IXTMPF(NMLO), 8 LCMIXF(NMLO), IXMIXF(NMLO), 9 LCSIGR(NML) , IXSIGR(NML) , A LCTMPR(NML) , IXTMPR(NML) , B LCMIXR(NML) , IXMIXR(NML) , C LCP41I , IXP41I , D LCT41I , IXT41I , E LCM41I , IXM41I C C FIND LOCATIONS AND SCALING C I=0 20 CONTINUE I = I + 1 IF(MSTACK(1,I).EQ.263) THEN LCSTIR = I ELSE IF(MSTACK(1,I).EQ.1282) THEN LCLATR = I IXLATR = -MSTACK(2,I) ELSE IF(MSTACK(1,I).EQ.1538) THEN LCLONR = I IXLONR = -MSTACK(2,I) ELSE IF(MSTACK(1,I).EQ.2060) THEN LCLSR = I ELSE IF(MSTACK(1,I).EQ.2061) THEN LCNDR = I ELSE IF(MSTACK(1,I).EQ.533) THEN LCINSR = I ELSE IF(MSTACK(1,I).EQ.534) THEN LCRTMR = I ELSE IF(MSTACK(1,I).EQ.6438) THEN LCFLFR = I ELSE IF(MSTACK(1,I).EQ.451) THEN IF(MSTACK(1,I-1).NE.451) THEN NBITS = MSTACK(1,I-1) - 34304 IF(NBITS.GT.0) THEN LCNMCR = I LBNMCR = NBITS / 8 LWNMCR = (LBNMCR - 1) / 4 + 1 ENDIF ENDIF ELSE IF(MSTACK(1,I).EQ.1048) THEN LCDVHR = I ELSE IF(MSTACK(1,I).EQ.1049) THEN LCDVMR = I ELSE IF(MSTACK(1,I).EQ.1050) THEN LCDVSR = I ELSE IF(MSTACK(1,I).EQ.14086) THEN LCRTPR = I ENDIF IF(MSTACK(1,I).EQ.2051) THEN IF(KDATA(1,I).EQ.7) THEN 25 CONTINUE I = I + 1 IF(MSTACK(1,I).EQ.537) THEN LCICOR = I GO TO 25 ELSE IF(MSTACK(1,I).NE.2051 .AND. MSTACK(1,I).NE.2280) THEN GO TO 25 ELSE I = I - 1 ENDIF ELSE IF(KDATA(1,I).EQ.8) THEN 30 CONTINUE I = I + 1 IF(MSTACK(1,I).EQ.6430) THEN LCSTUR = I GO TO 30 ELSE IF(MSTACK(1,I).NE.2051 .AND. MSTACK(1,I).NE.2280) THEN GO TO 30 ELSE I = I - 1 ENDIF ELSE IF(KDATA(1,I).EQ.3) THEN 35 CONTINUE I = I + 1 IF(MSTACK(1,I).EQ.537) THEN LCICTR = I GO TO 35 ELSE IF(MSTACK(1,I).EQ.1796) THEN LCPTRR = I IXPTRR = -MSTACK(2,I) GO TO 35 ELSE IF(MSTACK(1,I).EQ.3073) THEN LCTTRR = I IXTTRR = -MSTACK(2,I) GO TO 35 ELSE IF(MSTACK(1,I).NE.2051 .AND. MSTACK(1,I).NE.2280) THEN GO TO 35 ELSE I = I - 1 ENDIF ELSE IF(KDATA(1,I).EQ.0) THEN 40 CONTINUE I = I + 1 IF(MSTACK(1,I).EQ.2564) THEN LCPLSR = I IXPLSR = -MSTACK(2,I) GO TO 40 ELSE IF(MSTACK(1,I).EQ.3133) THEN LCSKNT = I IXSKNT = -MSTACK(2,I) GO TO 40 ELSE IF(MSTACK(1,I).NE.2051 .AND. MSTACK(1,I).NE.2280) THEN GO TO 40 ELSE I = I - 1 ENDIF ENDIF ELSE IF(MSTACK(1,I).EQ.2280) THEN IF(KDATA(1,I).EQ.16) THEN 45 CONTINUE I = I + 1 IF(MSTACK(1,I).EQ.1793) THEN LCSFHF = I IXSFHF = -MSTACK(2,I) GO TO 45 ELSE IF(MSTACK(1,I).EQ.2564) THEN LCPSFF = I IXPSFF = -MSTACK(2,I) GO TO 45 ELSE IF(MSTACK(1,I).EQ.3133) THEN LCSKNF = I IXSKNF = -MSTACK(2,I) GO TO 45 ELSE IF(MSTACK(1,I).EQ.1219) THEN LCFCYC = I GO TO 45 ELSE IF(MSTACK(1,I).NE.2051 .AND. MSTACK(1,I).NE.2280) THEN GO TO 45 ELSE I = I - 1 ENDIF ELSE IF(KDATA(1,I).EQ.2048) THEN 50 CONTINUE I = I + 1 IF(MSTACK(1,I).EQ.3133) THEN LCSKNR = I IXSKNR = -MSTACK(2,I) GO TO 50 ELSE IF(MSTACK(1,I).EQ.6437) THEN LCH8FR = I GO TO 50 ELSE IF(MSTACK(1,I).NE.2051 .AND. MSTACK(1,I).NE.2280) THEN GO TO 50 ELSE I = I - 1 ENDIF ELSE IF(KDATA(1,I).EQ.1076 .OR. KDATA(1,I).EQ.1074 .OR. 1 KDATA(1,I).EQ.1073) THEN IF(KDATA(1,I).EQ.1076) THEN ISCHAN = 0 ELSE IF(KDATA(1,I).EQ.1074) THEN ISCHAN = 20 ELSE IF(KDATA(1,I).EQ.1073) THEN ISCHAN = 24 ENDIF 55 CONTINUE I = I + 1 IF(MSTACK(1,I).EQ.1322) THEN ICHAN = ISCHAN + KDATA(1,I) ICHINC = 0 GO TO 55 ELSE IF(MSTACK(1,I).EQ.1332) THEN ICHINC = KDATA(1,I) GO TO 55 ELSE IF(MSTACK(1,I).GT.16384 .AND. 1 MSTACK(1,I).LT.33024) THEN KPROF = MSTACK(1,I) - 16384 KREPL = MOD(KPROF,256) KFLDS = KPROF / 256 GO TO 55 ELSE IF(MSTACK(1,I).EQ.3135) THEN ICHAN = ICHAN + ICHINC LCRADF(ICHAN) = I IXRADF(ICHAN) = -MSTACK(2,I) IF(ICHAN-ISCHAN.GE.KREPL*ICHINC) THEN ISCHAN = 0 ENDIF GO TO 55 ELSE IF(MSTACK(1,I).GE.33024) THEN GO TO 55 ELSE I = I - 1 ENDIF ELSE IF(KDATA(1,I).EQ.1588 .OR. KDATA(1,I).EQ.1586 .OR. 1 KDATA(1,I).EQ.1585) THEN IF(KDATA(1,I).EQ.1588) THEN ISCHAN = 0 ELSE IF(KDATA(1,I).EQ.1586) THEN ISCHAN = 20 ELSE IF(KDATA(1,I).EQ.1585) THEN ISCHAN = 24 ENDIF 60 CONTINUE I = I + 1 IF(MSTACK(1,I).EQ.1322) THEN ICHAN = ISCHAN + KDATA(1,I) ICHINC = 0 GO TO 60 ELSE IF(MSTACK(1,I).EQ.1332) THEN ICHINC = KDATA(1,I) GO TO 60 ELSE IF(MSTACK(1,I).GT.16384 .AND. 1 MSTACK(1,I).LT.33024) THEN KPROF = MSTACK(1,I) - 16384 KREPL = MOD(KPROF,256) KFLDS = KPROF / 256 GO TO 60 ELSE IF(MSTACK(1,I).EQ.3135) THEN ICHAN = ICHAN + ICHINC LCRDFC(ICHAN) = I IXRDFC(ICHAN) = -MSTACK(2,I) IF(ICHAN-ISCHAN.GE.KREPL*ICHINC) THEN ISCHAN = 0 ENDIF GO TO 60 ELSE IF(MSTACK(1,I).GE.33024) THEN GO TO 60 ELSE I = I - 1 ENDIF ELSE IF(KDATA(1,I).EQ.12288) THEN I = I + 1 KPROF = MSTACK(1,I) - 16384 KREPL = MOD(KPROF,256) KFLDS = KPROF / 256 DO 65 K = 1 , KREPL DO 65 J = 1 , KFLDS I = I + 1 IF(MSTACK(1,I).EQ.1330) THEN LCSIGI(K) = I IXSIGI(K) = -MSTACK(2,I) ELSE IF(MSTACK(1,I).EQ.3073) THEN LCTMPI(K) = I IXTMPI(K) = -MSTACK(2,I) ENDIF 65 CONTINUE ELSE IF(KDATA(1,I).EQ.3108 .OR. KDATA(1,I).EQ.3106 .OR. 1 KDATA(1,I).EQ.3105) THEN IF(KDATA(1,I).EQ.3108) THEN ISCHAN = 0 ELSE IF(KDATA(1,I).EQ.3106) THEN ISCHAN = 20 ELSE IF(KDATA(1,I).EQ.3105) THEN ISCHAN = 24 ENDIF 70 CONTINUE I = I + 1 IF(MSTACK(1,I).EQ.1322) THEN ICHAN = ISCHAN + KDATA(1,I) ICHINC = 0 GO TO 70 ELSE IF(MSTACK(1,I).EQ.1332) THEN ICHINC = KDATA(1,I) GO TO 70 ELSE IF(MSTACK(1,I).GT.16384 .AND. 1 MSTACK(1,I).LT.33024) THEN KPROF = MSTACK(1,I) - 16384 KREPL = MOD(KPROF,256) KFLDS = KPROF / 256 GO TO 70 ELSE IF(MSTACK(1,I).EQ.3135) THEN ICHAN = ICHAN + ICHINC LCRADR(ICHAN) = I IXRADR(ICHAN) = -MSTACK(2,I) IF(ICHAN-ISCHAN.GE.KREPL*ICHINC) THEN ISCHAN = 0 ENDIF GO TO 70 ELSE IF(MSTACK(1,I).GE.33024) THEN GO TO 70 ELSE I = I - 1 ENDIF ELSE IF(KDATA(1,I).EQ.3620 .OR. KDATA(1,I).EQ.3618 .OR. 1 KDATA(1,I).EQ.3617) THEN IF(KDATA(1,I).EQ.3620) THEN ISCHAN = 0 ELSE IF(KDATA(1,I).EQ.3618) THEN ISCHAN = 20 ELSE IF(KDATA(1,I).EQ.3617) THEN ISCHAN = 24 ENDIF 80 CONTINUE I = I + 1 IF(MSTACK(1,I).EQ.1322) THEN ICHAN = ISCHAN + KDATA(1,I) ICHINC = 0 GO TO 80 ELSE IF(MSTACK(1,I).EQ.1332) THEN ICHINC = KDATA(1,I) GO TO 80 ELSE IF(MSTACK(1,I).GT.16384 .AND. 1 MSTACK(1,I).LT.33024) THEN KPROF = MSTACK(1,I) - 16384 KREPL = MOD(KPROF,256) KFLDS = KPROF / 256 GO TO 80 ELSE IF(MSTACK(1,I).EQ.3135) THEN ICHAN = ICHAN + ICHINC LCRDRC(ICHAN) = I IXRDRC(ICHAN) = -MSTACK(2,I) IF(ICHAN-ISCHAN.GE.KREPL*ICHINC) THEN ISCHAN = 0 ENDIF GO TO 80 ELSE IF(MSTACK(1,I).GE.33024) THEN GO TO 80 ELSE I = I - 1 ENDIF ELSE IF(KDATA(1,I).EQ.8208) THEN I = I + 1 KPROF = MSTACK(1,I) - 16384 KREPL = MOD(KPROF,256) KFLDS = KPROF / 256 DO 85 K = 1 , KREPL DO 85 J = 1 , KFLDS I = I + 1 IF(MSTACK(1,I).EQ.1330) THEN LCSIGF(K) = I IXSIGF(K) = -MSTACK(2,I) ELSE IF(MSTACK(1,I).EQ.3073) THEN LCTMPF(K) = I IXTMPF(K) = -MSTACK(2,I) ELSE IF(MSTACK(1,I).EQ.3330) THEN LCMIXF(K) = I IXMIXF(K) = -MSTACK(2,I) ENDIF 85 CONTINUE ELSE IF(KDATA(1,I).EQ.10240) THEN I = I + 1 KPROF = MSTACK(1,I) - 16384 KREPL = MOD(KPROF,256) KFLDS = KPROF / 256 DO 90 K = 1 , KREPL DO 90 J = 1 , KFLDS I = I + 1 IF(MSTACK(1,I).EQ.1330) THEN LCSIGR(K) = I IXSIGR(K) = -MSTACK(2,I) ELSE IF(MSTACK(1,I).EQ.3073) THEN LCTMPR(K) = I IXTMPR(K) = -MSTACK(2,I) ELSE IF(MSTACK(1,I).EQ.3330) THEN LCMIXR(K) = I IXMIXR(K) = -MSTACK(2,I) ENDIF 90 CONTINUE ELSE IF(KDATA(1,I).EQ.4096) THEN I = I + 1 KPROF = MSTACK(1,I) - 16384 KREPL = MOD(KPROF,256) KFLDS = KPROF / 256 I = I + (KREPL - 1) * KFLDS DO 95 J = 1 , KFLDS I = I + 1 IF(MSTACK(1,I).EQ.1796) THEN LCP41I = I IXP41I = -MSTACK(2,I) ELSE IF(MSTACK(1,I).EQ.3073) THEN LCT41I = I IXT41I = -MSTACK(2,I) ELSE IF(MSTACK(1,I).EQ.3330) THEN LCM41I = I IXM41I = -MSTACK(2,I) ENDIF 95 CONTINUE ENDIF ENDIF IF(I.LT.NDESC) GO TO 20 C RETURN END SUBROUTINE FI8103(MSTACK,KDATA,NDESC) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: FI8103 GETS INFO TO UNPACK BUFR ANALYSIS INTERP C PRGMMR: BERT B. KATZ ORG: W/NMC23 DATE: 93-06-09 C GENERAL C SCIENCES CORP. C C ABSTRACT: USES BUFR DESCRIPTOR STACK AND DATA TO DETERMINE C ARRAY LOCATIONS AND SCALING FOR ANALYSIS INTERPOLATION C QUANTITIES TO BE RETURNED TO W3FI81. C C PROGRAM HISTORY LOG: C 93-06-09 BERT B. KATZ C C USAGE: CALL FI8103(MSTACK,KDATA,NDESC) C INPUT ARGUMENT LIST: C MSTACK - ARRAY CONTAINING BUFR DESCRIPTORS AND SCALING C - FOR ANALYSIS INTERPOLATION DATA. C KDATA - BUFR DATA IN INTEGER FORM. C NDESC - NUMBER OF DESCRIPTORS IN ARRAY MSTACK. C C REMARKS: CALLED BY SUBROUTINE W3FI81. RETURNS OUTPUT THOUGH C COMMON BLOCK /FI81IA/. C C ATTRIBUTES: C LANGUAGE: VS FORTRAN, CFT77 C MACHINE: HDS OR CRAY C C$$$ C PARAMETER (MXRPTR=100,MXDSCR=200) PARAMETER (NMLO=28) PARAMETER (NML=70) INTEGER MSTACK(2,MXDSCR) INTEGER KDATA(MXRPTR,MXDSCR) C COMMON /FI81AN/ LCSTIA , LCYRA , LCMONA , 1 LCDAYA , LCHRA , LCMINA , 2 LCLATA , IXLATA , 3 LCLONA , IXLONA , 4 LCPSFA , IXPSFA , 5 LCSFHA , IXSFHA , 6 LCNMCA , LWNMCA , 7 LCSIGA(NMLO), IXSIGA(NMLO), 8 LCTMPA(NMLO), IXTMPA(NMLO), 9 LCMIXA(NMLO), IXMIXA(NMLO), A LCRADA(27) , IXRADA(27) , B LCRDAC(27) , IXRDAC(27) C C FIND LOCATIONS AND SCALING C I=0 20 CONTINUE I = I + 1 IF(MSTACK(1,I).EQ.263) THEN LCSTIA = I ELSE IF(MSTACK(1,I).EQ.1282) THEN LCLATA = I IXLATA = -MSTACK(2,I) ELSE IF(MSTACK(1,I).EQ.1538) THEN LCLONA = I IXLONA = -MSTACK(2,I) ELSE IF(MSTACK(1,I).EQ.451) THEN IF(MSTACK(1,I-1).NE.451) THEN NBITS = MSTACK(1,I-1) - 34304 IF(NBITS.GT.0) THEN LCNMCA = I LBNMCA = NBITS / 8 LWNMCA = (LBNMCA - 1) / 4 + 1 ENDIF ENDIF ELSE IF(MSTACK(1,I).EQ.2280) THEN IF(KDATA(1,I).EQ.256) THEN 30 CONTINUE I = I + 1 IF(MSTACK(1,I).EQ.1793) THEN LCSFHA = I IXSFHA = -MSTACK(2,I) GO TO 30 ELSE IF(MSTACK(1,I).EQ.2564) THEN LCPSFA = I IXPSFA = -MSTACK(2,I) GO TO 30 ELSE IF(MSTACK(1,I).EQ.1025) THEN LCYRA = I GO TO 30 ELSE IF(MSTACK(1,I).EQ.1026) THEN LCMONA = I GO TO 30 ELSE IF(MSTACK(1,I).EQ.1027) THEN LCDAYA = I GO TO 30 ELSE IF(MSTACK(1,I).EQ.1028) THEN LCHRA = I GO TO 30 ELSE IF(MSTACK(1,I).EQ.1029) THEN LCMINA = I GO TO 30 ELSE IF(MSTACK(1,I).NE.2051 .AND. MSTACK(1,I).NE.2280) THEN GO TO 30 ELSE I = I - 1 ENDIF ELSE IF(KDATA(1,I).EQ.8448) THEN I = I + 1 KPROF = MSTACK(1,I) - 16384 KREPL = MOD(KPROF,256) KFLDS = KPROF / 256 DO 40 K = 1 , KREPL DO 40 J = 1 , KFLDS I = I + 1 IF(MSTACK(1,I).EQ.1330) THEN LCSIGA(K) = I IXSIGA(K) = -MSTACK(2,I) ELSE IF(MSTACK(1,I).EQ.3073) THEN LCTMPA(K) = I IXTMPA(K) = -MSTACK(2,I) ELSE IF(MSTACK(1,I).EQ.3330) THEN LCMIXA(K) = I IXMIXA(K) = -MSTACK(2,I) ENDIF 40 CONTINUE ELSE IF(KDATA(1,I).EQ.1316 .OR. KDATA(1,I).EQ.1314 .OR. 1 KDATA(1,I).EQ.1313) THEN IF(KDATA(1,I).EQ.1316) THEN ISCHAN = 0 ELSE IF(KDATA(1,I).EQ.1314) THEN ISCHAN = 20 ELSE IF(KDATA(1,I).EQ.1313) THEN ISCHAN = 24 ENDIF 50 CONTINUE I = I + 1 IF(MSTACK(1,I).EQ.1322) THEN ICHAN = ISCHAN + KDATA(1,I) ICHINC = 0 GO TO 50 ELSE IF(MSTACK(1,I).EQ.1332) THEN ICHINC = KDATA(1,I) GO TO 50 ELSE IF(MSTACK(1,I).GT.16384 .AND. 1 MSTACK(1,I).LT.33024) THEN KPROF = MSTACK(1,I) - 16384 KREPL = MOD(KPROF,256) KFLDS = KPROF / 256 GO TO 50 ELSE IF(MSTACK(1,I).EQ.3135) THEN ICHAN = ICHAN + ICHINC LCRADA(ICHAN) = I IXRADA(ICHAN) = -MSTACK(2,I) IF(ICHAN-ISCHAN.GE.KREPL*ICHINC) THEN ISCHAN = 0 ENDIF GO TO 50 ELSE IF(MSTACK(1,I).GE.33024) THEN GO TO 50 ELSE I = I - 1 ENDIF ELSE IF(KDATA(1,I).EQ.1828 .OR. KDATA(1,I).EQ.1826 .OR. 1 KDATA(1,I).EQ.1825) THEN IF(KDATA(1,I).EQ.1828) THEN ISCHAN = 0 ELSE IF(KDATA(1,I).EQ.1826) THEN ISCHAN = 20 ELSE IF(KDATA(1,I).EQ.1825) THEN ISCHAN = 24 ENDIF 60 CONTINUE I = I + 1 IF(MSTACK(1,I).EQ.1322) THEN ICHAN = ISCHAN + KDATA(1,I) ICHINC = 0 GO TO 60 ELSE IF(MSTACK(1,I).EQ.1332) THEN ICHINC = KDATA(1,I) GO TO 60 ELSE IF(MSTACK(1,I).GT.16384 .AND. 1 MSTACK(1,I).LT.33024) THEN KPROF = MSTACK(1,I) - 16384 KREPL = MOD(KPROF,256) KFLDS = KPROF / 256 GO TO 60 ELSE IF(MSTACK(1,I).EQ.3135) THEN ICHAN = ICHAN + ICHINC LCRDAC(ICHAN) = I IXRDAC(ICHAN) = -MSTACK(2,I) IF(ICHAN-ISCHAN.GE.KREPL*ICHINC) THEN ISCHAN = 0 ENDIF GO TO 60 ELSE IF(MSTACK(1,I).GE.33024) THEN GO TO 60 ELSE I = I - 1 ENDIF ENDIF ENDIF IF(I.LT.NDESC) GO TO 20 C RETURN END SUBROUTINE FI8104(PSFC,PR,TP,WP,PTOV,TTOV,WTOV,NML) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: FI8104 INTERPOLATES FROM MODEL TO TOVS LEVELS C PRGMMR: BERT B. KATZ ORG: W/NMC23 DATE: 93-08-26 C GENERAL C SCIENCES CORP. C C ABSTRACT: USING INPUT RETRIEVAL-LEVEL PRESSURES, INTERPOLATES C TEMPERATURE AND MIXING RATIO FROM MODEL LEVELS TO THE 40 TOVS C LEVELS. C C PROGRAM HISTORY LOG: C 91-05-13 M. GOLDBERG (NESDIS) C 92-10-20 T. GARDNER (NESDIS) C 93-08-26 BERT B. KATZ MODIFIED FOR NMC OPERATIONAL USE. C C C USAGE: CALL FI8104(PSFC,PR,TP,WP,PTOV,TTOV,WTOV,NML) C INPUT ARGUMENT LIST: C PSFC - SURFACE PRESSURE (MB). C PR - PRESSURE (MB) ON MODEL SIGMA LEVELS. C TP - TEMPERATURE (DEG K) ON MODEL SIGMA LEVELS. C WP - MIXING RATIO (G/KG) ON MODEL SIGMA LEVELS. C PTOV - TOVS 40 PRESSURE LEVELS (MB). C NML - NUMBER OF MODEL SIGMA LEVELS. C C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) C TTOV - TEMPERATURE (DEG K) ON 40 TOVS LEVELS. C WTOV - MIXING RATIO (G/KG) ON 40 TOVS LEVELS. C C OUTPUT FILES: C FT06F001 - USED FOR DEBUG PRINTOUT. C C ATTRIBUTES: C LANGUAGE: VS FORTRAN, CFT77 C MACHINE: HDS OR CRAY. C C$$$ C C REAL PR(NML),TP(NML),WP(NML),PTOV(40),TTOV(40),WTOV(40) REAL PX(29),TX(29),WX(29) C C C REMEMBER THAT NML = NUMBER OF MODEL LEVELS C DO 100 I = 1,NML PX(I) = PR(I) TX(I) = TP(I) WX(I) = WP(I) 100 CONTINUE C C INVENT SURFACE QUANTITIES TO BOUND LOWER END FOR PURPOSE OF C INTERPOLATION C C PRINT*,'PSFC=',PSFC C PRINT*, 'PX=',PX TX(NML+1)=TX(NML)+0.065*(1001.0-PSFC) WX(NML+1)=WX(NML)*((1001.0/PX(NML))**(.005*PX(NML)-1.5)) PX(NML+1)=1001.0 C C...MAKE SURE FOR CASES WHERE HIGHEST PRESS LEVEL IS BELOW HIGHEST C...TOVS LEVEL THAT INTERP. WILL BE PERFORMED. C IF (PX(1) .GT. PTOV(1)) PX(1) = PTOV(1) C C...INTERPOLATE FORECAST TEMPERATURE AND WATER VAPOR PROFILES TO C...THE 40 TOVS PRESSURE LEVELS. (FROM 1.0 MB TO 1000 MB) C...INITIALIZE TTOV AND WTOV VECTORS WITH THE OPERATIONAL RETRIEVALS C DO 800 I = 1,40 C C...EXTRACT PRESSURE (MB) FOR TOVS LEVEL I. C PY = PTOV(I) C C...LOOP THROUGH THE MEAN PRESSURES OF EACH LAYER C...TO DETERMINE IF THE PRESSURE, PY, AT EACH TOVS LEVEL I C...LIES BETWEEN THEM. C DO 300 J=1,NML DF1= PY - PX(J+1) DF2= PY - PX(J) IF(DF1.LE.0..AND.DF2.GE.0.) GO TO 350 300 CONTINUE C C...INTERPOLATE TEMPERATURE AND MOISTURE INFORMATION TO THE 40 TOVS C...LEVELS USING THE FOLLOWING INTERPOLATION FORMULA WHICH IS LINEAR C...WITH RESPECT TO THE NATURAL LOGARITHM OF PRESSURE. C 350 FAC = ALOG(PX(J)/PY) / ALOG(PX(J)/PX(J+1)) TTOV(I) = TX(J) +(TX(J+1)-TX(J))*FAC WTOV(I) = WX(J) +(WX(J+1)-WX(J))*FAC 800 CONTINUE C WRITE(6,*) ' TTOV=',TTOV C WRITE(6,*) ' WTOV=',WTOV RETURN END SUBROUTINE FI8105(PTOVS,TMP,WVMR,ZHGT,NBUG) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: FI8105 GEO. HGT. FROM TOVS 40-LEVEL TEMP, RATMIX C PRGMMR: BERT B. KATZ ORG: W/NMC23 DATE: 93-08-26 C GENERAL C SCIENCES CORP. C C ABSTRACT: CALCULATES GEOPOTENTIAL HEIGHTS HYDROSTATICALLY FROM TOVS C 40-LEVEL RETRIEVAL. C C PROGRAM HISTORY LOG: C 93-06-02 MIKE FERGUSON (NESDIS) C 93-08-26 BERT B. KATZ MODIFIED FOR NMC OPERATIONAL USE. C C USAGE: CALL FI8105 (PTOVS,TMP,WVMR,ZHGT,NBUG) C INPUT ARGUMENT LIST: C PTOVS - TOVS 40 PRESSURE LEVELS (MB). C TMP - 40-LEVEL TOVS RTRVL TEMPS (DEG K). C WVMR - 40-LEVEL TOVS RTRVL MOISTURE (G/KG). C NBUG - DEBUG FLAG. C C OUTPUT ARGUMENT LIST: C ZHGT - GEOPOTENTIAL HEIGHTS (M) AT 40 TOVS LEVELS. C C REMARKS: USES COMMON TPRES. CALLS SUBROUTINE IATROP TO CALCULATE C TROPOPAUSE PRESSURE AND TEMPERATURE VIA SPLINE FITTING TECHNIQUE. C C PARAMETERS- C VARIABLE TYPE FUNCTION C -------- ---- -------- C CONS REAL GAS CONSTANT FOR DRY AIR C (287 J/KG K) DIVIDED BY 2 * G C (9.8M/S**2). C ATTRIBUTES: C LANGUAGE: VS FORTRAN, CFT77 C MACHINE: HDS OR CRAY C C$$$ C REAL WVMR(40),TVIRT(40),ZHGT(40),PTOVS(40),TMP(40) DATA CONS/-14.6435/ C C...INITIALIZE GEOP. HIEGHTS ARRAY C C PRINT *, 'NBUG IN FI8105 IS ',NBUG DO 5 I = 1,40 ZHGT(I) = 0.0 5 CONTINUE C C...COMPUTE VIRTUAL TEMPERATURES(DEGREES KELVIN). C DO 40 L = 1 , 40 TVIRT(L) = TMP(L) + WVMR(L) / 6.0 40 CONTINUE C7/20 IF(MOD(NBUG,100).EQ.0)THEN C7/20 PRINT *, 'TEMPS INSIDE FI8105 ,1000,700,500,300 = ', C7/20+TMP(40),TMP(35),TMP(31),TMP(26) C7/20 PRINT *, 'V TEMPS INSIDE FI8105 ,1000,700,500,300 = ', C7/20+TVIRT(40),TVIRT(35),TVIRT(31),TVIRT(26) C7/20 ENDIF C C...COMPUTE GEOPOTENTIAL HEIGHTS (METERS) AT TOVS LEVELS. C DO 60 J = 2,40 I = 40 + 1 - J DLP = ALOG(PTOVS(I)/PTOVS(I+1)) ZHGT(I) = ZHGT(I+1) + (TVIRT(I)+TVIRT(I+1)) * DLP * CONS 60 CONTINUE C7/20 IF(MOD(NBUG,100).EQ.0)THEN C7/20 PRINT *, 'GEOPOTENTIALS INSIDE FI8105,1000,700,500,300 = ', C7/20+ZHGT(40),ZHGT(35),ZHGT(31),ZHGT(26) C7/20 ENDIF RETURN END SUBROUTINE FI8106(PTOVS,TVGPHT,ZHT,STDPTT,STDPLW,STDPUP,NBUG) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: FI8106 CALCULATES STABILITY DEPARTURES C PRGMMR: BERT B. KATZ ORG: W/NMC23 DATE: 93-08-26 C GENERAL C SCIENCES CORP. C C ABSTRACT: USING INPUT GEOPOTENTIAL HEIGHTS FROM TWO SOURCES, C CALCULATES LAYER-MEAN VIRTUAL TEMPERATURES FOR BOTH SOURCES C AND THE DIFFERENCE IN STABILITY FOR THE 1000 MB - 700 MB LAYER, C THE 500 MB - 300 MB LAYER, AND THE DIFFERENCE BETWEEN THESE TWO C LAYERS. C C PROGRAM HISTORY LOG: C 93-06-01 MIKE FERGUSON (NESDIS) C 93-08-26 BERT B. KATZ MODIFIED FOR NMC OPERATIONAL USE. C C C USAGE: CALL FI8106(PTOVS,TVGPHT,ZHT,STDPTT,STDPLW,STDPUP,NBUG) C INPUT ARGUMENT LIST: C PTOVS - TOVS 40 PRESSURE LEVELS (MB). C TVGPHT - GEOPOTENTIAL HEIGHTS (M) FROM SOURCE 1. C ZHT - GEOPOTENTIAL HEIGHTS (M) FROM SOURCE 2. C NBUG - DEBUG FLAG. C C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) C STDPTT - STABILITY DEPARTURE BETWEEN SOURCE 1 AND SOURCE 2 : C DIFFERENCE BETWEEN 1000 MB - 700 MB LAYER AND C 500 MB - 300 MB LAYER. C STDPLW - STABILITY DEPARTURE BETWEEN SOURCE 1 AND SOURCE 2 C IN THE 1000 MB - 700 MB LAYER. C STDPUP - STABILITY DEPARTURE BETWEEN SOURCE 1 AND SOURCE 2 C IN THE 500 MB - 300 MB LAYER. C C OUTPUT FILES: C FT06F001 - USED FOR DEBUG PRINTOUT. C C ATTRIBUTES: C LANGUAGE: VS FORTRAN, CFT77 C MACHINE: HDS OR CRAY C C$$$ C REAL PTOVS(40) REAL ZHT(40),TVGPHT(40) C DATA CONS/-14.6435/ DATA CONSTL/6.6890756E-02/ DATA CONSTU/9.5786797E-02/ C C...INITIALIZE STABILITY DEPARTURE VALUES C STDPTT = -9999.9 STDPLW = -9999.9 STDPUP = -9999.9 C PRINT *, 'NBUG IN FI8106 = ',NBUG C C...COMPUTE STABILITY DEPARTURE FOR 6-HOUR GUESS C C C...COMPUTE STABILITY TERMS C RTUPDP = (TVGPHT(26) - TVGPHT(31)) * CONSTL RTLWDP = (TVGPHT(35) - TVGPHT(40)) * CONSTU RBUPDP = (ZHT(26) - ZHT(31)) * CONSTL RBLWDP = (ZHT(35) - ZHT(40)) * CONSTU C PRINT *, 'OPR RET 1000,700,500,300 GPH ',TVGPHT(40),TVGPHT(35), C +TVGPHT(31),TVGPHT(26) C PRINT *, 'GES 1000,700,500,300 GPH ',ZHT(40),ZHT(35), C +ZHT(31),ZHT(26) C C RTSDP=RETRIEVAL TOTAL STABILITY DEPARTURE,RTLWDP=LOWER STABILITY C RTUPDP=UPPER STABILITY C C C...COMPUTE STABILITY DEPARTURES C STDPLW = RTLWDP - RBLWDP STDPUP = RTUPDP - RBUPDP STDPTT = STDPLW - STDPUP C 8000 RETURN END