SUBROUTINE KINDEX(KFILDO,KFIL10,IDPARS,JD,NDATE, 1 NGRIDC,ND11,NSLAB,IPACK,IWORK,DATA,ND5, 2 LSTORE,ND9,LITEMS,CORE,ND10,NBLOCK,NFETCH, 3 IS0,IS1,IS2,IS4,ND7, 4 FDTK5,FDTK8,FDTK7,FDPT8,FDPT7,FD4,ND2X3, 5 ISTAV,L3264B,MISTOT,IER) C C C SEPTEMBER 1998 HUGHES TDL MOS-2000 C OCTOBER 2002 WEISS CHANGED ND5 TO ND2X3 C APRIL 2003 GLAHN MODIFIED LINES IN CALL; SET C DIMENSIONS OF IPACK( ), IWORK( ) C AND DATA( ) = ND5; SPELL CHECK; C CHANGED CALCULATION DO 600 LOOP C FROM ND2X3 TO MTX5*NTY5; REMOVED C DEFINING IDPARS(7) C MAY 2003 GLAHN REARRANGED TYPE STATEMENTS C JULY 2019 SHAFER MODIFIED TO ACCOUNT FOR MISSING C VALUES ON THE MODEL GRID. C C PURPOSE C TO COMPUTE THE K-INDEX WHICH IS BY DEFINITION ON AN C ISOBARIC SURFACE. FIRST WORD OF ID IS 007200000 C K-INDEX = (850T - 500T) + 850TD - (700T - 700TD) C THE K-INDEX IS USEFUL FOR PREDICTING NON-SEVERE C WARM SEASON CONVECTIVE ACTIVITY C C THE FOLLOWING IDPARS(1) AND IDPARS(2) IS ACCOMMODATED: C C 007 200 - K-INDEX C C DATA SET USE C KFILDO = DEFAULT UNIT NUMBER FOR OUTPUT(PRINT) FILE. C (OUTPUT) C KFIL10 = UNIT NUMBER OF TDL MOS-2000 FILE SYSTEM C ACCESS.(INPUT-OUTPUT) C C VARIABLES C CORE(J) = THE ARRAY TO STORE OR RETRIEVE THE DATA C IDENTIFIED IN LSTORE(,) (J=1,ND10). C WHEN CORE() IS FULL DATA ARE STORED ON DISK. C (INPUT) C DATA(J) = K-INDEX CALCULATED FROM 850, 700 AND 500 MB C TEMPERATURE AND 850 AND 700 MB DEWPOINT C TEMPERATURE (J=1,ND5). (OUTPUT) C FDPT8(K) = DATA ARRAY TO HOLD THE DEW POINT TEMPERATURE C AT 850 MB IN KELVIN (K=1,ND2X3). (INTERNAL) C FDPT7(K) = DATA ARRAY TO HOLD THE DEW POINT TEMPERATURE C AT 700 MB IN KELVIN (K=1,ND2X3). (INTERNAL) C FDTK8(K) = WORK ARRAY TO HOLD THE AIR TEMPERATURE AT C 850 MB IN KELVIN (K=1,ND2X3). (INTERNAL) C FDTK7(K) = WORK ARRAY TO HOLD THE AIR TEMPERATURE AT C 700 MB IN KELVIN (K=1,ND2X3). (INTERNAL) C FDTK5(K) = WORK ARRAY TO HOLD THE AIR TEMPERATURE AT C 500 MB IN KELVIN (K=1,ND2X3). (INTERNAL) C FD4(K) = WORK ARRAY USED BY SUBROUTINE DEWPT C (INTERNAL) C I = LOOP CONTROL VARIABLE C ICCCFFF( ) = CONTAINS IDPARS(1) AND IDPARS(2) ID FOR THE C METEOROLOGICAL PARAMETERS BEING USED. C COLUMN 1 CONTAINS ID FOR ISOBARIC SURFACE C IDPARS(J) = THE PARSED, INDIVIDUAL COMPONENTS OF THE C PREDICTOR ID CORRESPONDING TO ID() (J=1,15). C (INPUT) C J=1--CCC (CLASS OF VARIABLE), C J=2--FFF (SUBCLASS OF VARIABLE), C J=3--B (BINARY INDICATOR), C J=4--DD (DATA SOURCE, MODEL NUMBER), C J=5--V (VERTICAL APPLICATION), C J=6--LBLBLBLB (BOTTOM OF LAYER, 0 IF ONLY C 1 LAYER) C J=7--LTLTLTLT (TOP OF LAYER) C J=8--T (TRANSFORMATION) C J=9--RR (RUN TIME OFFSET, ALWAYS + AND C BACK IN TIME) C J=10-OT (TIME APPLICATION) C J=11-OH (TIME PERIOD IN HOURS) C J=12-TAU (PROJECTION IN HOURS) C J=13-I (INTERPOLATION TYPE) C J=14-S (SMOOTHING INDICATOR) C J=15-G (GRID INDICATOR) C IER = STATUS RETURN C 0 = GOOD RETURN C 100 = THE TWO GRIDS NEEDED ARE NOT THE SAME SIZE C 101 = GRID SIZE IS TOO BIG FOR ???(), WHOSE C DIMENSION IS ND5. C 103 = IDPARS(1) AND IDPARS(2) DO NOT INDICATE C K-INDEX. C SEE GFETCH FOR OTHER VALUES. C WHEN IER NE 0, DATA ARE RETURNED AS MISSING. C (INTERNAL-OUTPUT) C IJ = LOOP CONTROL VARIABLE C IPACK(J) = WORK ARRAY (J=1,ND5). (INTERNAL) C IS0(J) = MOS-2000 GRIB SECTION 0 ID'S (J=1,3). C (INTERNAL) C IS1(J) = MOS-2000 GRIB SECTION 1 ID'S (J=1,22+). C (INTERNAL) C IS2(J) = MOS-2000 GRIB SECTION 2 ID'S (J=1,12). C IS2(3) AND IS2(4) ARE USED BY THE CALLING C PROGRAM AS THE GRID DIMENSIONS. C (INTERNAL-OUTPUT) C IS4(J) = MOS-2000 GRIB SECTION 4 ID'S (J=1,4). C (INTERNAL) C ISO = 1 FOR ISOBARIC, 2 FOR ISOHYETAL SURFACE, C 3 FOR SIGMA SURFACE(INTERNAL) C ISTAV = 0 SINCE THE DATA RETURNED ARE GRID DATA. C (OUTPUT) C IWORK(J) = WORK ARRAY (J=1,ND5). (INTERNAL) C J = LOOP CONTROL VARIABLE C JD(J) = THE BASIC INTEGER PREDICTOR ID (J=1,4). C THIS IS THE SAME AS ID(J), EXCEPT THAT C THE PORTIONS PERTAINING TO PROCESSING C ARE OMITTED: C B = IDPARS(3), C T = IDPARS(8), C I = IDPARS(13), C S = IDPARS(14), C G = IDPARS(15), AND C THRESH. C ID() IS USED TO HELP IDENTIFY THE BASIC MODEL C FIELDS AS READ FROM THE ARCHIVE. (INPUT) C KFILDO = DEFAULT UNIT NUMBER FOR OUTPUT (PRINT) FILE. C (INPUT) C KFIL10 = UNIT NUMBER OF TDL MOS-2000 FILE SYSTEM ACCESS. C (INPUT) C L3264B = INTEGER WORD LENGTH IN BITS OF MACHINE BEING C USED (EITHER 32 OR 64). (INPUT) C LITEMS = THE NUMBER OF ITEMS (COLUMNS) IN LSTORE(,) C THAT HAVE BEEN USED IN THIS RUN. (INPUT) C LSTORE(L,J) = THE ARRAY HOLDING INFORMATION ABOUT THE C DATA STORED (L=1,12) (J=1,LITEMS). C (INPUT-OUTPUT) C L=1,4--THE 4 ID'S FOR THE DATA. C L=5 --LOCATION OF STORED DATA. WHEN IN CORE, C THIS IS THE LOCATION IN CORE() WHERE C THE DATA START. WHEN ON DISK, C THIS IS MINUS THE RECORD NUMBER WHERE C THE DATA START. C L=6 --THE NUMBER OF 4-BYTE WORDS STORED. C L=7 --2 FOR DATA PACKED IN TDL GRIB, 1 FOR NOT. C L=8 --THE DATE/TIME OF THE DATA IN FORMAT C YYYYMMDDHH. C L=9 --NUMBER OF TIMES DATA HAVE BEEN RETRIEVED. C L=10 --NUMBER OF THE SLAB IN DIR(, ,L) AND C IN NGRIDC(,L) DEFINING THE C CHARACTERISTICS OF THIS GRID. C L=11 --THE NUMBER OF THE PREDICTOR IN THE SORTED C LIST IN ID(,N) (N=1,NPRED) FOR WHICH C THIS VARIABLE IS NEEDED, WHEN IT IS C NEEDED ONLY ONCE FROM LSTORE(,). C WHEN IT IS NEEDED MORE THAN ONCE, THE C VALUE IS SET = 7777. C L=12 --USED INITIALLY IN ESTABLISHING C MSTORE(,). LATER USED AS A WAY OF C DETERMINING WHETHER TO KEEP THIS C VARIABLE. C MDPARS() = PARSED ID USED IN SUBROUTINE PRSID1 FOR C SUBROUTINE DEWPOINT C MISSP = PRIMARY MISSING VALUE INDICATOR. RETURNED AS C 0 WHEN DATA ARE NOT PACKED. (INTERNAL) C MISSS = SECONDARY MISSING VALUE INDICATOR. RETURNED AS C 0 WHEN DATA ARE NOT PACKED. (INTERNAL) C MISTOT = TOTAL NUMBER OF TIMES A MISSING INDICATOR C HAS BEEN ENCOUNTERED IN UNPACKING GRIDS. C (INPUT-OUTPUT) C NBLOCK = THE BLOCK SIZE IN WORDS OF THE MOS-2000 RANDOM C DISK FILE. (INPUT) C ND2X3 = DIMENSION OF SEVERAL VARIABLES. THE SIZE OF C THE GRID IS NOT KNOWN BEFORE FDTK AND FDDP C ARE FETCHED. ALL WORK ARRAYS ARE DIMENSIONED C ND2X3 (INPUT) C ND5 = DIMENSION OF IPACK( ), IWORK( ), AND C DATA( ). (INPUT) C ND7 = DIMENSION OF IS0(),IS1(),IS2(), AND IS4(). C NOT ALL LOCATIONS ARE USED. (INPUT) C ND9 = THE SECOND DIMENSION OF LSTORE(,). (INPUT) C ND10 = DIMENSION OF CORE(). (INPUT) C ND11 = MAXIMUM NUMBER OF GRID COMBINATIONS THAT CAN C BE DEALT WITH ON THIS RUN. LAST DIMENSION C OF NGRIDC(,). (INPUT) C NDATE = THE DATE/TIME FOR WHICH PREDICTOR IS NEEDED. C (INPUT) C NFETCH = INCREMENTED EACH TIME GFETCH IS ENTERED. C IT IS A RUNNING COUNT FROM THE BEGINNING OF C THE PROGRAM. THIS COUNT IS MAINTAINED IN C CASE THE USER NEEDS IT(DIAGNOSTICS, ETC.). C (OUTPUT) C NGRIDC(L,M) = HOLDS THE GRID CHARACTERISTICS (L=1,6) FOR C EACH GRID COMBINATION (M=1,NGRID). C L=1--MAP PROJECTION NUMBER (3=LAMBERT, 5= C POLAR STEREOGRAPHIC). C L=2--GRID LENGTH IN METERS. C L=3--LATITUDE AT WHICH THE GRID LENGTH IS C CORRECT *1000. C L=4--GRID ORIENTATION IN DEGREES * 1000. C L=5--LATITUDE OF LL CORNER IN DEGREES *1000. C L=6--LONGITUDE OF LL CORNER IN DEGREES C *1000. C NPACK = 2 FOR TDL GRIB PACKED DATA; 1 FOR NOT PACKED C THIS IS RETURNED FROM GFETCH. (INTERNAL) C NSLAB = THE NUMBER OF THE SLAB IN DIR(, ,) AND C IN NGRIDC(,) DEFINING THE CHARACTERISTICS C OF THIS GRID. (OUTPUT) C NSLABD7 = THE NUMBER USED TO COMPARE TO NSLAB THAT C IS RETURNED FROM SUBROUTINE DEWPOINT AFTER C FETCHING THE 700MB DEWPOINT AND IS USED C AS A CHECK C NSLABT5 = THE NUMBER USED TO COMPARE TO NSLAB THAT C IS RETURNED FROM SUBROUTINE GFETCH AFTER C FETCHING THE 500MB TEMP AND IS USED AS A CHECK C NSLABT7 = THE NUMBER USED TO COMPARE TO NSLAB THAT C IS RETURNED FROM SUBROUTINE GFETCH AFTER C FETCHING THE 700MB TEMP AND IS USED AS A CHECK C NSLABT8 = THE NUMBER USED TO COMPARE TO NSLAB THAT C IS RETURNED FROM SUBROUTINE GFETCH AFTER C FETCHING THE 700MB TEMP AND IS USED AS A CHECK C NTIMES = THE NUMBER OF TIMES, INCLUDING THIS ONE, C THAT THE RECORD HAS BEEN FETCHED. THIS IS C STORED IN LSTORE(9,). (INTERNAL) C NWORDS = NUMBER OF WORDS RETURNED IN DATA(). THIS C IS RETURNED FROM GFETCH (INTERNAL) C 1 2 3 4 5 6 7 X C IMPLICIT NONE C REAL,PARAMETER :: ABSZRO=-273.15 C INTEGER JD(4),IDPARS(15) INTEGER IS0(ND7),IS1(ND7),IS2(ND7),IS4(ND7) INTEGER IPACK(ND5),IWORK(ND5) INTEGER LSTORE(12,ND9) INTEGER NGRIDC(6,ND11) INTEGER ICCCFFF(2),MD7(4),MD8(4),MT5(4),MT8(4),MT7(4),MDPARS(15) INTEGER IER,IJ,ISO,ISTAV,J,KFILDO,KFIL10,L3264B,LITEMS, 1 MISSP,MISSS,MISTOT,MDX8,MDY8,MDX7,MDY7,MTX5,MTY5, 2 MTX7,MTY7,MTX8,MTY8,NBLOCK,ND2X3,ND5,ND7,ND9,ND10,ND11, 3 NDATE,NFETCH,NPACK,NSLAB,NSLABD7,NSLABT5,NSLABT7,NSLABT8, 4 NTIMES,NWORDS C REAL DATA(ND5) REAL FDTK5(ND2X3),FDTK7(ND2X3),FDTK8(ND2X3),FDPT7(ND2X3), 1 FDPT8(ND2X3),FD4(ND2X3) REAL CORE(ND10) C IER=0 ISTAV=0 DATA=9999. C C THE K-INDEX IS CALCULATED ONLY ON A CONSTANT PRESSURE C LEVEL, HENCE ISO=1. SET THE ISO INDEX TO '1' SO THAT THE C METEOROLOGICAL VARIABLES WILL BE TAKEN ON ISOBARIC SURFACES. C ISO=1 C PREPARE PARSED ID TO REQUEST TEMPERATURE ICCCFFF(1)=002000 C PREPARE PARSED ID TO REQUEST DEW POINT ICCCFFF(2)=003100 C C MAKE SURE THE REQUESTED PREDICTOR ID IS VALID FOR KINDEX C IF(IDPARS(1).NE.007.OR.IDPARS(2).NE.200)THEN WRITE(KFILDO,101)(JD(J),J=1,4) 101 FORMAT(/' ****IDPARS(1) AND IDPARS(2) DO NOT INDICATE K-INDEX', 1 ' PREDICTOR. ',I9.9,2I10.9,I4.3,' NOT COMPUTED IN KINDEX. ') IER=103 GOTO 800 END IF C C CREATE ID FOR 850 MB DEW POINT TEMPERATURE C MD8(1)=ICCCFFF(2)*1000+IDPARS(4) MD8(2)=850 MD8(3)=IDPARS(9)*1000000+IDPARS(12) MD8(4)=0 C C CALL DEWPT TO RETURN THE 850 DEWPOINT TEMPERATURE C CALL PRSID1(KFILDO,MD8,MDPARS) CALL DEWPT(KFILDO,KFIL10,MDPARS,MD8,NDATE,NGRIDC,ND11,NSLAB, 1 IPACK,IWORK,FDPT8,ND2X3,LSTORE,ND9,LITEMS,CORE,ND10, 2 NBLOCK,NFETCH,IS0,IS1,IS2,IS4,ND7,FDTK8,FDTK7, 3 FDTK5,FD4,ND2X3,ISTAV, 4 L3264B,MISTOT,IER) C IF(IER.NE.0)GOTO 800 C MDX8=IS2(3) MDY8=IS2(4) C C CREATE ID FOR 700 MB DEW POINT TEMPERATURE C MD7(1)=ICCCFFF(2)*1000+IDPARS(4) MD7(2)=700 MD7(3)=IDPARS(9)*1000000+IDPARS(12) MD7(4)=0 C C CALL DEWPT TO RETURN THE 700 DEWPOINT TEMPERATURE C CALL PRSID1(KFILDO,MD7,MDPARS) CALL DEWPT(KFILDO,KFIL10,MDPARS,MD7,NDATE,NGRIDC,ND11,NSLABD7, 1 IPACK,IWORK,FDPT7,ND2X3,LSTORE,ND9,LITEMS,CORE,ND10, 2 NBLOCK,NFETCH,IS0,IS1,IS2,IS4,ND7,FDTK8,FDTK7, 3 FDTK5,FD4,ND2X3,ISTAV, 4 L3264B,MISTOT,IER) C IF(IER.NE.0)GOTO 800 C MDX7=IS2(3) MDY7=IS2(4) C IF(NSLABD7.NE.NSLAB.OR.MDX7.NE.MDX8.OR.MDY7.NE.MDY8)THEN WRITE(KFILDO,200)NSLAB,NSLABD7 200 FORMAT(/,' ****THE CHARACTERISTICS OF THE 700 MB ', 1 'DEWPOINT GRID ARE DIFFERENT',I3,2X,I3) IER=100 GOTO 800 END IF C CREATE ID FOR 850 TEMPERATURE ON THE APPROPRIATE SURFACE C MT8(1)=ICCCFFF(1)*1000+IDPARS(4) MT8(2)=850 MT8(3)=IDPARS(9)*1000000+IDPARS(12) MT8(4)=0 C C FETCH 850 MB TEMPERATURE C CALL GFETCH(KFILDO,KFIL10,MT8,7777,LSTORE,ND9,LITEMS, 1 IS0,IS1,IS2,IS4,ND7,IPACK,IWORK,FDTK8,ND2X3,NWORDS, 2 NPACK,NDATE,NTIMES,CORE,ND10,NBLOCK,NFETCH,NSLABT8, 3 MISSP,MISSS,L3264B,1,IER) IF(MISSP.NE.0)MISTOT=MISTOT+1 C IF(IER.NE.0)GOTO 800 C MTX8=IS2(3) MTY8=IS2(4) C IF(NSLABT8.NE.NSLAB.OR.MTX8.NE.MDX8.OR.MTY8.NE.MDY8)THEN WRITE(KFILDO,300)NSLAB,NSLABT8 300 FORMAT(/,' ****THE GRID CHARACTERISTICS OF THE TEMPERATURE', 1 ' AT 850 MB ARE DIFFERENT.',I3,2X,I3) IER=100 GOTO 800 END IF C CREATE ID FOR 700 TEMPERATURE ON THE APPROPRIATE SURFACE C MT7(1)=ICCCFFF(1)*1000+IDPARS(4) MT7(2)=700 MT7(3)=IDPARS(9)*1000000+IDPARS(12) MT7(4)=0 C C FETCH 700 MB TEMPERATURE. C CALL GFETCH(KFILDO,KFIL10,MT7,7777,LSTORE,ND9,LITEMS,IS0, 1 IS1,IS2,IS4,ND7,IPACK,IWORK,FDTK7,ND2X3,NWORDS, 2 NPACK,NDATE,NTIMES,CORE,ND10,NBLOCK,NFETCH, 3 NSLABT7,MISSP,MISSS,L3264B,1,IER) IF(MISSP.NE.0)MISTOT=MISTOT+1 C IF(IER.NE.0)GOTO 800 C MTX7=IS2(3) MTY7=IS2(4) C IF(NSLABT7.NE.NSLAB.OR.MTX7.NE.MDX8.OR.MTY7.NE.MDY8)THEN WRITE(KFILDO,400)NSLAB,NSLABT7 400 FORMAT(/,' ****THE GRID CHARACTERISTICS OF THE TEMPERATURE', 1 ' AT 700 MB ARE DIFFERENT.',I3,2X,I3) IER=100 GOTO 800 END IF C C CREATE ID FOR 500 MB TEMPERATURE C MT5(1)=ICCCFFF(1)*1000+IDPARS(4) MT5(2)=500 MT5(3)=IDPARS(9)*1000000+IDPARS(12) MT5(4)=0 C C NOW FETCH 500 MB TEMPERATURE C CALL GFETCH(KFILDO,KFIL10,MT5,7777,LSTORE,ND9,LITEMS,IS0, 1 IS1,IS2,IS4,ND7,IPACK,IWORK,FDTK5,ND2X3,NWORDS, 2 NPACK,NDATE,NTIMES,CORE,ND10,NBLOCK,NFETCH, 3 NSLABT5,MISSP,MISSS,L3264B,1,IER) IF(MISSP.NE.0)MISTOT=MISTOT+1 C IF(IER.NE.0)GOTO 800 C MTX5=IS2(3) MTY5=IS2(4) C C CHECK IF NSLAB EQUALS NSLABT5 C IF(NSLABT5.NE.NSLAB.OR.MTX5.NE.MDX8.OR.MTY5.NE.MDY8)THEN WRITE(KFILDO,500)NSLAB,NSLABT5 500 FORMAT(/,' ****THE GRID CHARACTERISTICS OF THE TEMPERATURE', 1 ' AT 500 MB ARE DIFFERENT.',I3,2X,I3) IER=100 GOTO 800 END IF C C COMPUTATION OF K-INDEX C DO 600 IJ=1,MTX5*MTY5 IF(FDTK8(IJ).EQ.9999..OR.FDTK5(IJ).EQ.9999..OR. 1 FDPT8(IJ).EQ.9999..OR.FDTK7(IJ).EQ.9999..OR. 2 FDPT7(IJ).EQ.9999.) CYCLE DATA(IJ)=((FDTK8(IJ)-FDTK5(IJ))+FDPT8(IJ)- 1 (FDTK7(IJ)-FDPT7(IJ)))+ABSZRO 600 CONTINUE C GOTO 900 C C SET OUTPUT FIELD TO MISSING WHEN AN ERROR HAS OCCURRED. C 800 DO 801 J=1,ND2X3 DATA(J)=9999. 801 CONTINUE C 900 RETURN END