SUBROUTINE SCLSNO(KFILDO,KFIL10,NDATE,ID,IDPARS,JD,
1 XDATA,FD2,ND1,NVAL,NX,NY,
2 NCAT,CONST,NSCALE,PREX3,
3 NPROJ,ALATL,ALONL,ORIENT,XLAT,MESH,ITRPX,
4 LSTORE,ND9,LITEMS,
5 IS0,IS1,IS2,IS4,ND7,
6 IPACK,IWORK,DATA,ND5,
7 CORE,ND10,NBLOCK,NFETCH,MISTOT,
8 L3264B,ISTOP,IER)
C
C AUGUST 2005 GLAHN TDL MOS-2000
C AUGUST 2005 GLAHN ADDED CUTTING GRID TO SIZE
C AUGUST 2005 GLAHN ADDED TABLE( , )
C NOVEMBER 2005 JPD MODIFIED SUBROUTINE TO CONFORM
C TO FORTRAN90 STANDARDS ON THE
C IBM-SP. MODIFICATIONS INCLUDED
C REPLACEMENT OF THE FLOAT FUNCTION
C WITH THE REAL FUNCTION, AND
C CHANGING FORMAT STATEMENTS
C APRIL 2006 GLAHN ADDED ND1 TO CALL; XDATA( )
C CHANGED TO XDATA( , ); ADDED NORUNS
C MAY 2006 GLAHN REMOVED FD2( ); CHANGED ND2X3 TO
C IS2(3)*IS2(4) IN CALL TO SCLSNO
C MAY 2006 GLAHN CHANGED L TO M IN DO 215 LOOP
C MAY 2006 GLAHN ADDED FD2( ) BACK
C MAY 2006 GLAHN ADDED D/ICOUNT
C JUNE 2006 GLAHN CHANGED CALL TO SZGRID TO SZGRDM
C JULY 2006 GLAHN ADDED TO COMMENT FOR MESH
C JULY 2006 JPD CHANGED IF TEST FOR EQUALITY OF
C REAL VALUES TO 9999. WITH NINT
C FUNCTION
C FEBRUARY 2007 GLAHN ADDED A FEW COMMENTS
C MARCH 2007 GLAHN ADJUSTED COMMENTS; IER RETURNS
C MARCH 2007 GLAHN REMOVED NORUNS; REDUCED XDATA( , )
C TO XDATA( )
C JUNE 2009 GLAHN CHANGED DIAGNOSTIC FORMATS 100 AND 101
C JUNE 2009 GLAHN ADDED PREX3 TO CALL; CHANGE IN DO 115
C LOOP
C OCTOBER 2009 GLAHN CHANGED LOCATION OF IER=103; REMOVED
C INCREMENTING ISTOP(1) WHEN IER
C RETURNED NE 0
C
C PURPOSE
C TO SCALE THE VALUES IN A CATEGORY OF A VARIABLE
C ACCORDING TO THE PROBABILITY RANGE FOR THIS CASE
C OVER THE DATA BEING ANALYZED, THEN TIMES A
C CONST*10**NSCALE. THE NUMBER OF PROBABILITY CATEGORIES
C IS NCAT. THIS ROUTINE IS FOR VECTOR DATA BUT IF A GRID
C FILLS THE ARRAY, IT CAN BE TREATED AS VECTOR. THIS
C WAS WRITTEN FOR SNOWFALL, AND ITABLE( , , ) AND TABLE( , )
C ARE SPECIFIC TO THOSE CATEGORIES.
C
C PREX3 IS THE VALUE TO SET VALUES OF ZERO. WHEN ZEROS
C ARE USED IN THE ANALYSIS, THE SNOW SPREADS TOO FAR.
C A GOOD VALUE MAY BE -1. WHICH IS MINUS 1 INCH SCALED.
C HOWEVER, THIS DOES NOT WORK WELL WITH SUBROUTINE STSNOZ.
C THE DEFAULT VALUE IN U405A.CN = 0, WHICH SETS THE VALUE
C TO ZERO THE SAME AS BEFORE.
C
C NOTE THIS MAY BE SPECIFIC TO SNOW AMOUNT BECAUSE THE
C LOWEST CATEGORY HAS NO PROBABILITIES AND IS ESSENTIALLY
C FOR ZERO AMOUNT (ZERO AND TRACE).
C
C DATA SET USE
C KFILDO - UNIT NUMBER FOR OUTPUT (PRINT) FILE. (OUTPUT)
C KFIL10 - UNIT NUMBER FOR INTERNAL RANDOM ACCESS STORAGE.
C (INPUT)
C
C VARIABLES
C KFILDO = UNIT NUMBER FOR OUTPUT (PRINT) FILE. (INPUT)
C KFIL10 = UNIT NUMBER FOR INTERNAL RANDOM ACCESS STORAGE.
C (INPUT/OUTPUT)
C NDATE = DATE/TIME, YYYYMMDDHH, OF ANALYSIS RUN.
C (INPUT)
C ID(J) = 4-WORD ID OF VARIABLE TO PROVIDE FIRST GUESS FOR
C (J=1,4). (INPUT)
C IDPARS(J) = THE PARSED, INDIVIDUAL COMPONENTS OF THE
C VARIABLE ID'S CORRESPONDING TO ID( ,N)
C (J=1,15), (N=1,ND4).
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 BACK
C 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), AND
C J=15--G (GRID INDICATOR).
C (INPUT)
C JD(J) = THE BASIC INTEGER VARIABLE ID'S (J=1,4)
C (N=1,ND4).
C THIS IS THE SAME AS ID(J,N), EXCEPT THAT THE
C PORTIONS PERTAINING TO PROCESSING 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 NOT ACTUALLY USED. (INPUT)
C XDATA(K) = CATEGORICAL VALUES ON INPUT; SCALED VALUES
C ON OUTPUT (K=1,NVAL). (INPUT/OUTPUT)
C FD2(K) = WORK ARRAY (K=1,NVAL). (INTERNAL)
C ND1 = FIRST DIMENSION OF XDATA( ) AND DIMENSION
C OF FD1( ). (INPUT)
C NVAL = NUMBER OF STATIONS BEING USED; THE NUMBER
C OF VALUES IN XDATA( ). (INPUT)
C NX = THE X-EXTENT OF THE GRID NEEDED WHEN A GRID
C IS BEING ACCESSED; OTHERWISE, MUST BE ZERO.
C SCLSNO CAN BE USED FOR EITHER VECTOR DATA
C OR GRIDDED DATA. WHEN GRIDDED, THE GRID
C MUST BE PUT ONTO THE GRID BEING USED BY
C THE CALLING PROGRAM. (INPUT)
C NY = THE Y-EXTENT OF THE GRID NEEDED WHEN A GRID
C IS BEING ACCESSED. (SEE NX ABOVE.) (INPUT)
C NCAT = NUMBER OF PROBABILITY CATEGORIES. (INPUT)
C CONST = THE MULTIPLIER FOR SCALING. (INPUT)
C NSCALE = THE POWER OF TEN FOR SCALING. (INPUT)
C NPROJ = NUMBER OF MAP PROJECTION TO WHICH THIS GRID
C APPLIES.
C 3 = LAMBERT.
C 5 = POLAR STEREOGRAPHIC.
C 7 = MERCATOR.
C (INPUT)
C ALATL = LATITUDE IN DEGREES OF THE LOWER LEFT CORNER
C POINT (1,1) OF THE ANALYSIS GRID. (INPUT)
C ALONL = LONGITUDE (WEST) IN DEGREES OF THE LOWER LEFT
C CORNER POINT OF THE ANALYSIS GRID. (INPUT)
C ORIENT = ORIENTATION W LONGITUDE, PARALLEL TO GRID
C COLUMNS, IN DEGREES. (INPUT)
C XLAT = N LATITUDE AT WHICH THE MESH LENGTH APPLIES.
C (INPUT)
C MESH = NOMINAL MESH LENGTH OF THE GRID NEEDED. NOT
C ACTUALLY USED FOR VECTOR DATA. (INPUT)
C ITRPX = THE TYPE OF INTERPOLATION BEING USED.
C (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 NTIMES = THE NUMBER OF TIMES GFETCH HAS BEEN ACCESSED.
C (INPUT/OUTPUT)
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(J) = WORK ARRAY FOR GFETCH (J=1,ND5) AND COMPUTATIONS.
C (INTERNAL)
C ND5 = DIMENSION OF IPACK( ), WORK( ), AND DATA( ).
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 MISTOT = RUNNING TOTAL OF RETRIEVED GRIDS WITH ONE OR
C MORE MISSING VALUES. (INPUT/OUTPUT)
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 WHENEVER AN ERROR
C OCCURS AND THE PROGRAM PROCEEDS. ISTOP(3) IS
C INCREMENTED BY 1 WHEN A DATA RECORD COULD
C NOT BE FOUND. WHEN AN ERROR OCCURS AND IER IS
C RETURNED NE 0, THE INCREMENTING OF ISTOP(1)
C IS DONE IN THE CALLILNG PROGRAM (U405A FOR
C VECTOR AND FSTGS5 FOR GRID). (INPUT/OUTPUT)
C IER = ERROR CODE.
C 0 = GOOD RETURN.
C 103 = COULD NOT IDENTIFY ID IN INTERNAL TABLE.
C 777 = NO FIRST GUESS AVAILABLE. FATAL ERROR.
C OTHER VALUES FROM CALLED ROUTNES. EVERY
C ERROR IS FATAL FOR THIS ELEMENT.
C (OUTPUT)
C NSLAB = SLAB OF THE GRID CHARACTERISTICS. RETURNED
C BY GFETCH. USED FOR CHECKING FOR EQUAL
C CHARACTERISTICS OF GRIDS READ. (INTERNAL)
C ITABLE(I,J,L) = HOLDS THE 4-WORD IDS OF THE NCAT PROBABILITIES
C (I=1,4) (J=1,NCAT) (L=1,2). THE THIRD
C DIMENSION IS TO ACCOMMODATE BOTH THE DATA TO
C ANALYZE (L=1) AND THE FIRST GUESS (L=2).
C THE IDCAT ENTRY IS THE 4-WORD ID OF THE
C VARIABLE BEING PROCESSED SANS THE DD AND TAU
C (E.G., THE CATEGORICAL VARIABLE). THE FIRST
C ENTRY IN THE TABLE IS A DUMMY BECAUSE THE FIRST
C CATEGORY REPRESENTING 0 AMOUNT DOES NOT HAVE
C A PROBABILITY. (INTERNAL)
C TABLE(I,J) = HOLDS THE LOWER AND UPPER CATEGORY VALUES OF
C THE VARIABLES WHOSE IDS ARE IN ITABLE( , , )
C (I=1,2), (J=1,NCAT-1). (SEE ITABLE( , , )) FOR
C MORE EXPLANATION. (INTERNAL)
C 1 2 3 4 5 6 7 X
C
C NONSYSTEM SUBROUTINES USED
C SZGRDM, GFETCH, CKGRID, LMLLIJ, PSLLIJ, MCLLIJ, NOMINL,
C CUTIT
C
PARAMETER (IDCAT=7)
C
DIMENSION ID(4),IDPARS(15),JD(4)
DIMENSION XDATA(ND1),FD2(ND1)
DIMENSION IPACK(ND5),IWORK(ND5),DATA(ND5)
DIMENSION IS0(ND7),IS1(ND7),IS2(ND7),IS4(ND7)
DIMENSION LSTORE(12,ND9)
DIMENSION CORE(ND10)
DIMENSION ISTOP(3),ITABLE(4,IDCAT,2),LD(4),TABLE(2,IDCAT-1)
C
DATA ITABLE/ 0,0,0, 0,
1 208460100,0,0,500051000,
2 208460100,0,0,195001000,
3 208460100,0,0,395001000,
4 208460100,0,0,595001000,
5 208460100,0,0,795001000,
6 208461000,0,0, 0,
7 0,0,0, 0,
8 218460100,0,0,500051000,
9 218460100,0,0,195001000,
A 218460100,0,0,395001000,
B 218460100,0,0,595001000,
C 218460100,0,0,795001000,
D 218461000,0,0, 0/
DATA TABLE/ 0.,0.,
1 .1,1.95,
2 2.,3.95,
3 4.,5.95,
4 6.,7.95,
5 8.,12./
CCC 1 .1,2., ORIGINAL (DEFINITIONS OF CATEGORIES)
CCC 2 2.,4.,
CCC 3 4.,6.,
CCC 4 6.,8.,
CCC 5 8.,12./
C
IER=0
D WRITE(KFILDO,100)(ID(J),J=1,4),NX,NY
D100 FORMAT(/' AT 100 IN SCLSNO--(ID(J),J=1,4),NX,NY',4I10,2I6)
C
C DETERMINE WHETHER VARIABLE IS IN THE LIST.
C THE DD IS NOT IN THE TABLE IN CASE THE MODEL CHANGES.
C THE TAU IS NOT IN THE TABLE TO MAKE IT GENERIC, BUT
C IS IN ID(3).
C
D WRITE(KFILDO,101)NCAT,((ITABLE(J,NCAT,L),J=1,4),L=1,2)
D101 FORMAT(/' AT 101 IN SCLSNO--',
D 1 'NCAT,((ITABLE(J,IDCAT.L),J=1,4),L=1,2)',I10/
D 2 (4I11))
D WRITE(KFILDO,102)(ITABLE(M1,J,1),M1=1,4),(IDPARS(M1),M1=1,15)
D102 FORMAT(/' AT 102--(ITABLE(M1,J,1),M1=1,4),(IDPARS(M1),M1=1,15)',
D 1 4I12/(15I8))
C
DO 105 L=1,2
C
IF(ID(1).EQ.ITABLE(1,IDCAT,L)+IDPARS(4).AND.
1 ID(2).EQ.ITABLE(2,IDCAT,L).AND.
2 (ID(3)/1000).EQ.(ITABLE(3,IDCAT,L)/1000).AND.
3 ID(4).EQ.ITABLE(4,IDCAT,L))THEN
GO TO 111
C THIS DEFINES L.
ENDIF
C
105 CONTINUE
C
C DROP THROUGH HERE MEANS THE ID WAS NOT FOUND.
C
IER=103
WRITE(KFILDO,110)(ID(J),J=1,4),IER
110 FORMAT(/' ****VARIABLE ',I9.9,I10.9,I10.9,I4.3,' NOT',
1 ' ACCOMMODATED IN SUBROUTINE SCLSNO. IER =',I3)
GO TO 900
C
C CHECK FOR NCAT = IDCAT-1
C
111 IF(NCAT.NE.IDCAT-1)THEN
IER=103
WRITE(KFILDO,112)NCAT,(ID(J),J=1,4),IER
112 FORMAT(/,' ****NCAT =',I3,' DOES NOT EQUAL IDCAT-1 IN SCLSNO.',
1 ' CANNOT PROCESS VARIABLE',I9.9,I10.9,I10.9,I4.3,
2 '. IER =',I3)
GO TO 900
ENDIF
C
C FIND THE NCAT PROBABILITIES AND SCALE. THE CATEGORICAL
C VALUES ARE IN XDATA( ) ON INPUT AND WILL BE MODIFIED.
C
FACTOR=CONST*10**NSCALE
C
D WRITE(KFILDO,113)ND1,NVAL,L,(IDPARS(M1),M1=1,15)
D113 FORMAT(/' AT 113--,ND1,NVAL,L,(IDPARS(M1),M1=1,15)',
D 1 3I12/(15I8))
C
D WRITE(KFILDO,1135)NVAL,FACTOR,(XDATA(M),M=1,NVAL)
D1135 FORMAT(' AT 1135 IN SCLSNO--NVAL,FACTOR,(XDATA(M),M=1,NVAL)',
D 1 I12,F8.2,/,(15F8.1))
C
KOUNT=0
C
DO 200 J=1,NCAT
C
IF(J.EQ.1)THEN
C THE 1ST CATEGORY IS FOR ZERO AMOUNT AND DOES NOT HAVE
C A PROBABILITY. XDATA( ) CONTAINS THE CATEGORICAL
C AMOUNTS FOR THIS CYCLE.
c
DO 115 K=1,NVAL
C
IF(NINT(XDATA(K)).EQ.9999)THEN
FD2(K)=9999.
C IF THE CATEGORICAL VALUE IS MISSING, NO
C COMPUTATIONS POSSIBLE.
ELSE
C
IF(NINT(XDATA(K)).EQ.J)THEN
FD2(K)=PREX3*FACTOR
KOUNT=KOUNT+1
ENDIF
C
ENDIF
C
115 CONTINUE
C
IF(KOUNT.EQ.0)THEN
WRITE(KFILDO,116)J
116 FORMAT(/' ****THERE WERE NO SNOW FORECASTS IN CATEGORY',I4,
1 ' THIS IS UNDOUBTEDLY AN ERROR; PROCEEDING.')
ISTOP(1)=ISTOP(1)+1
ISTOP(3)=ISTOP(3)+1
ENDIF
C
GO TO 200
ENDIF
C
D WRITE(KFILDO,117)J,L,(ITABLE(M1,J,L),M1=1,4)
D117 FORMAT(/' AT 117--J,L,(ITABLE(M1,J,L),M1=1,4)',
D 1 6I12)
C
C GET THE PROBABILITY OF CATEGORY J, J > 1. CAN BE A
C GRID OR VECTOR.
C
LD(1)=ITABLE(1,J,L)+IDPARS(4)
C THE DD IS ADDED.
LD(2)=ITABLE(2,J,L)
LD(3)=ITABLE(3,J,L)+IDPARS(12)
C THE TAU IS ADDED.
LD(4)=ITABLE(4,J,L)
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)
C
IF(IER.NE.0)THEN
ISTOP(3)=ISTOP(3)+1
WRITE(KFILDO,120)(LD(M1),M1=1,4)
120 FORMAT(/' ****COULD NOT FIND PROBABILITY RECORD',
1 3I10.9,I10,'. FATAL ERROR IN SCLSNO AT 120.')
GO TO 900
ENDIF
C
IF(NX.EQ.0)GO TO 1490
C WHEN NX NE 0, THIS IS A GRID, AND MUST BE PROCESSED
C ONTO THE CORRECT GRID.
C
IF(MISSP.NE.0)MISTOT=MISTOT+1
C
C IF THIS GRID COULD NOT BE OBTAINED OR THE GRID CHARACTERISTICS
C WERE NOT WHAT WAS EXPECTED, COUNT IT AS A GRID THAT COULD
C NOT BE OBTAINED BY INCREMENTING ISTOP(3). IT IS ALSO A
C FATAL ERROR FOR THIS ELEMENT.
C
C CHECK GRID PARAMETERS.
C
CALL CKGRID(KFILDO,LD,NPROJ,ORIENT,XLAT,IS2,ND7,IER)
C
IF(IER.NE.0)THEN
ISTOP(3)=ISTOP(3)+1
GO TO 900
ENDIF
C
C CKGRID ASSURES THE MAP PROJECTION (NPROJ), THE ORIENTATION
C (ORIENT), AND THE LATITUDE OF MESH LENGTH (XLAT) ARE
C WHAT ARE EXPECTED AND THAT THE MESH LENGTH IS ONE OF
C THE PERMISSIBLE ONES. IT IS NOT ASSURED AT THIS POINT
C THAT THE LOCATION OF THE GRID, THE MESH LENGTH, OR THE
C DIMENSIONS OF THE GRID ARE WHAT ARE WANTED.
C
C THE INPUT GRID AT ITS SIZE AND LOCATION IS IN DATA( ).
C POSITION THIS GRID (WITH THE SAME GRID LENGTH) OVER THE
C ANALYSIS AREA. ALATL AND ALONL REFER TO THE MESH
C LENGTH MESHB. IS2(8) IS IN MILLIMETERS; PSLLIJ, LMLLIJ,
C AND MCLLIJ NEED METERS. IS2(5) AND IS2(6) ARE IN
C TENTHS OF MILLIDEGRESS.
C
IF(NPROJ.EQ.3)THEN
CALL LMLLIJ(KFILDO,ALATL,ALONL,IS2(8)/1000.,ORIENT,XLAT,
1 REAL(IS2(5)/10000.),REAL(IS2(6)/10000.),
2 XIFG,YJFG)
ELSEIF(NPROJ.EQ.5)THEN
CALL PSLLIJ(KFILDO,ALATL,ALONL,IS2(8)/1000.,ORIENT,XLAT,
1 REAL(IS2(5)/10000.),REAL(IS2(6)/10000.),
2 XIFG,YJFG)
ELSEIF(NPROJ.EQ.7)THEN
CALL MCLLIJ(KFILDO,ALATL,ALONL,IS2(8)/1000.,XLAT,
1 REAL(IS2(5)/10000.),REAL(IS2(6)/10000.),
2 XIFG,YJFG)
ELSE
WRITE(KFILDO,146)NPROJ
146 FORMAT(/' ****MAP PROJECTION NUMBER NPROJ =',I3,
1 ' NOT 3, 5, OR 7. FATAL ERROR IN SCLSNO AT',
2 ' 146.')
IER=777
GO TO 900
ENDIF
C
CALL NOMINL(KFILDO,IS2(8)/1000000.,MESHI,TRASH,NPROJ,IER)
C MESHI IS THE GRID INPUT MESH LENGTH.
C IS2(8) IS IN KM*1000000; MESHI IS IN KM.
C
IF(IER.NE.0)THEN
GO TO 900
ENDIF
C
RATIO=REAL(MESH)/MESHI
NXI=NINT((NX-1)*RATIO)+1
NYI=NINT((NY-1)*RATIO)+1
NXOFF=NINT(XIFG)-1
NYOFF=NINT(YJFG)-1
C
D WRITE(KFILDO,147)RATIO,MESH,MESHI,NXI,NYI,NXOFF,NYOFF
D147 FORMAT(/' AT 147 IN SCLSNO--',
D 1 'RATIO,MESH,MESHI,NXI,NYI,NXOFF,NYOFF',F8.5,6I8)
D WRITE(KFILDO,1470)XIFG,YJFG,IS2(3),IS2(4)
D1470 FORMAT(' AT 1470 IN SCLSNO--XIFG,YJFG,IS2(3),IS2(4)',
D 1 2F12.5,2I12)
C
IF(NXOFF.NE.0.OR.NYOFF.NE.0.OR.IS2(3).NE.NXI.
1 OR.IS2(4).NE.NYI)THEN
CALL CUTIT(KFILDO,DATA,IS2(3),IS2(4),NXOFF,NYOFF,
1 DATA,NXI,NYI,IER)
C IS2(3) AND IS2(4) ARE THE INPUT GRID DIMENSIONS IN
C DATA( ). NXI AND NYI ARE THE OUTPUT GRID DIMENSIONS
C IN DATA( ). THERE IS NO NEED TO CALL CUTIT IF
C THE INPUT AND OUTPUT GRIDS ARE THE SAME.
ENDIF
C
IF(IER.NE.0)THEN
GO TO 900
ENDIF
C
CALL SZGRDM(KFILDO,DATA,NXI,NYI,MESHI,MESH,ITRPX,
1 IS2(3)*IS2(4))
C NXI AND NYI ARE THE DIMENSIONS IN OF THE INPUT
C GRID IN DATA( ). THEY ARE CHANGED, IF NECESSARY, TO
C BE THE DIMENSIONS OR THE OUTPUT GRID IN DATA( ). THEY
C WILL NOW AGREE WITH NX,NY CALCULATED PREVIOUSLY.
C
IF(NXI.NE.NX.OR.NYI.NE.NY)THEN
WRITE(KFILDO,148)NX,NXI,NY,NYI
148 FORMAT(/' ****NX AND NXI =',2I6,' OR NY AND NYI =',2I6,
1 ' DO NOT AGREE AT 148 IN SCLSNO. FATAL ERROR.')
IER=777
GO TO 900
ENDIF
C
D WRITE(KFILDO,149)MESHI,MESH,NXI,NYI,NX,NY
D149 FORMAT(/' AT 149 IN SCLSNO--MESHI,MESH,NXI,NYI,NX,NY',
D 1 6I6)
C
C THE GRID READ IN DATA( ) HAS NOW BEEN PUT ONTO THE SAME
C GRID AS THE INCOMING ONE IN XDATA( ), SO THE GRIDPOINTS
C MATCH ONE FOR ONE.
C
C FIND THE MAX AND MIN PROBABILITY FOR THIS CATEGORY.
C
1490 XMAX=-99999.
XMIN=99999.
D ICOUNT=0
C
DO 150 K=1,NVAL
C
IF(NINT(DATA(K)).EQ.9999)GO TO 150
C CHECKING THE PROBABILITY. IT IS POSSIBLE THERE COULD
C BE MISSING PROBABILITIES EVEN THOUGH THE CATEGORICAL
C VALUE IS THERE.
C
IF(NINT(XDATA(K)).EQ.J)THEN
D ICOUNT=ICOUNT+1
C
IF(DATA(K).LT.XMIN)THEN
XMIN=DATA(K)
ENDIF
C
IF(DATA(K).GT.XMAX)THEN
XMAX=DATA(K)
ENDIF
C
D WRITE(KFILDO,1495)XDATA(K),DATA(K),XMAX,XMIN,ICOUNT
D1495 FORMAT(' IN SCLSNO AT 1495--XDATA(K),DATA(K),XMAX,XMIN',
D 1 'ICOUNT',4F12.3,I7)
ENDIF
C
150 CONTINUE
C
IF(XMAX.EQ.-99999.)THEN
C THERE WERE NO FORECASTS IN THIS CATEGORY.
WRITE(KFILDO,152)J
152 FORMAT(/' THERE WERE NO FORECASTS IN CATEGORY',I4)
GO TO 200
ENDIF
C
IF(XMAX.EQ.XMIN)THEN
C
A=(TABLE(2,J)-TABLE(1,J))/2.+TABLE(1,J)
B=0.
RANGE=0.
C FOR A CONSTANT VALUE, THE OUTPUT IS THE MIDPOINT
C OF THE RANGE IN TABLE( , ). THIS MIGHT HAPPEN
C IF THERE WERE ONLY ONE INSTANCE OF THE CATEGORY.
C NOTE THAT IF THERE IS ONLY TWO INSTANCES AND
C THEY ARE DIFFERENT, THE OUTPUT WILL BE ONE VALUE
C AT THE LOW END OF THE CATEGORY AND ONE AT THE
C HIGH END--PROBABLY NOT A GOOD THING AND MAY
C HAVE TO BE MODIFIED.
ELSE
RANGE=XMAX-XMIN
B=(TABLE(2,J)-TABLE(1,J))/RANGE
A=TABLE(1,J)-B*XMIN
ENDIF
C
D WRITE(KFILDO,160)XMAX,XMIN,RANGE,
D 1 TABLE(2,J),TABLE(1,J)
D160 FORMAT(/,' IN SCLSNO AT 160--XMAX,XMIN,RANGE,',
D 1 'TABLE(2,J),TABLE(1,J)',5F10.3)
C
DO 170 K=1,NVAL
C
IF(NINT(XDATA(K)).EQ.9999)GO TO 170
C IF THE CATEGORICAL VALUE IS MISSING, NO COMPUTATIONS
C POSSIBLE. FD2( ) HAS ALREADY BEEN INITIALIZED TO 9999,
C EXCEPT FOR J=1, AND CONTROL DOES NOT COME HERE WHEN J=1.
C
IF(NINT(DATA(K)).EQ.9999)GO TO 170
C THIS GUARDS AGAINST A PROBABILITY BEING MISSING WHEN
C A CATEGORICAL VALUE IS THERE. THIS SHOULD NOT REALLY
C HAPPEN.
C
IF(NINT(XDATA(K)).EQ.J)THEN
FD2(K)=(A+B*DATA(K))*FACTOR
C
D WRITE(KFILDO,165)J,K,A,B,DATA(K),XDATA(K),FD2(K)
D165 FORMAT(' AT 165--J,K,A,B,DATA(K),XDATA(K),FD2(K)',
D 1 2I6,5F10.3)
C
ENDIF
C
170 CONTINUE
C
200 CONTINUE
C
C THE COMPUTATIONS WERE IN FD2( ); PUT THEM IN XDATA( ).
C
DO 210 K=1,NVAL
XDATA(K)=FD2(K)
210 CONTINUE
C
215 CONTINUE
C
D WRITE(KFILDO,225)(XDATA(K),K=1,NVAL)
C NOTE THAT THESE VALUES ARE WHAT IS BEING ANALYZED,
C SCALED BY CONST AND NSCALE.
D225 FORMAT(/,' IN SCLSNO AT 225',/,(15F8.2))
D230 CONTINUE
C
900 RETURN
END