SUBROUTINE CONCPR(KFILDO,KFIL10,IP16,ID,IDPARS,
1 P,NX,NY,
2 LSTORE,ND9,LITEMS,NDATE,
3 IS0,IS1,IS2,IS4,ND7,
4 IPACK,IWORK,DATA,ND5,
5 CORE,ND10,NBLOCK,NFETCH,NSLAB,
6 IPLAIN,L3264W,L3264B,ISTOP,JER,IER)
C
C MARCH 2008 GLAHN TDL MOS-2000
C JUNE 2008 GLAHN IMPROVED DIAGNOSTICS AT 115, 130
C OCTOBER 2008 COSGROVE ADDED COMMAS TO FORMAT 130 FOR IBM
C APRIL 2010 GLAHN ADDED AVERAGE AND MAX CHANGE
C APRIL 2010 GLAHN MODIFIED PRINT FOR LOWEST LEVEL
C JUNE 2010 GLAHN INSERTED TEST ON MISSINGS
C JUNE 2010 GLAHN INSERTED WRITING TO INTERNAL STORAGE;
C ADDED IP16, PLAIN, L3264W, JER TO CALL
C JUNE 2010 GLAHN OMITTED WRITING WHEN THRESHOLD NOT
C FOUND; MODIFIED COUNT TO > 0.1%
C APRIL 2013 IM MOS/LAMP TEAM LEADERS MADE A DECISION
C TO MAKE FINAL OUTPUT UNIT=DECIMAL
C (INSTEAD OF PERCENT), SO MODIFIED COUNT
C > 0.1% TO COUNT > 0.001 ACCORDINGLY.
C JUNE 2014 GLAHN IER SET = 666 ON GSTORE ERROR
C MARCH 2016 GLAHN COMMENT BELOW 120; CHECK ON GRID SIZE
C READ AT 132
C APRIL 2017 GLAHN IMPROVED DIAGNOSTIC AT 1380
C MAY 2017 GLAHN CHANGED DIFF THRESHOLD FOR PRINTING FROM
C 2 TO 5
C MARCH 2018 GLAHN CHANGED ORDER OF PRINTING P(IX,JY),
C DATA(IX,JY) AT 1380
C MAY 2018 GLAHN CHANGED THRESOLD FOR PRINTING FROM
C 10 TO 20 (PERCENT) AT 138
C
C PURPOSE
C TO MAKE SURE THE PROBABILITY OF A CUMULATIVE CEILING
C CATEGORY IS AT LEAST AS HIGH AS THE NEXT LOWER CATEGORY.
C ITABLE IS FOR CEILING HEIGHT.
C
C NOTE THAT IF SETPNT IS USED WITH PROBABILITIES (IN THE
C RANGE 0 TO 1), THE MAX CHANGE MAY USUALLY BE .05.
C ALTHOUGH IT MAY NOT HAPPEN OFTEN, THAT ALSO AFFECTS THE
C AVERAGE CHANGE. USUALLY SETPNT WON'T BE USED WITH
C PROBABILITIES. SETPNT COULD BE CHANGED TO GIVE
C AN OFFSET OF 001, SAY, VICE .05.
C
C DATA SET USE
C KFILDO - UNIT NUMBER OF OUTPUT (PRINT) FILE. (OUTPUT)
C KFIL10 - UNIT NUMBER FOR INTERNAL RANDOM ACCESS STORAGE.
C (INPUT)
C IP16 - UNIT NUMBER FOR INDICATING WHEN A RECORD IS
C WRITTEN TO INTERNAL STORAGE. (OUTPUT)
C
C VARIABLES
C KFILDO = UNIT NUMBER OF OUTPUT (PRINT) FILE. (INPUT)
C KFIL10 = UNIT NUMBER FOR INTERNAL RANDOM ACCESS STORAGE.
C (INPUT)
C IP16 = INDICATES WHETHER (>0) OR NOT (=0)
C A STATEMENT WILL BE OUTPUT TO IP16
C WHEN A SEQUENTIAL FILE IS WRITTEN THROUGH
C PAWGTS,A RANDOM ACCESS FILE IS WRITTEN
C THROUGH PAWRAC, OR A FILE IS WRITTEN TO
C INTERNAL STORAGE BY GSTORE. (INPUT)
C ID(J) = ID OF VARIABLE BEING ANALYZED (J=1,4).
C (INPUT)
C IDPARS(J) = THE PARSED, INDIVIDUAL COMPONENTS OF THE
C ID'S CORRESPONDING TO ID( )
C (J=1,15). (INPUT)
C P(IX,JY) = GRID OF CEILING HEIGHT PROBABILITIES
C (IX=1,NX) (JY=1,NY). (INPUT/OUTPUT)
C NX = X EXTENT OF GRID IN P( , ). (INPUT)
C NY = Y EXTENT OF GRID IN P( , ). (INPUT)
C LSTORE(L,J) = THE ARRAY HOLDING INFORMATION ABOUT THE DATA
C STORED (L=1,12) (J=1,LITEMS). (INPUT/OUTPUT)
C ND9 = MAXIMUM NUMBER OF FIELDS STORED IN LSTORE( , ).
C SECOND DIMENSION OF LSTORE( , ). (INPUT)
C LITEMS = THE NUMBER OF ITEMS J IN LSTORE( ,L).
C (INPUT/OUTPUT)
C NDATE = THE DATE/TIME OF THE RUN. (INPUT)
C IS0(J) = MOS-2000 GRIB SECTION 0 ID'S (J=1,4).
C IS1(J) = MOS-2000 GRIB SECTION 1 ID'S (J=1,21+).
C IS2(J) = MOS-2000 GRIB SECTION 2 ID'S (J=1,12).
C IS4(J) = MOS-2000 GRIB SECTION 4 ID'S (J=1,4).
C ND7 = DIMENSION OF IS0( ), IS1( ), IS2( ), AND IS4( ).
C (INPUT)
C IPACK(J) = WORK ARRAY FOR GFETCH (J=1,ND5). (INTERNAL)
C IWORK(J) = WORK ARRAY FOR GFETCH (J=1,ND5). (INTERNAL)
C DATA(IX,JY) = WORK ARRAY (IX=1,NX) (JY=1,NY). DIMENSIONED
C ND5 IN CALLING PROGRAM. (INTERNAL)
C ND5 = DIMENSION OF IPACK( ), AND IWORK( ).
C (INPUT)
C CORE(J) = SPACE ALLOCATED FOR SAVING PACKED GRIDPOINT
C FIELDS (J=1,ND10). WHEN THIS SPACE IS
C EXHAUSTED, SCRATCH DISK WILL BE USED. THIS IS
C THE SPACE USED FOR THE MOS-2000 INTERNAL RANDOM
C ACCESS SYSTEM. (INPUT)
C ND10 = THE MEMORY IN WORDS ALLOCATED TO THE SAVING OF
C DATA CORE( ). WHEN THIS SPACE IS EXHAUSTED,
C SCRATCH DISK WILL BE USED. (INPUT)
C NBLOCK = BLOCK SIZE IN WORDS OF INTERNAL MOS-2000 DISK
C STORAGE. (INPUT)
C NFETCH = INCREMENTED EACH TIME DATA ARE FETCHED BY
C GFETCH. IT IS A RUNNING COUNT FROM THE
C BEGINNING OF THE PROGRAM. THIS COUNT
C IS MAINTAINED IN CASE THE USER NEEDS IT
C (DIAGNOSTICS, ETC.). (OUTPUT)
C NSLAB = SLAB OF THE GRID CHARACTERISTICS. RETURNED
C BY GFETCH. USED FOR CHECKING FOR EQUAL
C CHARACTERISTICS OF GRIDS READ. (OUTPUT)
C IPLAIN(L,J) = 32 CHARACTERS (L=1,L3264W) (J=1,4) OF PLAIN
C LANGUAGE DESCRIPTION OF VARIABLE TO BE WRITTEN.
C NOTE THAT THIS REQUIRES TWO 32-BIT WORDS TO HOLD
C THE DESCRIPTION BUT ONLY ONE 64-BIT WORD.
C EQUIVALENCED TO PLAIN( ) IN DRU155. (INPUT)
C L3264W = NUMBER OF WORDS IN 64 BITS (EITHER 1 OR 2).
C (INPUT)
C L3264B = INTEGER WORD LENGTH IN BITS OF MACHINE BEING
C USED (EITHER 32 OR 64). (INPUT)
C ISTOP(J) = ISTOP(1)--IS INCREMENTED BY 1 EACH TIME AN ERROR
C OCCURS.
C ISTOP(3)--IS INCREMENTED WHEN A DATA RECORD
C COULD NOT BE FOUND.
C (INPUT/OUTPUT)
C JER = SET TO 1 IF A WRITING ERROR OCCURS.
C IER = ERROR RETURN.
C 0 = GOOD RETURN.
C (OUTPUT)
C TABLE(M) = HOLDS THE 4TH WORD ID FOR THE NOCAT CATEGORIES
C OF CEILING HEIGHT (M=1,NOCAT). (INTERNAL)
C NOCAT = THE NUMBER OF CEILING HEIGHT CATEGORIES FORECAST
C BY LAMP MINUS 1. (INTERNAL)
C 1 2 3 4 5 6 7 X
C
C NONSYSTEM SUBROUTINES USED
C NONE
C
PARAMETER(NOCAT=7)
C
DIMENSION ID(4),IDPARS(15),LD(4)
DIMENSION IPLAIN(L3264W,4)
DIMENSION P(NX,NY),DATA(NX,NY)
DIMENSION IPACK(ND5),IWORK(ND5)
DIMENSION IS0(ND7),IS1(ND7),IS2(ND7),IS4(ND7)
DIMENSION LSTORE(12,ND9)
DIMENSION CORE(ND10)
DIMENSION ITABLE(NOCAT)
DIMENSION ISTOP(5)
C
DATA ITABLE/ 150001000,
1 450001000,
2 950001000,
3 195002000,
4 305002000,
5 655002000,
6 120503000/
C
D CALL TIMPR(KFILDO,KFILDO,'START CONCPR ')
IER=0
C
C FIND THE CATEGORY.
C
DO 110 J=1,NOCAT
C
IF(ID(4).EQ.ITABLE(J))THEN
C
IF(J.EQ.1)THEN
C THIS IS THE LOWEST CATEGORY. CAN'T CHECK A LOWER ONE.
C BECAUSE ALL LEVELS ARE USED TO COMPUTE THE LAPSE, THE
C U405A.CN IS USED FOR ALL PROBABILITY LEVELS.
C THEREFORE, CONVPR OR CONCPR (OR EQUIVALENT) HAS TO
C BE IN THE u405A.CN FOR THE LOWEST LEVEL OR NO LEVELS
C WILL BE CHECKED.
WRITE(KFILDO,105)
105 FORMAT(/' PROBABILITY OF < 200 FT CANNOT CHECKED FOR',
1 ' CONSISTENCY WITH NEXT LOWER LEVEL.')
GO TO 210
C THIS LOWEST CATEGORY IS WRITTEN SO THAT IT WILL BE
C AVAILABLE FOR THE NEXT HIGHER LEVEL.
ELSE
GO TO 120
C J HAS BEEN DEFINED.
ENDIF
C
ENDIF
C
110 CONTINUE
C
C DROP THROUGH HERE MEANS THE CATEGORY WAS NOT FOUND.
C
WRITE(KFILDO,115)(ID(L),L=1,4)
115 FORMAT(/,' ****COULDN''T FIND THRESHOLD FOR ID ',4I10,
1 ' IN TABLE IN CONCPR.',/,
2 ' GRID NOT CHECKED',
3 ' FOR CONSISTENCY WITH LOWER CATEGORY.')
ISTOP(1)=ISTOP(1)+1
C NOT COUNTED AS FATAL.
GO TO 350
C THIS CATEGORY IS UNKNOWN TO CONCPR, SO IT DOES NOT
C NEED TO BE WRITTEN.
C
120 LD(1)=ID(1)
LD(2)=ID(2)
LD(3)=ID(3)
LD(4)=ITABLE(J-1)+1
C THE +1 IS TO GET THE "CONSISTENT" GRID. THE ONE
C WRITTEN IN U405A IS BEFORE THE CHECKING IS DONE.
CALL GFETCH(KFILDO,KFIL10,LD,7777,LSTORE,ND9,LITEMS,
1 IS0,IS1,IS2,IS4,ND7,IPACK,IWORK,DATA,ND5,
2 NWORDS,NPACK,NDATE,NTIMES,CORE,ND10,
3 NBLOCK,NFETCH,NSLAB,MISSP,MISSS,L3264B,1,IER)
IF(IER.NE.0)THEN
WRITE(KFILDO,130)(LD(L),L=1,4),(ID(L),L=1,4)
130 FORMAT(/,' ****COULDN''T FETCH GRID ',4I10,
1 ' FROM INTERNAL STORAGE IN CONCPR.',/,
2 ' GRID ',4I10,' NOT CHECKED',
3 ' FOR CONSISTENCY WITH LOWER CATEGORY.')
ISTOP(1)=ISTOP(1)+1
ISTOP(3)=ISTOP(3)+1
GO TO 210
C THIS CATEGORY IS WRITTEN SO THAT IT WILL BE
C AVAILABLE FOR THE NEXT HIGHER LEVEL, EVEN IF IT COULD
C NOT BE CHECKED. THIS MIGHT HAPPEN IF ONE LEVEL WERE
C OMITTED. HOWEVER, IT MUST HAVE ENTERED THIS FOR
C LOWER LEVELS TO HAVE A LEVEL CHECKED.
ENDIF
C
IF(NWORDS.NE.NX*NY)THEN
WRITE(KFILDO,132)NWORDS,NX*NY,(LD(L),L=1,4)
132 FORMAT(/' ****NUMBER OF WORDS READ',I10,
1 ' DOES NOT EQUAL GRID SIZE',I10,
2 ' FOR VARIABLE ',4I12,' IN CONCPR.'/,
3 ' ABORT CHECKING IN CONCPR.')
ISTOP(1)=ISTOP(1)+1
ISTOP(3)=ISTOP(3)+1
GO TO 350
ENDIF
C
ICOUNT=0
CHG=0.
CHGMAX=0.
C
DO 140 JY=1,NY
DO 139 IX=1,NX
C THE GRIDS HAVE LIKELY BEEN CLIPPED AND CONTAIN 9999'S
C IN THE BORDERS. ALL CHANGES WILL BE POSITIVE.
C
IF(DATA(IX,JY).LT.9998..AND.P(IX,JY).LT.9998.)THEN
DIFF=DATA(IX,JY)-P(IX,JY)
C
C*********************************
CCC IF(IX.GE.1997.AND.IX.LE.1998.AND.
CCC 1 JY.GE.874.AND.JY.LE.876)THEN
CCC WRITE(KFILDO,137)IX,JY,ICOUNT,P(IX,JY),DATA(IX,JY),DIFF
CCC 137 FORMAT(' CONCPR--IX,JY,ICOUNT,P(IX,JY),DATA(IX,JY),DIFF',
CCC 1 3I8,3F10.5)
CCC ENDIF
C*********************************
C
IF(DIFF.GT.0.0)THEN
D WRITE(KFILDO,138)IX,JY,ICOUNT,DATA(IX,JY),P(IX,JY),DIFF
D138 FORMAT(' IN CONCPR--IX,JY,ICOUNT,DATA(IX,JY),P(IX,JY),DIFF',
D 1 3I7,3F10.4)
C
IF(DIFF.GT.20.0)THEN
WRITE(KFILDO,1380)DIFF,IX,JY,P(IX,JY),DATA(IX,JY)
1380 FORMAT(' LARGE DIFFERENCE =',F10.4,' AT IX,JY =',2I6,
1 ' BETWEEN GRID ANALYZED VALUE =',F10.7,
2 ' AND NEXT LOWER GRID VALUE =',F10.7)
CCCC WRITE(KFILDO,1380)IX,JY,ICOUNT,DATA(IX,JY),P(IX,JY),DIFF
CCCC 1380 FORMAT(' IN CONCPR--IX,JY,ICOUNT,DATA(IX,JY),P(IX,JY),',
CCCC 1 'DIFF',3I7,3F10.4)
ENDIF
C
P(IX,JY)=DATA(IX,JY)
C
IF(DIFF.GT.0.001)THEN
ICOUNT=ICOUNT+1
CHG=CHG+DIFF
CHGMAX=MAX(CHGMAX,DIFF)
ENDIF
ENDIF
C
ENDIF
C
139 CONTINUE
140 CONTINUE
C
IF(ICOUNT.GT.0)THEN
CHG=CHG/ICOUNT
WRITE(KFILDO,205)ICOUNT,CHG,CHGMAX
205 FORMAT(/,I6,' VALUES IN THE CEILING HEIGHT PROBABILITY GRID',
1 ' MODIFIED BY THE NEXT LOWER CATEGORY BY > 0.001.',
2 ' AVG CHG =',F5.3,' MAX CHG =',F7.3)
ELSE
WRITE(KFILDO,206)
206 FORMAT(/' CEILING PROBABILITY GRID CONSISTENT WITH NEXT',
1 ' LOWER ONE.')
ENDIF
C
C GSTORE WRITES THE "CONSISTENT" GRID TO INTERNAL STORAGE
C ON FILE KFIL10. TO DISTINGUISH IT FROM THE ONE WRITTEN
C IN U405A, IDPARS(15) IS SET TO 1. THIS GRID IS ALWAYS
C WRITTEN, ANTICIPATING A CHECK WITH THE ONE ABOVE.
C NOTE THAT THIS IS NOT CLIPPED AS IT MAY BE FOR OUTPUT
C TO OTHER MEDIA.
C
210 LD(1)=ID(1)
LD(2)=ID(2)
LD(3)=ID(3)
LD(4)=ID(4)+1
NSLAB=0
C THE PLUS 1 PUTS A 1 IN IDPARS(15) TO DISTINGUISH THE
C FIELD FROM THE ONE WRITTEN IN U405A. THIS ONE IS THE
C ONE "CONSISTENT" WITH THE LOWER LEVELS.
CALL GSTORE(KFILDO,KFIL10,LD,NSLAB,LSTORE,ND9,LITEMS,
1 P,NX*NY,1,0,NDATE,
2 CORE,ND10,LASTL,NBLOCK,LASTD,NSTORE,L3264B,IER)
C "NSLAB" IS STORED AS ZERO SIGNIFYING THE DATA ARE NOT
C PACKED AND CAN BE TREATED AS VECTOR DATA.
C
IF(IER.EQ.0)THEN
C
IF(IP16.NE.0)THEN
WRITE(IP16,3475)(LD(JJ),JJ=1,4),
1 ((IPLAIN(I,JJ),I=1,L3264W),JJ=1,4),NDATE
3475 FORMAT(/' WRITING DATA TO UNIT KFIL10',3I10.9,I10.3,3X,
1 8A4,' FOR DATE',I12)
ENDIF
C
ELSE
C A DIAGNOSTIC WILL HAVE OCCURRED IN GSTORE.
ISTOP(1)=ISTOP(1)+1
JER=1
WRITE(KFILDO,348)(LD(JJ),JJ=1,4)
348 FORMAT(' ERROR WRITING VARIABLE',3(1X,I9.9),1X,I10.3,
1 ' TO INTERNAL STORAGE.',/,
2 ' CHECKING OF PROBABILITY GRIDS FOR CONSISTENCY',
3 ' MAY NOT BE ABLE TO BE MADE.')
IER=666
ENDIF
C
350 RETURN
END