C**********************************************************************C C**********************************************************************C C**********************************************************************C C* D 1 R E A D M O D U L E *C C*--------------------------------------------------------------------*C C* THIS PROGRAM READS D1 HDF FORMAT FILES PRODUCED BY ISCCP *C C*--------------------------------------------------------------------*C C* CONTAINS: *C C* PROGRAM SAMPLE : EXAMPLE OF HOW TO USE THESE SUBROUTINES *C C* SUBROUTINE D1OPEN : POSITION FILE AT REQUESTED SDS *C C* SUBROUTINE D1READ : UNPACK D1 DATA FOR ONE LATITUDE BAND *C C* SUBROUTINE D1PHYS : CONVERT DATA IN LAT BAND TO PHYSICAL VALUES*C C* SUBROUTINE MIDPRS : CALCULATE MID-LAYER PRESSURES FOR GRID BOX *C C* SUBROUTINE RDANC : READ ANCILLARY DATA FILE *C C* SUBROUTINE PRINTI : PRINT COUNT VALUES FOR ONE GRID BOX *C C* SUBROUTINE PRINTR : PRINT PHYSICAL VALUES FOR ONE GRID BOX *C C* SUBROUTINE CENTER : CALCULATE CENTER LON/LAT OF GRID BOX *C C* SUBROUTINE TOTIR : CALCULATE TOTAL IR RADIANCE *C C* SUBROUTINE TOTVIS : CALCULATE TOTAL VS RADIANCE *C C* SUBROUTINE CLDHGT : CALCULATE CLOUD TOP HEIGHT IN METERS *C C* SUBROUTINE EQ2SQ : CONVERT EQUAL AREA MAP TO SQUARE MAP *C C* BLOCK DATA : CONVERSION TABLES AND EQUAL-AREA GRID INFO *C C**********************************************************************C C**********************************************************************C C**********************************************************************C C* THIS SAMPLE PROGRAM READS AN ENTIRE D1 FILE BY LOOPING OVER THE 72 C* LATITUDE BANDS ONE AT A TIME. FOR EACH PASS THROUGH THE LOOP, C* D1READ IS CALLED TO UNPACK THE DATA FOR THAT LAT BAND, AND THEN C* D1PHYS IS CALLED TO CONVERT THAT DATA TO PHYSICAL VALUES. CLOUD C* AMOUNT IS SAVED IN AN EQUAL-AREA ARRAY, THEN CONVERTED TO A C* SQUARE LAT/LON ARRAY AT THE END OF THE PROGRAM, AND WRITTEN OUT. C* USE OF THE OTHER SUBROUTINES IS ILLUSTRATED FOR A FEW GRID BOXES. C*--------------------------------------------------------------------*C C* Modifications *C C* April 2002 - The format of the ISCCP D1 hdf files was modified *C C* for all data after Jan. 1994. This software will read both file*C C* formats. C*--------------------------------------------------------------------*C PROGRAM SAMPLE C*--------------------------------------------------------------------*C C* D1 DATA *C C*--------------------------------------------------------------------*C C* NUMBER OF VARIABLES REPORTED IN EACH D1 GRID BOX PARAMETER ( MAXVAR = 202 ) C* GRIDS PARAMETER ( MAXLON = 144 ) PARAMETER ( MAXLAT = 72 ) PARAMETER ( MAXBOX = 6596 ) C* UNDEFINED VALUE FOR INTEGER VALUES PARAMETER ( IUNDEF = 255 ) C* UNDEFINED VALUE FOR FLOATING POINT VALUES PARAMETER ( RUNDEF = -1000.0 ) C* D1 DATA FOR ONE LATITUDE ZONE C* D1READ WILL SET NLON TO THE NUMBER OF EQUAL-AREA BOXES IN THE C* LATITUDE ZONE, AND SET IVAR TO THE INTEGER DATA. TO CONVERT C* TO PHYSICAL VALUES, CALL D1PHYS WHICH WILL TAKE THE DATA IN C* IVAR, CONVERT IT TO PHYSICAL VALUES, AND STORE IT IN RVAR. COMMON /D1DATA/ LAT,NLON,IVAR(MAXVAR,MAXLON),RVAR(MAXVAR,MAXLON) C* EQUAL AREA GRID INFO COMMON /D1GRID/ NCELLS(MAXLAT),ICELLS(MAXLAT) C* COUNT TO PHYSICAL VALUE CONVERSION TABLES PARAMETER ( MAXCNT = 255 ) COMMON/CNTTAB/TMPTAB(0:MAXCNT),TMPVAR(0:MAXCNT),PRETAB(0:MAXCNT), 1 RFLTAB(0:MAXCNT),TAUTAB(0:MAXCNT),PRWTAB(0:MAXCNT), 2 OZNTAB(0:MAXCNT) C* ARRAYS TO HOLD ONE DECODED VARIABLE AS EQUAL-AREA MAP, AND SQUARE MAP REAL EQMAP(MAXBOX) REAL SQMAP(MAXLON,MAXLAT) CHARACTER*100 STARS/'********************************************* $*******************************************************'/ C* NAME OF HDF FILE CHARACTER*33 HDFFILE/'HDF_LINK'/ C---------------------------------------------------------------------- C BYTE SWAP THE VDATA RECORDS BEFORE YOU READ ANY HDF INFORMATION C---------------------------------------------------------------------- C*--------------------------------------------------------------------*C C* READ ANCILARY DATA FILE IF PLANNING TO USE CLDHGT FUNCTION *C C* OR TO CONVERT EQUAL AREA GRID TO SQUARE GRID *C C*--------------------------------------------------------------------*C CALL RDANC(HDFFILE,IRC) IF ( IRC .NE. 0 ) GOTO 900 C*--------------------------------------------------------------------*C C* LOOP OVER UTC IN FILE FOR POSITIONING *C C*--------------------------------------------------------------------*C DO 600 IUTC=1,1 CALL D1OPEN(HDFFILE,IUTC,IRC) C*--------------------------------------------------------------------*C C* LOOP OVER LATITUDES, CALL D1READ SUBROUTINE FOR EACH LAT BAND *C C*--------------------------------------------------------------------*C IBOX = 0 IFULL = 0 DO 500 LAT=1,MAXLAT CALL D1READ(HDFFILE,IRC) C* CHECK FOR END OF FILE IF ( IRC .LT. 0 ) THEN GOTO 800 C* CHECK FOR READ ERROR ELSE IF ( IRC .GT. 0 ) THEN GOTO 920 END IF C*--------------------------------------------------------------------*C C* CONVERT TO PHYSICAL QUANTITIES IF DESIRED *C C* D1PHYS WILL CONVERT INTEGER COUNTS IN IVAR INTO PHYSICALS IN RVAR *C C*--------------------------------------------------------------------*C CALL D1PHYS C*--------------------------------------------------------------------*C C* LOOP OVER LONGITUDES TO PROCESS BOXES WITHIN THIS LAT BAND *C C*--------------------------------------------------------------------*C DO 400 LON=1,NLON IBOX = IBOX + 1 C* CHECK FOR EMPTY BOX IF ( IVAR(6,LON) .EQ. 255 ) GOTO 400 IFULL = IFULL + 1 C*--------------------------------------------------------------------*C C* DO WHATEVER YOU WANT TO DO WITH THE BOX HERE *C C*--------------------------------------------------------------------*C C* FOR THIS SAMPLE PROGRAM, JUST SELECT A FEW BOXES IF ( LAT .lt. 72 .AND. LON .LT. 144 ) THEN PRINT 310,STARS,LON,LAT 310 FORMAT(//,A100,//,1X,'PROCESSING EQUAL-AREA LON/LAT',2I10) C* PRINT CONTENTS OF IVAR - COUNTS CALL PRINTI(LON) C* PRINT CONTENTS OF RVAR - PHYSICAL VALUES CALL PRINTR(LON) C* FIND CENTER LON/LAT OF EQUAL AREA BOX CALL CENTER(LON) C* FIND TOTAL IR RADIANCE CALL TOTIR(LON) C* FIND TOTAL VIS RADIANCE CALL TOTVIS(LON) C* FIND ACTUAL PRESSURE LAYER MID-POINTS CALL MIDPRS(LON) C* FIND CLOUD HEIGHT IN METERS CALL CLDHGT(LON) END IF C* FOR THIS SAMPLE PROGRAM, SAVE CLOUD AMOUNT IN A GLOBAL EQUAL AREA MAP EQMAP(IBOX) = RVAR(12,LON) C*--------------------------------------------------------------------*C C* END OF LON,LAT LOOPS *C C*--------------------------------------------------------------------*C 400 CONTINUE 500 CONTINUE C*--------------------------------------------------------------------*C C* END OF UTC LOOP *C C*--------------------------------------------------------------------*C 600 CONTINUE C*--------------------------------------------------------------------*C C* NORMAL END *C C*--------------------------------------------------------------------*C 800 CONTINUE PRINT 810,IFULL 810 FORMAT(/1X,'NUMBER OF FULL BOXES:',I6) C* CONVERT EQUAL AREA MAP TO SQUARE MAP FOR DISPLAY PURPOSES CALL EQ2SQ(1,EQMAP,SQMAP) C* WRITE OUT THE SQUARE MAP LUNOUT = 90 OPEN(LUNOUT,ACCESS='DIRECT',RECL=576,FORM='UNFORMATTED') DO 850 J=1,MAXLAT WRITE(LUNOUT,REC=J) (SQMAP(I,J),I=1,MAXLON) 850 CONTINUE PRINT 860 860 FORMAT(/1X,'NORMAL END OF PROGRAM') STOP 0 C*--------------------------------------------------------------------*C C* ERROR ENDS *C C*--------------------------------------------------------------------*C 900 CONTINUE PRINT *,'ERROR: RDANC RC=',IRC STOP 999 910 CONTINUE PRINT *,'ERROR: D1OPEN RC=',IRC STOP 999 920 CONTINUE PRINT *,'ERROR: D1READ RC=',IRC STOP 999 END C**********************************************************************C C**********************************************************************C C**********************************************************************C C* NAME: D1OPEN *C C* DESCRIPTION: OPEN THE HDF FILE AND FIND REQUESTED SDS *C C**********************************************************************C C**********************************************************************C C**********************************************************************C SUBROUTINE D1OPEN(HDFFILE,IUTC,IRC) CHARACTER*(*) HDFFILE C* INTEGER IREFS(8)/11,13,15,17,19,21,23,25/ INTEGER IREF, ITAG/720/ INTEGER ID_HDF INTEGER HOPEN,DAGFIDL,DAGFID,DSRREF,DAGLAB,HCLOSE INTEGER DALLIST INTEGER*4 DFTAG_SD, LISTSIZE, DFS_MAXLEN CHARACTER*255 FILEID, LABEL PARAMETER (DFTAG_SD = 720) PARAMETER (LISTSIZE = 55) PARAMETER (DFS_MAXLEN = 132) CHARACTER*60 LABEL_LIST(DFS_MAXLEN*LISTSIZE) INTEGER NUM_OF_LABELS, ST_POS, REF_LIST(DFS_MAXLEN) ST_POS = 1 ID_HDF = HOPEN(HDFFILE,1,0) LENGTH = DAGFIDL(ID_HDF, 1) IRC = DAGFID(ID_HDF,FILEID,255,1) IRC = HCLOSE(ID_HDF) PRINT *,'FILE ID: ',FILEID(1:LENGTH) NUM_OF_LABELS = DALLIST(HDFFILE, DFTAG_SD, REF_LIST, $ LABEL_LIST, 10, DFS_MAXLEN, $ ST_POS) C* IREF = IREFS(IUTC) IREF = REF_LIST(IUTC) LENGTH = DAGLLEN(HDFFILE, ITAG, IREF) IRC = DAGLAB(HDFFILE, ITAG, IREF, LABEL, 255) IRC = DSRREF(HDFFILE, IREF) PRINT *,'FILE POSITIONED AT DATA LABEL: ',LABEL(1:10) RETURN END C**********************************************************************C C**********************************************************************C C**********************************************************************C C* NAME: D1READ *C C* DESCRIPTION: READ AND UNPACK D1 DATA FOR A SINGLE LATITUDE BAND *C C**********************************************************************C C**********************************************************************C C**********************************************************************C SUBROUTINE D1READ(HDFFILE,IRC) PARAMETER ( MAXVAR = 202 ) PARAMETER ( NUMBOX = 100 ) PARAMETER ( MAXLAT = 72 ) PARAMETER ( MAXLON = 144 ) PARAMETER ( IUNDEF = 255 ) PARAMETER ( RUNDEF = -1000.0 ) COMMON /D1BUFS/ CHRBUF(MAXVAR) CHARACTER*1 CHRBUF COMMON /D1DATA/ LAT,NLON,IVAR(MAXVAR,MAXLON),RVAR(MAXVAR,MAXLON) COMMON /D1GRID/ NCELLS(MAXLAT),ICELLS(MAXLAT) CHARACTER*(*) HDFFILE INTEGER ISTART(2)/1,1/ INTEGER ISIZE(2)/MAXVAR,1/ INTEGER ISTRIDE(2) INTEGER DSRSLAB INTEGER IDIM(2) C*--------------------------------------------------------------------*C C* INITIALIZE THE OUTPUT ARRAYS (IVAR AND RVAR) *C C*--------------------------------------------------------------------*C DO 100 LON=1,MAXLON DO 100 I=1,MAXVAR IVAR(I,LON) = IUNDEF RVAR(I,LON) = RUNDEF 100 CONTINUE C*--------------------------------------------------------------------*C C* LOOP OVER ALL BOXES FOR THIS LAT *C C*--------------------------------------------------------------------*C NLON = ICELLS(LAT) NPREV = NCELLS(LAT) IDIM(1) = MAXVAR IDIM(2) = 1 DO 500 LON=1,NLON IBOX = NPREV + LON ISTART(2) = IBOX IRC = DSRSLAB(HDFFILE,ISTART,ISIZE,ISTRIDE,CHRBUF,IDIM) DO 490 I=1,MAXVAR IVAR(I,LON) = ICHAR(CHRBUF(I)) 490 CONTINUE 500 CONTINUE C*--------------------------------------------------------------------*C C* END *C C*--------------------------------------------------------------------*C 900 CONTINUE RETURN END C**********************************************************************C C**********************************************************************C C**********************************************************************C C* NAME: EQ2SQ *C C* DESCRIPTION: CONVERT EQUAL AREA MAP TO SQUARE LAT/LON MAP FOR *C C* DISPLAY PURPOSES *C C* ISHIFT = 1 => SHIFT LONGITUDES TO BE IN RANGE -180 TO +180 *C C* ISHIFT ANY OTHER VALE => KEEP LONGITUDES IN RANGE 0 TO 360 *C C**********************************************************************C C**********************************************************************C C**********************************************************************C SUBROUTINE EQ2SQ(ISHIFT,EQMAP,SQMAP) PARAMETER ( MAXLON = 144 ) PARAMETER ( MAXLAT = 72 ) PARAMETER ( MAXBOX = 6596 ) REAL EQMAP(MAXBOX) REAL SQMAP(MAXLON,MAXLAT) C* EQUAL AREA GRID INFO COMMON /D1GRID/ NCELLS(MAXLAT),ICELLS(MAXLAT) COMMON /SQUARE/ LONLIM(2,MAXBOX) IBOX = 0 DO 200 LAT=1,MAXLAT DO 200 LON=1,ICELLS(LAT) IBOX = IBOX + 1 LONSQ1 = LONLIM(1,IBOX) LONSQ2 = LONLIM(2,IBOX) DO 100 ILON=LONSQ1,LONSQ2 LONSQ = ILON IF ( ISHIFT .EQ. 1 ) THEN LONSQ = LONSQ + MAXLON/2 IF ( LONSQ .GT. MAXLON ) LONSQ = LONSQ - MAXLON END IF SQMAP(LONSQ,LAT) = EQMAP(IBOX) 100 CONTINUE 200 CONTINUE RETURN END C**********************************************************************C C**********************************************************************C C**********************************************************************C C* NAME: D1PHYS *C C* DESCRIPTION: CONVERT DATA FOR ALL GRID BOXES WITHIN A SINGLE LAT *C C* BAND FROM INTEGER COUNTS TO FLOATING POINT *C C* PHYSICAL VALUES *C C**********************************************************************C C**********************************************************************C C**********************************************************************C SUBROUTINE D1PHYS PARAMETER ( PATHW = 6.292 ) PARAMETER ( PATHI = 10.5 ) PARAMETER ( MAXVAR = 202 ) PARAMETER ( NUMBOX = 100 ) PARAMETER ( MAXLON = 144 ) PARAMETER ( IUNDEF = 255 ) PARAMETER ( RUNDEF = -1000.0 ) COMMON /D1DATA/ LAT,NLON,IVAR(MAXVAR,MAXLON),RVAR(MAXVAR,MAXLON) PARAMETER ( MAXCNT = 255 ) COMMON/CNTTAB/TMPTAB(0:MAXCNT),TMPVAR(0:MAXCNT),PRETAB(0:MAXCNT), 1 RFLTAB(0:MAXCNT),TAUTAB(0:MAXCNT),PRWTAB(0:MAXCNT), 2 OZNTAB(0:MAXCNT) C*--------------------------------------------------------------------*C C* BOX ID *C C*--------------------------------------------------------------------*C DO 500 LON=1,NLON DO 90 I=1,7 IF ( IVAR(I,LON) .EQ. IUNDEF ) THEN RVAR(I,LON) = RUNDEF ELSE RVAR(I,LON) = IVAR(I,LON) ENDIF 90 CONTINUE C*--------------------------------------------------------------------*C C* VIEWING GEOMETRY *C C*--------------------------------------------------------------------*C DO 100 I=8,9 IF ( IVAR(I,LON) .EQ. IUNDEF ) THEN RVAR(I,LON) = RUNDEF ELSE RVAR(I,LON) = FLOAT(IVAR(I,LON)) / 100.0 ENDIF 100 CONTINUE IF ( IVAR(10,LON) .EQ. IUNDEF ) THEN RVAR(10,LON) = RUNDEF ELSE RVAR(10,LON) = IVAR(10,LON) ENDIF C*--------------------------------------------------------------------*C C* CLOUD AMOUNTS *C C*--------------------------------------------------------------------*C IF ( IVAR(11,LON) .EQ. IUNDEF ) THEN RVAR(11,LON) = RUNDEF ELSE RVAR(11,LON) = IVAR(11,LON) ENDIF DO 101 I=12,19 IF ( IVAR(I,LON) .EQ. IUNDEF ) THEN RVAR(I,LON) = RUNDEF ELSE RVAR(I,LON) = FLOAT(IVAR(I,LON)) / RVAR(11,LON) * 100.0 ENDIF 101 CONTINUE C*--------------------------------------------------------------------*C C* ALGORITHM STATS *C C*--------------------------------------------------------------------*C IF ( IVAR(20,LON) .EQ. IUNDEF ) THEN RVAR(20,LON) = RUNDEF ELSE RVAR(20,LON) = FLOAT(IVAR(20,LON)) / RVAR(11,LON) * 100.0 ENDIF DO 102 I=21,22 IF ( IVAR(I,LON) .EQ. IUNDEF ) THEN RVAR(I,LON) = RUNDEF ELSE RVAR(I,LON) = FLOAT(IVAR(I,LON)) / 100.0 ENDIF 102 CONTINUE C*--------------------------------------------------------------------*C C* CLOUD TYPE DISTRIBUTIONS *C C*--------------------------------------------------------------------*C DO 103 I=23,77 IF ( IVAR(I,LON) .EQ. IUNDEF ) THEN RVAR(I,LON) = RUNDEF ELSE RVAR(I,LON) = FLOAT(IVAR(I,LON)) / RVAR(11,LON) * 100.0 ENDIF 103 CONTINUE C*--------------------------------------------------------------------*C C* CONVERT AVERAGE AND VARIANCE OF THE CLOUD TOP PRESSURE *C C*--------------------------------------------------------------------*C DO 110 I=78,84 RVAR(I,LON) = PRETAB(IVAR(I,LON)) 110 CONTINUE C*--------------------------------------------------------------------*C C* CONVERT AVERAGE AND VARIANCE OF THE CLOUD TOP TEMPERATURE *C C*--------------------------------------------------------------------*C DO 120 I=85,90 RVAR(I,LON) = TMPTAB(IVAR(I,LON)) 120 CONTINUE RVAR(91,LON) = TMPVAR(IVAR(91,LON)) C*--------------------------------------------------------------------*C C* CONVERT TAU AND PATH *C C*--------------------------------------------------------------------*C DO 130 I=92,105 RVAR(I,LON) = TAUTAB(IVAR(I,LON)) 130 CONTINUE DO 135 I=99,105 IF ( RVAR(I,LON).GE.0.0 ) RVAR(I,LON) = RVAR(I,LON) * PATHW 135 CONTINUE C*--------------------------------------------------------------------*C C* CONVERT TC DISTRIBUTION *C C*--------------------------------------------------------------------*C DO 140 I=106,112 RVAR(I,LON) = TMPTAB(IVAR(I,LON)) 140 CONTINUE C*--------------------------------------------------------------------*C C* CONVERT CLOUD TYPES *C C*--------------------------------------------------------------------*C I = 113 DO 150 ITYP=1,15 RVAR(I,LON) = TMPTAB(IVAR(I,LON)) RVAR(I+1,LON) = TAUTAB(IVAR(I+1,LON)) I = I + 3 150 CONTINUE RVAR(115,LON) = TAUTAB(IVAR(115,LON)) IF ( RVAR(115,LON).GE.0.0 ) RVAR(115,LON) = RVAR(115,LON) * PATHW RVAR(118,LON) = TAUTAB(IVAR(118,LON)) IF ( RVAR(118,LON).GE.0.0 ) RVAR(118,LON) = RVAR(118,LON) * PATHW RVAR(121,LON) = TAUTAB(IVAR(121,LON)) IF ( RVAR(121,LON).GE.0.0 ) RVAR(121,LON) = RVAR(121,LON) * PATHW RVAR(124,LON) = TAUTAB(IVAR(124,LON)) IF ( RVAR(124,LON).GE.0.0 ) RVAR(124,LON) = RVAR(124,LON) * PATHI RVAR(127,LON) = TAUTAB(IVAR(127,LON)) IF ( RVAR(127,LON).GE.0.0 ) RVAR(127,LON) = RVAR(127,LON) * PATHI RVAR(130,LON) = TAUTAB(IVAR(130,LON)) IF ( RVAR(130,LON).GE.0.0 ) RVAR(130,LON) = RVAR(130,LON) * PATHI RVAR(133,LON) = TAUTAB(IVAR(133,LON)) IF ( RVAR(133,LON).GE.0.0 ) RVAR(133,LON) = RVAR(133,LON) * PATHW RVAR(136,LON) = TAUTAB(IVAR(136,LON)) IF ( RVAR(136,LON).GE.0.0 ) RVAR(136,LON) = RVAR(136,LON) * PATHW RVAR(139,LON) = TAUTAB(IVAR(139,LON)) IF ( RVAR(139,LON).GE.0.0 ) RVAR(139,LON) = RVAR(139,LON) * PATHW RVAR(142,LON) = TAUTAB(IVAR(142,LON)) IF ( RVAR(142,LON).GE.0.0 ) RVAR(142,LON) = RVAR(142,LON) * PATHI RVAR(145,LON) = TAUTAB(IVAR(145,LON)) IF ( RVAR(145,LON).GE.0.0 ) RVAR(145,LON) = RVAR(145,LON) * PATHI RVAR(148,LON) = TAUTAB(IVAR(148,LON)) IF ( RVAR(148,LON).GE.0.0 ) RVAR(148,LON) = RVAR(148,LON) * PATHI RVAR(151,LON) = TAUTAB(IVAR(151,LON)) IF ( RVAR(151,LON).GE.0.0 ) RVAR(151,LON) = RVAR(151,LON) * PATHI RVAR(154,LON) = TAUTAB(IVAR(154,LON)) IF ( RVAR(154,LON).GE.0.0 ) RVAR(154,LON) = RVAR(154,LON) * PATHI RVAR(157,LON) = TAUTAB(IVAR(157,LON)) IF ( RVAR(157,LON).GE.0.0 ) RVAR(157,LON) = RVAR(157,LON) * PATHI C*--------------------------------------------------------------------*C C* CONVERT AVERAGE OF THE SURFACE TEMPERATURE *C C*--------------------------------------------------------------------*C DO 160 I=158,161 RVAR(I,LON) = TMPTAB(IVAR(I,LON)) 160 CONTINUE RVAR(162,LON) = TMPVAR(IVAR(162,LON)) C*--------------------------------------------------------------------*C C* CONVERT AVERAGE OF THE REFLECTANCE *C C*--------------------------------------------------------------------*C DO 170 I=163,168 RVAR(I,LON) = RFLTAB(IVAR(I,LON)) 170 CONTINUE C*--------------------------------------------------------------------*C C* CONVERT AVERAGE AND VARIANCE OF THE IR RADIANCE *C C*--------------------------------------------------------------------*C RVAR(169,LON) = TMPTAB(IVAR(169,LON)) RVAR(170,LON) = TMPVAR(IVAR(170,LON)) RVAR(171,LON) = TMPTAB(IVAR(171,LON)) RVAR(172,LON) = TMPTAB(IVAR(172,LON)) RVAR(173,LON) = TMPVAR(IVAR(173,LON)) RVAR(174,LON) = TMPTAB(IVAR(174,LON)) RVAR(175,LON) = TMPTAB(IVAR(175,LON)) C*--------------------------------------------------------------------*C C* CONVERT AVERAGE AND VARIANCE OF THE VIS RADIANCE *C C*--------------------------------------------------------------------*C DO 180 I=176,182 RVAR(I,LON) = RFLTAB(IVAR(I,LON)) 180 CONTINUE C*--------------------------------------------------------------------*C C* FETCH THE ATMOSPHERE QC ( = 255 IF NO DATA ) *C C*--------------------------------------------------------------------*C RVAR(183,LON) = IVAR(183,LON) C*--------------------------------------------------------------------*C C* CONVERT SURFACE PRESSURE AND TEMPERATURE *C C*--------------------------------------------------------------------*C RVAR(184,LON) = PRETAB(IVAR(184,LON)) RVAR(185,LON) = TMPTAB(IVAR(185,LON)) C*--------------------------------------------------------------------*C C* CONVERT TEMPERATURE AT 7 STANDARD PRESSURE LEVELS *C C* NOMINALLY = 900, 740, 620, 500, 375, 245, 115 MILLIBARS *C C* TOP AND BOTTOM LAYERS ARE REALLY DEFINED BY SURFACE AND TROPOPAUSE *C C* PRESSURE. TO CALCULATE THE REAL LAYER MID-POINTS FOR A PARTICULAR *C C* GRID BOX, CALL SUBROUTINE MIDPRS *C C*--------------------------------------------------------------------*C DO 190 I = 186,192 RVAR(I,LON) = TMPTAB(IVAR(I,LON)) 190 CONTINUE C*--------------------------------------------------------------------*C C* CONVERT TROPOPAUSE PRESSURE AND TEMPERATURE *C C*--------------------------------------------------------------------*C RVAR(193,LON) = PRETAB(IVAR(193,LON)) RVAR(194,LON) = TMPTAB(IVAR(194,LON)) C*--------------------------------------------------------------------*C C* CONVERT STRATOSPHERE TEMPERATURES AT 70 AND 30 MB *C C*--------------------------------------------------------------------*C RVAR(195,LON) = TMPTAB(IVAR(195,LON)) RVAR(196,LON) = TMPTAB(IVAR(196,LON)) C*--------------------------------------------------------------------*C C* CONVERT PRECIPITABLE WATER FOR 5 LOWEST PRESSURE LAYERS *C C*--------------------------------------------------------------------*C DO 200 I=197,201 RVAR(I,LON) = PRWTAB(IVAR(I,LON)) 200 CONTINUE C*--------------------------------------------------------------------*C C* CONVERT O3-OZONE ABUNDANCE *C C*--------------------------------------------------------------------*C RVAR(202,LON) = OZNTAB(IVAR(202,LON)) C*--------------------------------------------------------------------*C C* END OF LON LOOP *C C*--------------------------------------------------------------------*C 500 CONTINUE C*--------------------------------------------------------------------*C C* NORMAL RETURN *C C*--------------------------------------------------------------------*C PRINT 510,LAT 510 FORMAT(1X,'D1PHYS: LAT BAND',I4,' CONVERTED TO PHYSICAL VALUES') RETURN END C**********************************************************************C C**********************************************************************C C**********************************************************************C C* NAME: MIDPRS *C C* DESCRIPTION: CALCULATE ACTUAL MID-POINTS FOR THE 7 STANDARD *C C* PRESSURE LAYERS FOR A PARTICULAR GRID BOX *C C**********************************************************************C C**********************************************************************C C**********************************************************************C SUBROUTINE MIDPRS(LON) PARAMETER ( MAXVAR = 202 ) PARAMETER ( MAXLON = 144 ) PARAMETER ( RUNDEF = -1000.0 ) COMMON /D1DATA/ LAT,NLON,IVAR(MAXVAR,MAXLON),RVAR(MAXVAR,MAXLON) PARAMETER ( NLAYER = 7 ) PARAMETER ( NBOUND = NLAYER + 1 ) REAL*4 PRSMID(NLAYER) REAL*4 PBOUND(NBOUND) $ /1000.,800.,680.,560.,440.,310.,180.,30./ PSURF = RVAR(184,LON) PTROP = RVAR(193,LON) LYRSRF = 1 LYRTRP = NLAYER DO 10 IBOUND=2,NBOUND IF ( PSURF .LE. PBOUND(IBOUND) ) LYRSRF = IBOUND IF ( PTROP .GT. PBOUND(IBOUND) ) LYRTRP = IBOUND-1 10 CONTINUE DO 20 ILAYER=1,NLAYER IF ( ILAYER .LT. LYRSRF .OR. ILAYER .GT. LYRTRP ) THEN PRSMID(ILAYER) = RUNDEF ELSE IF ( ILAYER .EQ. LYRSRF ) THEN PRSMID(ILAYER) = ( PSURF + PBOUND(ILAYER+1) ) * 0.5 ELSE IF ( ILAYER .EQ. LYRTRP ) THEN PRSMID(ILAYER) = ( PTROP + PBOUND(ILAYER) ) * 0.5 ELSE PRSMID(ILAYER) = ( PBOUND(ILAYER) + PBOUND(ILAYER+1) ) * 0.5 END IF 20 CONTINUE PRINT 90,PRSMID 90 FORMAT(/1X,'MIDPRS: ACTUAL PRESSURE LAYER MID-POINTS (MB)',7F8.2) RETURN END C**********************************************************************C C**********************************************************************C C**********************************************************************C C* NAME: RDANC *C C* DESCRIPTION: READ D1 ANCILARY DATA FILE (FILE DESCRIPTION 4) *C C* AND SAVE TOPOGRAPHIC HEIGHT FOR CLOUD HEIGHT *C C* CALCULATION *C C**********************************************************************C C**********************************************************************C C**********************************************************************C SUBROUTINE RDANC(HDFFILE,IRC) PARAMETER ( MAXBOX = 6596 ) PARAMETER ( MAXLINE = 6598 ) COMMON /HEIGHT/ ITOPOG(MAXBOX) COMMON /SQUARE/ LONLIM(2,MAXBOX) CHARACTER*80 ANCIL(MAXLINE) CHARACTER*(*) HDFFILE INTEGER HOPEN,HCLOSE,DAGFDSL,DAGFDS ID_HDF = HOPEN(HDFFILE,1,0) ISFIRST = 1 DO 10 I=1,3 LENGTH = DAGFDSL(ID_HDF,ISFIRST) IRC = DAGFDS(ID_HDF,ANCIL,1,ISFIRST) ISFIRST = 0 10 CONTINUE LENGTH = DAGFDSL(ID_HDF,ISFIRST) C FIND OUT IF THE ANCILLARY FILE IS PRESENT AND DECODE IT C OR READ THE ANCILLARY VALUES FROM THE VDATA RECORD AND C STORE THE VALUES INTO THE ANCILLARY ARRAY. if(LENGTH .LT. 740) THEN CALL VDATASUB(ID_HDF) ELSE IRC = DAGFDS(ID_HDF,ANCIL,LENGTH,ISFIRST) DO 100 ILINE=3,MAXBOX+2 READ(UNIT=ANCIL(ILINE),FMT=110) IBOX,J,I,LONBEG,LONEND, $ CENLAT,CENLON,IAREA,LANDFR,ITOPOG(IBOX),IVEG, $ ISAT1,ISAT2,ISAT3,ISAT4 LONLIM(1,IBOX) = LONBEG LONLIM(2,IBOX) = LONEND 100 CONTINUE 110 FORMAT(5I4,2F9.2,I8,I6,I7,5I4) ENDIF IRC = HCLOSE(ID_HDF) RETURN END C**********************************************************************C C**********************************************************************C C**********************************************************************C C* NAME: VDATASUB *C C* DESCRIPTION: READ D1 ANCILLARY DATA FILE IN THE VDATA FIELD *C C**********************************************************************C C**********************************************************************C C**********************************************************************C SUBROUTINE VDATASUB(ID_HDF) PARAMETER ( MAXBOX = 6596 ) COMMON /HEIGHT/ ITOPOG(MAXBOX) COMMON /SQUARE/ LONLIM(2,MAXBOX) CHARACTER*7 STR CHARACTER*1 ACCESS INTEGER VSFGID,VSFATCH,VDATA_REF INTEGER VFSTART INTEGER VDATA_ID,STATUS INTEGER IBOX(MAXBOX) REAL DATA(6596) VDATA_REF=-1 ACCESS = "w" STATUS = VFSTART(ID_HDF) VDATA_ID = VSFATCH(ID_HDF, VDATA_REF, ACCESS) VDATA_REF = VSFGID(ID_HDF,VDATA_REF) ACCESS = "r" C THIS ROUTINE DECODES 15 FIELDS FROM THE HDF VDATA RECORD. C THESE ARE THE ANCILLARY FILE FIELD NAMES. C C GRD BOX STR="IBOX" CALL NEXT_VD_FIELD(ID_HDF,STATUS,VDATA_ID,ACCESS,VDATA_REF,DATA, & STR,NRECS) DO 10 I = 1 ,MAXBOX IBOX(I) = DATA(I) 10 CONTINUE C LAT IND STR="J" CALL NEXT_VD_FIELD(ID_HDF,STATUS,VDATA_ID,ACCESS,VDATA_REF,DATA, & STR,NRECS) C LON IND STR="I" CALL NEXT_VD_FIELD(ID_HDF,STATUS,VDATA_ID,ACCESS,VDATA_REF,DATA, & STR,NRECS) C SQ1 IND STR="LONBEG" CALL NEXT_VD_FIELD(ID_HDF,STATUS,VDATA_ID,ACCESS,VDATA_REF,DATA, & STR,NRECS) DO 20 I = 1 ,MAXBOX LONLIM(1,IBOX(I)) = DATA(I) 20 CONTINUE C SQ2 IND STR="LONEND" CALL NEXT_VD_FIELD(ID_HDF,STATUS,VDATA_ID,ACCESS,VDATA_REF,DATA, & STR,NRECS) DO 30 I = 1 ,MAXBOX LONLIM(2,IBOX(I)) = DATA(I) 30 CONTINUE C LAT CENTER STR="CENLAT" CALL NEXT_VD_FIELD(ID_HDF,STATUS,VDATA_ID,ACCESS,VDATA_REF,DATA, & STR,NRECS) C LON CENTER STR="CENLON" CALL NEXT_VD_FIELD(ID_HDF,STATUS,VDATA_ID,ACCESS,VDATA_REF,DATA, & STR,NRECS) C BOX AREA STR="IAREA" CALL NEXT_VD_FIELD(ID_HDF,STATUS,VDATA_ID,ACCESS,VDATA_REF,DATA, & STR,NRECS) C PER LAND STR="LANDFR" CALL NEXT_VD_FIELD(ID_HDF,STATUS,VDATA_ID,ACCESS,VDATA_REF,DATA, & STR,NRECS) C TOPOG HEIGHT STR="ITOPOG" CALL NEXT_VD_FIELD(ID_HDF,STATUS,VDATA_ID,ACCESS,VDATA_REF,DATA, & STR,NRECS) DO 40 I = 1 ,MAXBOX ITOPOG(I) = DATA(I) 40 CONTINUE C VEG TYPE STR="IVEG" CALL NEXT_VD_FIELD(ID_HDF,STATUS,VDATA_ID,ACCESS,VDATA_REF,DATA, & STR,NRECS) C SAT 1ST STR="ISAT1" CALL NEXT_VD_FIELD(ID_HDF,STATUS,VDATA_ID,ACCESS,VDATA_REF,DATA, & STR,NRECS) C PREF 2ND STR="ISAT2" CALL NEXT_VD_FIELD(ID_HDF,STATUS,VDATA_ID,ACCESS,VDATA_REF,DATA, & STR,NRECS) C PREF 3RD STR="ISAT3" CALL NEXT_VD_FIELD(ID_HDF,STATUS,VDATA_ID,ACCESS,VDATA_REF,DATA, & STR,NRECS) C PREF 4TH STR="ISAT4" CALL NEXT_VD_FIELD(ID_HDF,STATUS,VDATA_ID,ACCESS,VDATA_REF,DATA, & STR,NRECS) END C**********************************************************************C C**********************************************************************C C**********************************************************************C C* NAME: NEXT_VD_FIELD *C C* DESCRIPTION: OBTAIN THE NEXT FIELD IN THE VDATA *C C**********************************************************************C C**********************************************************************C C**********************************************************************C SUBROUTINE NEXT_VD_FIELD(ID_HDF,STATUS,VDATA_ID,ACCESS,VDATA_REF $ ,DATA,STR,NRECS) CHARACTER*(*) ACCESS CHARACTER*7 VCLASS,VDATA_NAME,STR CHARACTER*512 VFIELDS,FIELDS INTEGER VDATA_ID,VSFATCH,ID_HDF,VDATA_REF,VSFINQ,NRECS INTEGER INTERLACE,VSIZE,STATUS REAL DATA(*) VDATA_NAME = " " VDATA_ID = VSFATCH(ID_HDF, VDATA_REF, ACCESS) STATUS=VSFINQ(VDATA_ID,NRECS,INTERLACE,VFIELDS,VSIZE,VDATA_NAME) STATUS = VSFGCLS(VDATA_ID,VCLASS) FIELDS = STR STATUS = VSFSFLD(VDATA_ID,FIELDS) STATUS = VSFREAD(VDATA_ID,DATA,NRECS,INTERLACE) STATUS = VSFDTCH(VDATA_ID) END C**********************************************************************C C**********************************************************************C C**********************************************************************C C* NAME: PRINTI *C C* DESCRIPTION: PRINT COUNT VALUES FOR THE BOX *C C**********************************************************************C C**********************************************************************C C**********************************************************************C SUBROUTINE PRINTI(LON) PARAMETER ( MAXVAR = 202 ) PARAMETER ( MAXLON = 144 ) COMMON /D1DATA/ LAT,NLON,IVAR(MAXVAR,MAXLON),RVAR(MAXVAR,MAXLON) PRINT 140 140 FORMAT(/1X,'PRINTI: COUNT VALUES FOR ALL VARIABLES') PRINT 145,(K,K=1,10) 145 FORMAT(1X,18X,10I8) DO 150 I=1,MAXVAR,10 IEND = I + 9 IF ( IEND .GT. MAXVAR ) IEND = MAXVAR PRINT 155,I,IEND,(IVAR(K,LON),K=I,IEND) 150 CONTINUE 155 FORMAT(1X,'VARIABLE (',I3.3,'-',I3.3,')',10I8) RETURN END C**********************************************************************C C**********************************************************************C C**********************************************************************C C* NAME: PRINTR *C C* DESCRIPTION: PRINT PHYSICAL VALUES FOR THE BOX *C C**********************************************************************C C**********************************************************************C C**********************************************************************C SUBROUTINE PRINTR(LON) PARAMETER ( MAXVAR = 202 ) PARAMETER ( MAXLON = 144 ) COMMON /D1DATA/ LAT,NLON,IVAR(MAXVAR,MAXLON),RVAR(MAXVAR,MAXLON) PRINT 140 140 FORMAT(/1X,'PRINTR: PHYSICAL VALUES FOR ALL VARIABLES') PRINT 145,(K,K=1,10) 145 FORMAT(1X,18X,10I8) DO 150 I=1,MAXVAR,10 IEND = I + 9 IF ( IEND .GT. MAXVAR ) IEND = MAXVAR PRINT 155,I,IEND,(RVAR(K,LON),K=I,IEND) 150 CONTINUE 155 FORMAT(1X,'VARIABLE (',I3.3,'-',I3.3,')',10F8.2) RETURN END C**********************************************************************C C**********************************************************************C C**********************************************************************C C* NAME: CENTER *C C* DESCRIPTION: CALCULATE CENTER LON/LAT OF BOX (EQUAL-AREA GRID) *C C**********************************************************************C C**********************************************************************C C**********************************************************************C SUBROUTINE CENTER(LON) PARAMETER ( DLAT = 2.5 ) PARAMETER ( MAXLAT = 72 ) COMMON /D1GRID/ NCELLS(MAXLAT),ICELLS(MAXLAT) PARAMETER ( MAXVAR = 202 ) PARAMETER ( MAXLON = 144 ) COMMON /D1DATA/ LAT,NLON,IVAR(MAXVAR,MAXLON),RVAR(MAXVAR,MAXLON) DLON = 360.0 / NLON CENLAT = ( LAT - 1 ) * DLAT + DLAT/2.0 - 90.0 CENLON = ( LON - 1 ) * DLON + DLON/2.0 PRINT 300,CENLON,CENLAT 300 FORMAT(/1X,'CENTER: CENTER LON/LAT',2F8.2) RETURN END C**********************************************************************C C**********************************************************************C C**********************************************************************C C* NAME: TOTIR *C C* DESCRIPTION: CALCULATE TOTAL IR RADIANCE FROM CLOUD/CLEAR RADIANCE*C C**********************************************************************C C**********************************************************************C C**********************************************************************C SUBROUTINE TOTIR(LON) PARAMETER ( MAXVAR = 202 ) PARAMETER ( MAXLON = 144 ) COMMON /D1DATA/ LAT,NLON,IVAR(MAXVAR,MAXLON),RVAR(MAXVAR,MAXLON) PARAMETER ( IUNDEF = 255 ) PARAMETER ( MAXCNT = 255 ) COMMON/CNTTAB/TMPTAB(0:MAXCNT),TMPVAR(0:MAXCNT),PRETAB(0:MAXCNT), 1 RFLTAB(0:MAXCNT),TAUTAB(0:MAXCNT),PRWTAB(0:MAXCNT), 2 OZNTAB(0:MAXCNT) PRINT 100 100 FORMAT(/1X,'TOTIR: IR RADIANCES') NTOT = IVAR(11,LON) NIRCLD = IVAR(13,LON) NIRCLR = NTOT - NIRCLD ICLD = IVAR(169,LON) ICLR = IVAR(172,LON) ITOT = NINT(FLOAT(NIRCLD*ICLD+NIRCLR*ICLR)/FLOAT(NTOT)) PRINT 210,NIRCLD,NIRCLR,NTOT, $ TMPTAB(ICLD),TMPTAB(ICLR),TMPTAB(ITOT) 210 FORMAT(10X,'USING IR CLOUD/CLEAR CATEGORIES', $ /16X,'NUMBER OF PIXELS CLOUD/CLEAR/TOTAL ',3I10, $ /16X,'RADIANCE (K) CLOUD/CLEAR/TOTAL ',3F10.2) NVSCLD = IVAR(12,LON) - IVAR(16,LON) NVSCLR = NTOT - NVSCLD ICLD = IVAR(171,LON) ICLR = IVAR(174,LON) IF ( IVAR(6,LON) .GT. 100 ) THEN ITOT = IUNDEF ELSE ITOT = NINT(FLOAT(NVSCLD*ICLD+NVSCLR*ICLR)/FLOAT(NTOT)) END IF PRINT 220,NVSCLD,NVSCLR,NTOT, $ TMPTAB(ICLD),TMPTAB(ICLR),TMPTAB(ITOT) 220 FORMAT(10X,'USING VIS/IR CLOUD/CLEAR CATEGORIES', $ /16X,'NUMBER OF PIXELS CLOUD/CLEAR/TOTAL ',3I10, $ /16X,'RADIANCE (K) CLOUD/CLEAR/TOTAL ',3F10.2) RETURN END C**********************************************************************C C**********************************************************************C C**********************************************************************C C* NAME: TOTVIS *C C* DESCRIPTION: CALCULATE TOTAL VS RADIANCE FROM CLOUD/CLEAR RADIANCE*C C**********************************************************************C C**********************************************************************C C**********************************************************************C SUBROUTINE TOTVIS(LON) PARAMETER ( MAXVAR = 202 ) PARAMETER ( MAXLON = 144 ) COMMON /D1DATA/ LAT,NLON,IVAR(MAXVAR,MAXLON),RVAR(MAXVAR,MAXLON) PARAMETER ( IUNDEF = 255 ) PARAMETER ( MAXCNT = 255 ) COMMON/CNTTAB/TMPTAB(0:MAXCNT),TMPVAR(0:MAXCNT),PRETAB(0:MAXCNT), 1 RFLTAB(0:MAXCNT),TAUTAB(0:MAXCNT),PRWTAB(0:MAXCNT), 2 OZNTAB(0:MAXCNT) C* PRINT 100,LON 100 FORMAT(/1X,'TOTVIS: VIS RADIANCES') NTOT = IVAR(11,LON) NIRCLD = IVAR(13,LON) NIRCLR = NTOT - NIRCLD ICLD = IVAR(178,LON) ICLR = IVAR(181,LON) IF ( IVAR(6,LON) .GT. 100 ) THEN ITOT = IUNDEF ELSE ITOT = NINT(FLOAT(NIRCLD*ICLD+NIRCLR*ICLR)/FLOAT(NTOT)) END IF PRINT 210,NIRCLD,NIRCLR,NTOT, $ RFLTAB(ICLD),RFLTAB(ICLR),RFLTAB(ITOT) 210 FORMAT(10X,'USING IR CLOUD/CLEAR CATEGORIES', $ /16X,'NUMBER OF PIXELS CLOUD/CLEAR/TOTAL ',3I10, $ /16X,'RADIANCE (REFLECTANCE) CLOUD/CLEAR/TOTAL',3F10.2) NVSCLD = IVAR(12,LON) - IVAR(16,LON) NVSCLR = NTOT - NVSCLD ICLD = IVAR(176,LON) ICLR = IVAR(179,LON) IF ( IVAR(6,LON) .GT. 100 ) THEN ITOT = IUNDEF ELSE ITOT = NINT(FLOAT(NVSCLD*ICLD+NVSCLR*ICLR)/FLOAT(NTOT)) END IF PRINT 220,NVSCLD,NVSCLR,NTOT, $ RFLTAB(ICLD),RFLTAB(ICLR),RFLTAB(ITOT) 220 FORMAT(10X,'USING VIS/IR CLOUD/CLEAR CATEGORIES', $ /16X,'NUMBER OF PIXELS CLOUD/CLEAR/TOTAL ',3I10, $ /16X,'RADIANCE (REFLECTANCE) CLOUD/CLEAR/TOTAL',3F10.2) RETURN END C**********************************************************************C C**********************************************************************C C**********************************************************************C C* NAME: CLDHGT *C C* DESCRIPTION: CALCULATE CLOUD TOP HEIGHT IN METERS, BY USING *C C* CLOUD TOP PRESSURE AND OBSERVED ATMOSPHERIC *C C* TEMPERATURE AND HUMIDITY PROFILES *C C**********************************************************************C C**********************************************************************C C**********************************************************************C SUBROUTINE CLDHGT(LON) PARAMETER ( MAXVAR = 202 ) PARAMETER ( NUMBOX = 100 ) PARAMETER ( MAXLON = 144 ) PARAMETER ( MAXLAT = 72 ) COMMON /D1GRID/ NCELLS(MAXLAT),ICELLS(MAXLAT) C* D1 DATA ARRAYS COMMON /D1DATA/ LAT,NLON,IVAR(MAXVAR,MAXLON),RVAR(MAXVAR,MAXLON) C* TOPOGRAPHIC HEIGHT (READ FROM ANCILARY DATA FILE) PARAMETER ( MAXBOX = 6596 ) COMMON /HEIGHT/ ITOPOG(MAXBOX) C* CONSTANTS PARAMETER ( CONSTG = 9.806 ) PARAMETER ( CONSTR = 8.3144 ) PARAMETER ( CONSTM = 0.028966 ) C* PRESSURE LEVELS PARAMETER ( NLEVEL = 7 ) PARAMETER ( NBOUND = NLEVEL + 1 ) REAL PLIM(NBOUND)/1000.,800.,680.,560.,440.,310.,180.,30./ REAL P(NBOUND) C* REAL LNP(NBOUND) REAL Z(NBOUND) REAL T(NLEVEL) REAL PW(NLEVEL) C* FIND EQUAL AREA BOX NUMBER IBOX = NCELLS(LAT) + LON PC = RVAR(78,LON) IF ( PC .LT. 0.0 ) THEN HGT = -1000.0 ELSE C* INIT TO STANDARD BOUNDARIES DO 2 I=1,NBOUND P(I) = PLIM(I) 2 CONTINUE C* FIND LOWER AND UPPER BOUNDARIES FOR SURFACE AND TROPOPAUSE PSURF = RVAR(184,LON) PTROP = RVAR(193,LON) IUPBND = NBOUND ILWBND = 1 DO 5 I=NBOUND,1,-1 IF ( PTROP .GT. P(I) ) IUPBND = I - 1 IF ( PSURF .GT. P(I) ) ILWBND = I 5 CONTINUE C* GET D1 TEMPERATURE AND PRECIPITABLE WATER PROFILES TSURF = RVAR(185,LON) TTROP = RVAR(194,LON) DO 10 I=1,NLEVEL T(I) = RVAR(185+I,LON) 10 CONTINUE DO 20 I=1,5 PW(I) = RVAR(196+I,LON) 20 CONTINUE PW(6) = 0.0 PW(7) = 0.0 C* SET LN(P) DO 30 I=ILWBND,IUPBND LNP(I) = ALOG(P(I)) 30 CONTINUE IF ( ILWBND.GT.1 .AND. PSURF-P(ILWBND).GT.0.0 ) THEN ILWBND = ILWBND - 1 LNP(ILWBND) = ALOG(PSURF) P(ILWBND) = PSURF END IF IF ( IUPBND.LT.NBOUND .AND. P(IUPBND)-PTROP.GT.0.0 ) THEN IUPBND = IUPBND + 1 LNP(IUPBND) = ALOG(PTROP) P(IUPBND) = PTROP END IF C* Z(1) IS TOPOGRAPHIC HEIGHT IN METERS FROM ANCILLARY DATA Z(ILWBND) = ITOPOG(IBOX) C* LOOP THROUGH BOUNDARIES 2 THROUGH TOP TO CALCULATE Z FOR EACH DO 100 I=ILWBND+1,IUPBND Q = CONSTG / ( P(I-1) - P(I) ) * PW(I-1) TSTAR = (1.0 + 0.6077 * Q ) * T(I-1) Z(I) = Z(I-1)+(CONSTR*TSTAR)/(CONSTM*CONSTG)*ALOG(P(I-1)/P(I)) 100 CONTINUE C* LOOK UP CLOUD TOP PRESSURE ON LNP(), FIND CORRESPONDING Z() ALNPC = ALOG(PC) IBOT = IUPBND - 1 ITOP = IUPBND DO 200 I=ILWBND+1,IUPBND IF ( ALNPC .GT. LNP(I) ) THEN IBOT = I-1 ITOP = I GOTO 210 END IF 200 CONTINUE 210 CONTINUE RATIO = (ALNPC-LNP(ITOP)) / (LNP(IBOT)-LNP(ITOP)) HGT = Z(ITOP) + RATIO * (Z(IBOT)-Z(ITOP)) END IF PRINT 340, PC,HGT 340 FORMAT(/1X,'CLDHGT: CLOUD TOP PRESSURE (MB)',F10.0, $ 10X,'CLOUD TOP HEIGHT (M)',F10.0) RETURN END C**********************************************************************C C**********************************************************************C C**********************************************************************C C* NAME: BLOCK DATA *C C* DESCRIPTION: INITIALIZE CONVERSION TABLES AND EQUAL-AREA GRID *C C**********************************************************************C C**********************************************************************C C**********************************************************************C BLOCK DATA C*--------------------------------------------------------------------*C PARAMETER ( MAXCNT = 255 ) COMMON/CNTTAB/TMPTAB(0:MAXCNT),TMPVAR(0:MAXCNT),PRETAB(0:MAXCNT), 1 RFLTAB(0:MAXCNT),TAUTAB(0:MAXCNT),PRWTAB(0:MAXCNT), 2 OZNTAB(0:MAXCNT) C*--------------------------------------------------------------------*C PARAMETER ( MAXLAT = 72 ) COMMON /D1GRID/ NCELLS(MAXLAT),ICELLS(MAXLAT) C*--------------------------------------------------------------------*C DATA (TMPTAB(I),I=0,127) / & -100.000,165.000,169.000,172.000,175.000,177.800,180.500, & 183.000,185.500,187.800,190.000,192.000,194.000,195.700, & 197.500,199.200,201.000,202.700,204.500,206.200,208.000, & 209.700,211.500,212.800,214.100,215.400,216.700,217.900, & 219.200,220.500,221.800,223.100,224.400,225.400,226.500, & 227.500,228.600,229.600,230.600,231.700,232.700,233.800, & 234.800,235.700,236.600,237.500,238.400,239.200,240.100, & 241.000,241.900,242.800,243.700,244.500,245.300,246.100, & 246.900,247.700,248.500,249.300,250.100,250.900,251.700, & 252.400,253.100,253.900,254.600,255.300,256.000,256.700, & 257.500,258.200,258.900,259.500,260.200,260.800,261.500, & 262.100,262.800,263.400,264.100,264.700,265.400,266.000, & 266.600,267.200,267.800,268.400,269.100,269.700,270.300, & 270.900,271.500,272.100,272.700,273.200,273.800,274.400, & 275.000,275.600,276.100,276.700,277.300,277.800,278.400, & 278.900,279.500,280.000,280.500,281.100,281.600,282.200, & 282.700,283.200,283.700,284.200,284.700,285.200,285.800, & 286.300,286.800,287.300,287.800,288.300,288.800,289.300, & 289.800,290.200/ DATA (TMPTAB(I),I=128,255) / & 290.700,291.200,291.700,292.200,292.700, & 293.200,293.600,294.100,294.600,295.000,295.500,296.000, & 296.500,296.900,297.400,297.800,298.300,298.700,299.200, & 299.600,300.100,300.500,301.000,301.400,301.900,302.300, & 302.800,303.200,303.600,304.000,304.500,304.900,305.300, & 305.800,306.200,306.600,307.000,307.500,307.900,308.300, & 308.700,309.100,309.600,310.000,310.400,310.800,311.200, & 311.600,312.000,312.400,312.900,313.300,313.700,314.100, & 314.500,314.900,315.300,315.700,316.100,316.400,316.800, & 317.200,317.600,318.000,318.400,318.800,319.200,319.500, & 319.900,320.300,320.700,321.100,321.400,321.800,322.200, & 322.600,323.000,323.300,323.700,324.100,324.500,324.900, & 325.200,325.600,326.000,326.400,326.700,327.100,327.400, & 327.800,328.200,328.500,328.900,329.200,329.600,329.900, & 330.300,330.600,331.000,331.300,331.700,332.000,332.400, & 332.700,333.100,333.400,333.800,334.100,334.500,334.800, & 335.200,335.500,335.900,336.200,336.600,336.900,337.300, & 337.600,338.000,338.300,338.600,339.000,339.300,339.700, & 340.000,345.000,-200.000,-1000.000/ DATA (TMPVAR(I),I=0,127) / & -100.000, 0.075, 0.300,0.600,0.900,1.200,1.500,1.800,2.100,2.400, & 2.700, 3.000, 3.300,3.600,3.900,4.200,4.500,4.800,5.100,5.400, & 5.700, 6.000, 6.300,6.600,6.900,7.200,7.500,7.800,8.100,8.400, & 8.700, 9.000, 9.300, 9.600, 9.900,10.200,10.500,10.800,11.100, & 11.400,11.700,12.000,12.300,12.600,12.900,13.200,13.500,13.800, & 14.100,14.400,14.700,15.000,15.300,15.600,15.900,16.200,16.500, & 16.800,17.100,17.400,17.700,18.000,18.300,18.600,18.900,19.200, & 19.500,19.800,20.100,20.400,20.700,21.000,21.300,21.600,21.900, & 22.200,22.500,22.800,23.100,23.400,23.700,24.000,24.300,24.600, & 24.900,25.200,25.500,25.800,26.100,26.400,26.700,27.000,27.300, & 27.600,27.900,28.200,28.500,28.800,29.100,29.400,29.700,30.000, & 30.300,30.600,30.900,31.200,31.500,31.800,32.100,32.400,32.700, & 33.000,33.300,33.600,33.900,34.200,34.500,34.800,35.100,35.400, & 35.700,36.000,36.300,36.600,36.900,37.200,37.500,37.800/ DATA (TMPVAR(I),I=128,255) / & 38.100, & 38.400,38.700,39.000,39.300,39.600,39.900,40.200,40.500,40.800, & 41.100,41.400,41.700,42.000,42.300,42.600,42.900,43.200,43.500, & 43.800,44.100,44.400,44.700,45.000,45.300,45.600,45.900,46.200, & 46.500,46.800,47.100,47.400,47.700,48.000,48.300,48.600,48.900, & 49.200,49.500,49.800,50.100,50.400,50.700,51.000,51.300,51.600, & 51.900,52.200,52.500,52.800,53.100,53.400,53.700,54.000,54.300, & 54.600,54.900,55.200,55.500,55.800,56.100,56.400,56.700,57.000, & 57.300,57.600,57.900,58.200,58.500,58.800,59.100,59.400,59.700, & 60.000,60.300,60.600,60.900,61.200,61.500,61.800,62.100,62.400, & 62.700,63.000,63.300,63.600,63.900,64.200,64.500,64.800,65.100, & 65.400,65.700,66.000,66.300,66.600,66.900,67.200,67.500,67.800, & 68.100,68.400,68.700,69.000,69.300,69.600,69.900,70.200,70.500, & 70.800,71.100,71.400,71.700,72.000,72.300,72.600,72.900,73.200, & 73.500,73.800,74.100,74.400,74.700,75.400,78.000,85.000, & -200.000,-1000.000/ DATA (PRETAB(I),I=0,127) / & -100.00, 1.00, 5.00, 10.00,15.00,20.00,25.00,30.00,35.00,40.00, & 45.00, 50.00, 55.00,60.00,65.00,70.00,75.00,80.00,85.00,90.00, & 95.00,100.00,105.00,110.00,115.00,120.00,125.00,130.00,135.00, & 140.00,145.00,150.00,155.00,160.00,165.00,170.00,175.00,180.00, & 185.00,190.00,195.00,200.00,205.00,210.00,215.00,220.00,225.00, & 230.00,235.00,240.00,245.00,250.00,255.00,260.00,265.00,270.00, & 275.00,280.00,285.00,290.00,295.00,300.00,305.00,310.00,315.00, & 320.00,325.00,330.00,335.00,340.00,345.00,350.00,355.00,360.00, & 365.00,370.00,375.00,380.00,385.00,390.00,395.00,400.00,405.00, & 410.00,415.00,420.00,425.00,430.00,435.00,440.00,445.00,450.00, & 455.00,460.00,465.00,470.00,475.00,480.00,485.00,490.00,495.00, & 500.00,505.00,510.00,515.00,520.00,525.00,530.00,535.00,540.00, & 545.00,550.00,555.00,560.00,565.00,570.00,575.00,580.00,585.00, & 590.00,595.00,600.00,605.00,610.00,615.00,620.00,625.00,630.00/ DATA (PRETAB(I),I=128,255) / & 635.00,640.00,645.00,650.00,655.00,660.00,665.00,670.00,675.00, & 680.00,685.00,690.00,695.00,700.00,705.00,710.00,715.00,720.00, & 725.00,730.00,735.00,740.00,745.00,750.00,755.00,760.00,765.00, & 770.00,775.00,780.00,785.00,790.00,795.00,800.00,805.00,810.00, & 815.00,820.00,825.00,830.00,835.00,840.00,845.00,850.00,855.00, & 860.00,865.00,870.00,875.00,880.00,885.00,890.00,895.00,900.00, & 905.00,910.00,915.00,920.00,925.00,930.00,935.00,940.00,945.00, & 950.00,955.00,960.00,965.00,970.00,975.00,980.00,985.00,990.00, & 995.00,1000.00,-200.00,-200.00,-200.00,-200.00,-200.00,-200.00, & -200.00,-200.00,-200.00,-200.00,-200.00,-200.00,-200.00, & -200.00,-200.00,-200.00,-200.00,-200.00,-200.00,-200.00, & -200.00,-200.00,-200.00,-200.00,-200.00,-200.00,-200.00, & -200.00,-200.00,-200.00,-200.00,-200.00,-200.00,-200.00, & -200.00,-200.00,-200.00,-200.00,-200.00,-200.00,-200.00, & -200.00,-200.00,-200.00,-200.00,-200.00,-200.00,-200.00, & -200.00,-200.00,-200.00,-200.00,-200.00,-1000.00/ DATA (RFLTAB(I),I=0,127) / & -100.000,0.000,0.008,0.012,0.016,0.020,0.024,0.028,0.032,0.036, & 0.040,0.044,0.048,0.052,0.056,0.060,0.064,0.068,0.072,0.076, & 0.080,0.084,0.088,0.092,0.096,0.100,0.104,0.108,0.112,0.116, & 0.120,0.124,0.128,0.132,0.136,0.140,0.144,0.148,0.152,0.156, & 0.160,0.164,0.168,0.172,0.176,0.180,0.184,0.188,0.192,0.196, & 0.200,0.204,0.208,0.212,0.216,0.220,0.224,0.228,0.232,0.236, & 0.240,0.244,0.248,0.252,0.256,0.260,0.264,0.268,0.272,0.276, & 0.280,0.284,0.288,0.292,0.296,0.300,0.304,0.308,0.312,0.316, & 0.320,0.324,0.328,0.332,0.336,0.340,0.344,0.348,0.352,0.356, & 0.360,0.364,0.368,0.372,0.376,0.380,0.384,0.388,0.392,0.396, & 0.400,0.404,0.408,0.412,0.416,0.420,0.424,0.428,0.432,0.436, & 0.440,0.444,0.448,0.452,0.456,0.460,0.464,0.468,0.472,0.476, & 0.480,0.484,0.488,0.492,0.496,0.500,0.504,0.508/ DATA (RFLTAB(I),I=128,255) / & 0.512,0.516, & 0.520,0.524,0.528,0.532,0.536,0.540,0.544,0.548,0.552,0.556, & 0.560,0.564,0.568,0.572,0.576,0.580,0.584,0.588,0.592,0.596, & 0.600,0.604,0.608,0.612,0.616,0.620,0.624,0.628,0.632,0.636, & 0.640,0.644,0.648,0.652,0.656,0.660,0.664,0.668,0.672,0.676, & 0.680,0.684,0.688,0.692,0.696,0.700,0.704,0.708,0.712,0.716, & 0.720,0.724,0.728,0.732,0.736,0.740,0.744,0.748,0.752,0.756, & 0.760,0.764,0.768,0.772,0.776,0.780,0.784,0.788,0.792,0.796, & 0.800,0.804,0.808,0.812,0.816,0.820,0.824,0.828,0.832,0.836, & 0.840,0.844,0.848,0.852,0.856,0.860,0.864,0.868,0.872,0.876, & 0.880,0.884,0.888,0.892,0.896,0.900,0.904,0.908,0.912,0.916, & 0.920,0.924,0.928,0.932,0.936,0.940,0.944,0.948,0.952,0.956, & 0.960,0.964,0.968,0.972,0.976,0.980,0.984,0.988,0.992,1.000, & 1.016,1.040,1.072,1.108,-200.000,-1000.000/ DATA (TAUTAB(I),I=0,127) / & -100.000,0.020,0.040,0.060,0.090,0.110,0.140,0.160,0.190,0.220, & 0.240,0.270,0.300,0.330,0.370,0.400,0.430,0.460,0.500,0.530, & 0.570,0.600,0.640,0.680,0.720,0.750,0.790,0.830,0.870,0.920, & 0.960,1.000,1.040,1.090,1.130,1.180,1.220,1.270,1.320,1.370, & 1.420,1.470,1.520,1.570,1.620,1.670,1.730,1.780,1.830,1.890, & 1.950,2.000,2.060,2.120,2.180,2.240,2.300,2.360,2.430,2.490, & 2.550,2.620,2.690,2.750,2.820,2.890,2.960,3.030,3.100,3.180, & 3.250,3.320,3.400,3.480,3.550,3.630,3.710,3.790,3.880,3.960, & 4.040,4.130,4.220,4.300,4.390,4.480,4.570,4.670,4.760,4.850, & 4.950,5.050,5.150,5.250,5.350,5.450,5.560,5.660,5.770,5.880, & 5.990,6.110,6.220,6.340,6.450,6.570,6.690,6.820,6.940,7.070, & 7.190,7.330,7.460,7.590,7.730,7.870,8.010,8.150,8.300,8.440, & 8.590,8.740,8.900,9.060,9.220,9.380,9.540,9.710/ DATA (TAUTAB(I),I=128,255) / & 9.880,10.050, & 10.230,10.410,10.590,10.780,10.970,11.160,11.350,11.550,11.760, & 11.960,12.170,12.390,12.600,12.830,13.050,13.280,13.520,13.760, & 14.000,14.250,14.510,14.770,15.030,15.300,15.580,15.860,16.150, & 16.440,16.740,17.050,17.360,17.690,18.020,18.350,18.700,19.050, & 19.410,19.780,20.160,20.540,20.940,21.350,21.770,22.200,22.630, & 23.080,23.550,24.030,24.520,25.020,25.540,26.070,26.620,27.190, & 27.770,28.370,28.990,29.630,30.290,30.970,31.670,32.400,33.160, & 33.940,34.740,35.580,36.450,37.350,38.290,39.260,40.260,41.320, & 42.420,43.570,44.760,46.000,47.310,48.680,50.110,51.600,53.170, & 54.840,56.590,58.430,60.360,62.400,64.590,66.900,69.360,71.960, & 74.720,77.730,80.940,84.380,88.060,92.020,96.400,101.010, & 105.510,109.870,114.330,119.590,125.920,133.660,143.120, & 154.650, 169.560, 187.490, 207.200, 228.130, 250.440, 282.780, & 323.920, 378.650,-200.000,-200.000,-200.000,-200.000,-200.000, & -200.000,-200.000,-200.000,-200.000,-200.000,-200.000, & -1000.000/ DATA (PRWTAB(I),I=0,127) / & -100.000,0.000,0.030,0.060,0.090,0.120,0.150,0.180,0.210,0.240, & 0.270,0.300,0.330,0.360,0.390,0.420,0.450,0.480,0.510,0.540, & 0.570,0.600,0.630,0.660,0.690,0.720,0.750,0.780,0.810,0.840, & 0.870,0.900,0.930,0.960,0.990,1.020,1.050,1.080,1.110,1.140, & 1.170,1.200,1.230,1.260,1.290,1.320,1.350,1.380,1.410,1.440, & 1.470,1.500,1.530,1.560,1.590,1.620,1.650,1.680,1.710,1.740, & 1.770,1.800,1.830,1.860,1.890,1.920,1.950,1.980,2.010,2.040, & 2.070,2.100,2.130,2.160,2.190,2.220,2.250,2.280,2.310,2.340, & 2.370,2.400,2.430,2.460,2.490,2.520,2.550,2.580,2.610,2.640, & 2.670,2.700,2.730,2.760,2.790,2.820,2.850,2.880,2.910,2.940, & 2.970,3.000,3.030,3.060,3.090,3.120,3.150,3.180,3.210,3.240, & 3.270,3.300,3.330,3.360,3.390,3.420,3.450,3.480,3.510,3.540, & 3.570,3.600,3.630,3.660,3.690,3.720,3.750,3.780/ DATA (PRWTAB(I),I=128,255) / & 3.810,3.840, & 3.870,3.900,3.930,3.960,3.990,4.020,4.050,4.080,4.110,4.140, & 4.170,4.200,4.230,4.260,4.290,4.320,4.350,4.380,4.410,4.440, & 4.470,4.500,4.530,4.560,4.590,4.620,4.650,4.680,4.710,4.740, & 4.770,4.800,4.830,4.860,4.890,4.920,4.950,4.980,5.010,5.040, & 5.070,5.100,5.130,5.160,5.190,5.220,5.250,5.280,5.310,5.340, & 5.370,5.400,5.430,5.460,5.490,5.520,5.550,5.580,5.610,5.640, & 5.670,5.700,5.730,5.760,5.790,5.820,5.850,5.880,5.910,5.940, & 5.970,6.000,6.030,6.060,6.090,6.120,6.150,6.180,6.210,6.240, & 6.270,6.300,6.330,6.360,6.390,6.420,6.450,6.480,6.510,6.540, & 6.570,6.600,6.630,6.660,6.690,6.720,6.750,6.780,6.810,6.840, & 6.870,6.900,6.930,6.960,6.990,7.020,7.050,7.080,7.110,7.140, & 7.170,7.200,7.230,7.260,7.290,7.320,7.350,7.380,7.410,7.440, & 7.470,7.500,7.650,8.000,-200.000,-1000.000/ DATA (OZNTAB(I),I=0,127) / & -100.0,0.0,2.0,4.0,6.0,8.0,10.0,12.0,14.0,16.0,18.0,20.0,22.0, & 24.0,26.0,28.0,30.0,32.0,34.0,36.0,38.0,40.0,42.0,44.0,46.0, & 48.0,50.0,52.0,54.0,56.0,58.0,60.0,62.0,64.0,66.0,68.0,70.0, & 72.0,74.0,76.0,78.0,80.0,82.0,84.0,86.0,88.0,90.0,92.0,94.0, & 96.0,98.0,100.0,102.0,104.0,106.0,108.0,110.0,112.0,114.0, & 116.0,118.0,120.0,122.0,124.0,126.0,128.0,130.0,132.0,134.0, & 136.0,138.0,140.0,142.0,144.0,146.0,148.0,150.0,152.0,154.0, & 156.0,158.0,160.0,162.0,164.0,166.0,168.0,170.0,172.0,174.0, & 176.0,178.0,180.0,182.0,184.0,186.0,188.0,190.0,192.0,194.0, & 196.0,198.0,200.0,202.0,204.0,206.0,208.0,210.0,212.0,214.0, & 216.0,218.0,220.0,222.0,224.0,226.0,228.0,230.0,232.0,234.0, & 236.0,238.0,240.0,242.0,244.0,246.0,248.0,250.0,252.0/ DATA (OZNTAB(I),I=128,255) / & 254.0, & 256.0,258.0,260.0,262.0,264.0,266.0,268.0,270.0,272.0,274.0, & 276.0,278.0,280.0,282.0,284.0,286.0,288.0,290.0,292.0,294.0, & 296.0,298.0,300.0,302.0,304.0,306.0,308.0,310.0,312.0,314.0, & 316.0,318.0,320.0,322.0,324.0,326.0,328.0,330.0,332.0,334.0, & 336.0,338.0,340.0,342.0,344.0,346.0,348.0,350.0,352.0,354.0, & 356.0,358.0,360.0,362.0,364.0,366.0,368.0,370.0,372.0,374.0, & 376.0,378.0,380.0,382.0,384.0,386.0,388.0,390.0,392.0,394.0, & 396.0,398.0,400.0,402.0,404.0,406.0,408.0,410.0,412.0,414.0, & 416.0,418.0,420.0,422.0,424.0,426.0,428.0,430.0,432.0,434.0, & 436.0,438.0,440.0,442.0,444.0,446.0,448.0,450.0,452.0,454.0, & 456.0,458.0,460.0,462.0,464.0,466.0,468.0,470.0,472.0,474.0, & 476.0,478.0,480.0,482.0,484.0,486.0,488.0,490.0,492.0,494.0, & 496.0,498.0,500.0,505.0,515.0,-200.0,-1000.0/ DATA NCELLS / & 0, 3, 12, 28, 50, 78, 112, 152, 198, 250, & 308, 372, 441, 516, 596, 681, 771, 866, 966,1070, & 1178,1290,1406,1526,1649,1775,1904,2036,2170,2306, & 2444,2584,2725,2867,3010,3154,3298,3442,3586,3729, & 3871,4012,4152,4290,4426,4560,4692,4821,4947,5070, & 5190,5306,5418,5526,5630,5730,5825,5915,6000,6080, & 6155,6224,6288,6346,6398,6444,6484,6518,6546,6568, & 6584,6593 / DATA ICELLS / & 3, 9, 16, 22, 28, 34, 40, 46, 52, 58, & 64, 69, 75, 80, 85, 90, 95, 100, 104, 108, & 112, 116, 120, 123, 126, 129, 132, 134, 136, 138, & 140, 141, 142, 143, 144, 144, 144, 144, 143, 142, & 141, 140, 138, 136, 134, 132, 129, 126, 123, 120, & 116, 112, 108, 104, 100, 95, 90, 85, 80, 75, & 69, 64, 58, 52, 46, 40, 34, 28, 22, 16, & 9, 3 / END