SUBROUTINE U140(KFILDI,KFILDO,KFILIN,
1 ND1,ND2,ND3,ND2X3,ND4,ND5,
2 ND6,ND7,ND8,
3 ISCALD,PLAIN2,IPLAIN,L3264B,L3264W,
4 IPACK,DATA,SDATA,TMP_DATA,IWORK,GIS_DATA,
5 NAME,NAMIN,JFOPEN,MODNUM,
6 IS0,IS1,IS2,IS4,
7 IDATE,NWORK)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK ***
C
C SUBPROGRAM: U140
C PRGMMR: WEISS ORG: W/OST22 DATE: 2004-01-01
C
C ABSTRACT: SUBPROGRAM U140 IS USED COVERT A VECTOR SEQUENTIAL OR
C RANDOM ACCESS FILE TO A GRIDDED SEQUENTIAL AND/OR
C RANDOM ACCESS FILE.
C
C PROGRAM HISTORY LOG:
C 04-01-01 WEISS
C 05-03-07 MALONEY ADDED NCEP DOCBLOCK
C 05-03-11 MALONEY ADDED VARIABLE MISSV TO SELECT THE TYPE
C OF MISSING VALUE OPTION
C 05-10-17 COSGROVE CHANGED SOME MESSAGES WITH THE CORNER
C CHECKING TO MAKE IT MORE USER-FRIENDLY.
C ALSO REMOVED CHECK NEAR LINE 523 THAT
C FORCED THE ADJUSTED ID TO GO FROM X0X
C TO X1X. IT NOW LETS YOU SET THE OUTPUT
C ID TO ANYTHING... BUT NOTE THAT THE
C INPUT ID AND OUTPUT ID MUST BE IN THE
C SAME POSITIONS IN THEIR RESPECTIVE LISTS.
C 06-03-27 COSGROVE CHANGED RANDOM ACCESS WRITING TO USE
C PACKGR_OPER INSTEAD OF PAWRAG. HAD TO
C ADD ARRAY NGRIDC AND WORK ARRAY FD1,
C VARIABLES NTOTGB/NTOTGR, AND PARSE THE
C ID THAT'S SENT INTO PACKGR_OPER. ALSO
C SET DD AND PROJECTION BEFORE CALL TO
C SEQUENTIAL PACKER.
C 07-06-20 MALONEY ***NOTE*** TO GET U140 TO WORK FOR
C |\ ALASKA, I HAD TO COMMENT OUT A LINE
C ||\ IN THE POLAR STEREOGRAPHIC SECTION
C ==========> THAT MULTIPLIED THE ALON BY NEG. 1.
C ||/ THIS MAY HAVE IMPACTS ON OTHER STUFF
C |/ AND SHOULD ONLY BE TREATED AS A
C BAND-AID SOLUTION! ********$$$$$$%%%%%%
C 3/08 - THIS IS ACTUALLY THE REAL SOLUTION
C TO MAKE THIS CODE WORK WITH PSIJLL.
C 2009-08-28 MALONEY ADDED PIECE FOR NPROJ 7 (MERCATOR)
C 2009-09-02 MALONEY REMOVED ERRONEOUS 405 DO LOOP. THIS CAUSED
C PROBLEMS WITH THE PACKED OUTPUT WHEN INUM
C AND ISTA WERE IDENTICAL.
C 2012-06-25 ENGLE ADDED PLAIN2( ) TO THE CALLING SEQUENCE FOR ALL
C CALLS TO PAWRAG AND PACKGR_OPER.
C 2012-07-16 ENGLE ADDED CONVERTX; ADDED CALL TO CKFILEND
C BEFORE OPENING A TDLPACK VECTOR FILE; MODIFIED
C OPEN STATEMENT TO INCLUDE CONVERT= SPECIFIER.
C
C USAGE: CALLED BY DRU140
C
C DATA SET USE:
C INPUT FILES:
C FORT.KFILDI - UNIT NUMBER OF INPUT FILE. (INPUT)
C FORT.KFILP - THE UNIT NUMBER FOR WHERE THE PREDICTOR LIST
C IS TO BE FOUND. (INPUT)
C FORT.KFILIN(J) - UNIT NUMBERS FOR INPUT DATA, ALL IN TDLPACK
C FORMAT. INPUT CAN INCLUDE GRIDPOINT (FILES)
C DATA, PREDICTAND (OBSERVATIONS) DATA, VARIOUS
C CONSTANTS, OR MOS FORECASTS (J=1,NUMIN). (INPUT)
C FORT.KFILD(J) - THE UNIT NUMBER FOR WHERE THE STATION LIST
C (J=1) AND THE STATION DIRECTORY (J=2) RESIDES.
C CORRESPONDS TO DIRNAM(J). WHEN KFILD(1) =
C KFILDI, THE DEFAULT INPUT IS INDICATED,
C DIRNAM(1) IS NOT USED, AND THE FILE IS NOT
C OPENED. KFILD(1) CAN EQUAL KFILD(2), IN WHICH
C CASE THE STATION LIST IS TAKEN FROM THE
C DIRECTORY (I.E., A SEPARATE STATION LIST IS NOT
C PROVIDED). (INPUT)
C FORT.KFILDT - UNIT NUMBER WHERE THE DATE LIST IS LOCATED.
C (INPUT)
C FORT.KFILRA - UNIT NUMBER OF INPUT RANDOM ACCESS FILE
C CONTAINING MOS-2000 CONSTANT DATA. (INPUT)
C OUTPUT FILES:
C FORT.KFILDO - UNIT NUMBER OF OUTPUT (PRINT) FILE. (OUTPUT)
C FORT.IP(J) - UNIT NUMBERS FOR OPTIONAL OUTPUT (SEE IP( )
C UNDER "VARIABLES" BELOW.) (J=1,25) (OUTPUT)
C FORT.KFILGO - UNIT NUMBER OF GRIDPOINT OUTPUT FILE.
C (OUTPUT)
C FORT.KFILRA - UNIT NUMBER OF INPUT RANDOM ACCESS FILE
C CONTAINING MOS-2000 CONSTANT DATA. (OUTPUT)
C FORT.KFILGIS - UNIT NUMBER OF ARC-GIS OUTPUT FILE.
C (OUTPUT)
C FORT.KFILX - UNIT NUMBER FOR THE GRIDPOINT OUTPUT
C RANDOM ACCESS FILE. (OUTPUT)
C
C VARIABLES
C KFILDI = UNIT NUMBER TO READ INPUT FILE 'U140.CN'.
C (INPUT)
C KFILDO = UNIT NUMBER OF OUTPUT (PRINT) FILE. INITIALLY,
C THIS IS SET BY DATA STATEMENT. LATER, IN
C IPOPEN, IF IP(1) NE 0, KFILDO IS SET = IP(1).
C THIS ALLOWS CHANGING THE "DEFAULT" PRINT FILE ON
C THE FLY. OTHERWISE, ON SOME SYSTEMS, THE OUTPUT
C FILE MIGHT HAVE THE SAME NAME AND BE OVERWRITTEN.
C WHEN THE OUTPUT FILE IS NOT THE ORIGINAL DEFAULT,
C THE NAME IS GENERATED AND CAN BE DIFFERENT FOR
C EACH RUN. (INPUT)
C KFILIN(J) = UNIT NUMBERS FOR SEQUENTIAL INPUT DATA, ALL IN
C TDLPACK FORMAT. INPUT CAN INCLUDE GRIDPOINT (FILES)
C DATA, PREDICTAND (OBSERVATIONS) DATA, VARIOUS
C CONSTANTS, OR MOS FORECASTS (FOR 2ND GENERATION
C MOS, POSSIBLY FOR LOCAL IMPLEMENTATION
C (J=1,NUMIN). (OUTPUT)
C ND1 = MAXIMUM NUMBER OF STATIONS THAT CAN BE DEALT
C WITH (I.E., INTERPOLATION DONE FOR). NOTE THAT
C THIS DOES NOT INCLUDE THE NUMBER OF STATIONS IN
C THE DIRECTORY UNLESS, OF COURSE, THE STATION
C DIRECTORY IS TO BE USED AS THE STATION LIST.
C SET BY PARAMETER. (INPUT)
C ND2 = ND2*ND3 IS THE MAXIMUM SIZE OF THE GRID THAT CAN
C BE DEALT WITH. ND2 AND ND3 ARE SET SEPARATELY
C TO HIGHLIGHT THE POSSIBLE DIMENSIONS OF THE
C GRID. HOWEVER, IN THE CALLED ROUTINES, THE SIZE
C IS ONLY LIMITED BY THE PRODUCT, NOT EACH
C DIMENSION INDIVIDUALLY. NOT ACTUALLY USED
C EXCEPT IN DRU140. SET BY PARAMETER. (INPUT)
C ND3 = ND2*ND3 IS THE MAXIMUM SIZE OF THE GRID THAT CAN
C BE DEALT WITH. SEE ND2. SET BY PARAMETER.
C (INPUT)
C ND2X3 = THE DIMENSION OF SEVERAL ARRAYS. SET BY
C PARAMETER. (INPUT)
C ND4 = THE MAXIMUM NUMBER OF VARIABLES FOR WHICH
C GRIDDED VALUES CAN BE PROVIDED. SET BY
C PARAMETER. (INPUT)
C ND5 = DIMENSION OF IPACK, IWORK, DATA.
C THESE ARE GENERAL PURPOSE ARRAYS, SOMETIMES USED
C FOR GRIDS. TWO SIZES OF ARRAYS (ND5 AND ND2X3)
C ARE USED IN CASE AN ARRAY NEEDS TO BE LARGER
C THAN ND2X3. ND5 CAN BE INCREASED WITHOUT
C INCREASING THE SIZE OF ALL ARRAYS. SHOULD BE GE
C ND2X3. SET BY PARAMETER. (INPUT)
C ND6 = MAXIMUM NUMBER OF MODELS THAT CAN BE DEALT WITH
C IN ONE RUN. DIMENSION OF KFILIN( ) AND
C NAMIN( ). SET BY PARAMETER. (INPUT)
C ND7 = DIMENSION OF IS0( ), IS1( ), IS2( ), AND IS4( ).
C NOT ALL LOCATIONS ARE USED. MAXIMUM SIZE IS FOR
C IS1( ) = 22 PLUS 32 CHARACTERS (ONE CHARACTER
C PER WORD) OF PLAIN TEXT = 54. SET BY PARAMETER.
C (INPUT)
C ND8 = MAXIMUM NUMBER OF DATES THAT CAN BE DEALT WITH.
C (INPUT)
C ISCALD(N) = THE DECIMAL SCALING CONSTANT TO USE WHEN PACKING
C THE GRIDDED DATA (N=1,ND4). NO BINARY
C SCALING IS PROVIDED FOR. (OUTPUT)
C PLAIN2 = THE PLAIN LANGUAGE CHARACTER STRING EQUIVALENCED
C TO ARRAY IPLAIN. (CHARACTER*32), (INPUT/INTERNAL)
C IPLAIN(L,J) = 32 CHARACTERS (L=1,L3264W) (J=1,4) OF PLAIN
C LANGUAGE DESCRIPTION OF VARIABLES.
C NOTE THAT THIS REQUIRES TWO 32-BIT WORDS TO HOLD
C THE DESCRIPTION BUT ONLY ONE 64-BIT WORD.
C EQUIVALENCED TO PLAIN2. (INPUT/INTERNAL)
C L3264B = INTEGER WORD LENGTH IN BITS OF MACHINE BEING
C USED (EITHER 32 OR 64). SET BY PARAMETER.
C (INPUT)
C L3264W = NUMBER OF WORDS IN 64 BITS (EITHER 1 OR 2).
C CALCULATED BY PARAMETER, BASED ON L3464B.
C (INPUT)
C IPACK(J) = INTEGER WORK ARRAY (J=1,ND5). (INPUT/INTERNAL)
C DATA(J) = REAL WORK ARRAY (J=1,ND5). (INPUT/INTERNAL)
C SDATA(J) = ARRAY CONTAINING THE DATA VALUES TO BE EVENTUALLY
C STORED BY PACKV (J=1,ND5). (INPUT/INTERNAL)
C NOTE: FD1 IN DRU140
C TMP_DATA(J) = REAL WORK ARRAY (J=1,ND5). (INPUT/INTERNAL)
C NOTE: FD2 IN DRU140
C IWORK(J) = INTEGER WORK ARRAY (J=1,ND5). (INPUT/INTERNAL)
C GIS_DATA(I,J) = GIS ASCII FILE OUTPUT ARRAY (I=1,ND5),
C (J=1,ND7). (INPUT/INTERNAL)
C NAME(K) = NAMES OF STATIONS (K=1,ND1) (CHARACTER*20).
C (INPUT/INTERNAL)
C NAMIN(J) = HOLDS DATA SET NAMES FOR THE UNIT NUMBERS IN
C KFILIN(J) (J=1,NUMIN). (CHARACTER*60)
C (INPUT/INTERNAL)
C JFOPEN(J) = FOR EACH FILE IN KFILIN(J), JFOPEN(J) IS 1 WHEN
C THE FILE IS OPEN, IS 0 WHEN IT HAS ALREADY BEEN
C USED AND IS 2 WHEN THE FILE HAS NOT BEEN OPENED
C (J=1,ND6). (INPUT/INTERNAL)
C MODNUM(J) = THE "MODEL" NUMBER CORRESPONDING TO KFILIN(J),
C AND NAMIN(J) (J=1,NUMIN). THIS MAY NOT HAVE
C MEANING FOR SOME INPUTS, BUT IS NEEDED FOR THE
C MODEL DATA. (INPUT/INTERNAL)
C IS0(J) = MOS-2000 GRIB SECTION 0 ID'S (J=1,4).
C (INPUT/INTERNAL)
C IS1(J) = MOS-2000 GRIB SECTION 1 ID'S (J=1,21+).
C (INPUT/INTERNAL)
C IS2(J) = MOS-2000 GRIB SECTION 2 ID'S (J=1,12).
C (INPUT/INTERNAL)
C IS4(J) = MOS-2000 GRIB SECTION 4 ID'S (J=1,4).
C (INPUT/INTERNAL)
C IDATE(J) = INITIAL DATE LIST (J=1,NDATES) WHICH MAY CONTAIN
C NEGATIVE VALUES INDICATING A DATE SPAN.
C THIS IS MODIFIED IN DATPRO TO CONTAIN THE COMPLETE
C DATE LIST WITH THE DATES IN THE SPANS FILLED IN
C (J=1,NDATES), WHERE NDATES HAS BEEN INCREASED
C IF NECESSARY. DATES ARE INPUT AS YYMMDDHH AND
C MODIFIED TO YYYYMMDDHH. ZEROS IN THE INPUT ARE
C ELIMINATED. TERMINATOR IS 99999999. MAXIMUM
C NUMBER OF DATES IS ND8. (INPUT/INTERNAL)
C NWORK(J) = A WORK ARRAY (J=1,ND8). (INPUT/INTERNAL)
C
C
C ADDITIONAL VARIABLES (INT140.F)
C
C
C KFILDT = UNIT NUMBER FOR READING THE DATE LIST (INTERNAL).
C KFILRA = UNIT NUMBERS FOR RANDOM ACCESS INPUT DATA, ALL IN
C TDLPACK FORMAT. (INTERNAL)
C KFILGIS = UNIT NUMBER OF GIS OUTPUT FILE. (INTERNAL)
C KFILGO = UNIT NUMBER OF GRIDPOINT SEQUENTIAL OUTPUT FILE.
C (INTERNAL)
C KFILX = UNIT NUMBER OF GRIDPOINT RANDOM ACCESS OUTPUT
C FILE. (INTERNAL)
C RACESS = FILE NAME OF THE INPUT EXTERNAL RANDOM ACCESS
C FILE. ONLY ONE IS ALLOWED (CHARACTER*60).
C (OUTPUT)
C KFILD(J) = THE UNIT NUMBER FOR WHERE THE STATION LIST (J=1)
C AND THE STATION DIRECTORY (J=2) RESIDES.
C CORRESPONDS TO DIRNAM(J). WHEN KFILD(1) =
C KFILDI, THE DEFAULT INPUT IS INDICATED,
C DIRNAM(1) IS NOT USED, AND THE FILE IS NOT
C OPENED. KFILD(1) CAN EQUAL KFILD(2), IN WHICH
C CASE THE STATION LIST IS TAKEN FROM THE
C DIRECTORY (I.E., A SEPARATE STATION LIST IS NOT
C PROVIDED).
C IP(J) = EACH VALUE (J=1,25) INDICATES WHETHER (>1)
C OR NOT (=0) CERTAIN INFORMATION WILL BE WRITTEN.
C WHEN IP( ) > 0, THE VALUE INDICATES THE UNIT
C NUMBER FOR OUTPUT. THESE VALUES SHOULD NOT BE THE
C SAME AS ANY KFILX VALUES EXCEPT POSSIBLY
C KFILDO, WHICH IS THE DEFAULT OUTPUT FILE. THIS IS
C ASCII OUTPUT, GENERALLY FOR DIAGNOSTIC PURPOSES.
C THE FILE NAMES WILL BE 4 CHARACTERS 'U140',
C THEN 4 CHARACTERS FROM IPINIT, THEN 2 CHARACTERS
C FROM IP(J) (E.G., 'U140HRG140'). THE ARRAY IS
C INITIALIZED TO ZERO IN CASE LESS THAN THE EXPECTED
C NUMBER OF VALUES ARE READ IN. EACH OUTPUT ASCII
C FILE WILL BE TIME STAMPED. NOTE THAT THE TIME
C ON EACH FILE SHOULD BE VERY NEARLY THE SAME, BUT
C COULD VARY BY A FRACTION OF A SECOND. IT IS
C INTENDED THAT ALL ERRORS BE INDICATED ON THE
C DEFAULT, SOMETIMES IN ADDITION TO BEING INDICATED
C ON A FILE WITH A SPECIFIC IP( ) NUMBER, SO THAT
C THE USER WILL NOT MISS AN ERROR.
C (1) = ALL ERRORS AND OTHER INFORMATION NOT
C SPECIFICALLY IDENTIFIED WITH OTHER IP( )
C NUMBERS. WHEN IP(1) IS READ AS NONZERO,
C KFILDO, THE DEFAULT OUTPUT FILE UNIT NUMBER,
C WILL BE SET TO IP(1). WHEN IP(1) IS READ
C AS ZERO, KFILDO WILL BE USED UNCHANGED.
C (2) = THE INPUT DATES IN IDATE( ). WHEN THERE
C ARE ERRORS, PRINT WILL BE TO UNIT KFILDO AS
C WELL AS TO UNIT IP(2).
C (3) = THE OUTPUT DATES IN IDATE( ). WHEN THERE
C ARE ERRORS, OUTPUT WILL BE TO UNIT KFILDO AS
C WELL AS TO UNIT IP(3).
C (4) = THE INPUT SEQUENTIAL FILE(S). IF
C THERE ARE NO INPUT SEQUENTIAL FILES, A
C MESSAGE WILL BE WRITTEN TO THE DEFAULT OUTPUT
C FILE UNIT KFILDO AS WELL AS TO UNIT IP(4).
C (5) = THE INPUT RANDOM ACCESS FILE. IF
C THERE ARE NO INPUT RANDOM ACCESS FILES, A
C MESSAGE WILL BE WRITTEN TO THE DEFAULT OUTPUT
C FILE UNIT KFILDO AS WELL AS TO UNIT IP(5).
C (6) = THE OUTPUT GIS, SEQUENTIAL, AND RANDOM
C ACCESS FILE. IF ANY OF THE OUTPUT FILES ARE
C MISSING, A MESSAGE WILL BE WRITTEN TO THE
C DEFAULT OUTPUT FILE UNIT KFILDO AS WELL AS
C TO UNIT IP(6).
C (7) = THE INPUT STATION LIST IS WRITTEN. IF THERE
C ARE INPUT ERRORS, THE STATION LIST WILL BE
C WRITTEN TO THE DEFAULT OUTPUT FILE
C UNIT KFILDO AS WELL AS TO UNIT IP(7).
C NOTE: INPUT STATION LISTS ARE NOT YET
C OPERATIONAL FOR U140./
C (8) = THE STATION DIRECTORY INFORMATION IS
C WRITTEN. IF THERE ARE INPUT ERRORS,
C THE DIRECTORY INFO WILL BE WRITTEN TO THE
C DEFAULT OUTPUT FILE UNIT KFILDO AS WELL AS
C TO UNIT IP(8).
C (9) = THE INPUT VARIABLE IDS ARE WRITTEN TO
C UNIT IP9 AS THE VARIABLES ARE READ IN.
C ARE READ IN. THIS SHOULD BE USEFUL FOR
C CHECKOUT.
C NOTE: FOR BOTH NON-ADJUSTED AND ADJUSTED
C VARIABLES.
C (10) = THE VARIABLE LIST WILL BE WRITTEN TO UNIT
C IP10 PARSED INTO ITS 15 INTEGER COMPONENTS.
C 15 INTEGER COMPONENTS. IF THERE ARE INPUT
C ERRORS, THE VARIABLE LIST WILL BE WRITTEN
C TO THE DEFAULT OUTPUT FILE UNIT KFILDO AS WELL AS
C TO UNIT IP10 IF THEY ARE DIFFERENT.
C NOTE: FOR BOTH NON-ADJUSTED AND ADJUSTED
C VARIABLES.
C (16) = A STATEMENT WILL BE OUTPUT TO IP(16)
C WHEN A SEQUENTIAL FILE IS WRITTEN THROUGH
C PWOTGM.
C (23) = INDICATES WHETHER (>0) OR NOT (=0)
C STATEMENTS ABOUT EOF AND FILE OPENINGS AND
C CLOSINGS WILL BE OUTPUT FOR PRINTING ON UNIT
C IP(23). (INTERNAL)
C IUSE(J) = EACH VALUE J PERTAINS TO IP(J). WHEN AN IP(J)
C VALUE IS USED BY THE PROGRAM, IPRINT(J) = 1;
C OTHERWISE, IPRINT(J) = 0. USED BY IPRINT TO
C PRINT IP( ) VALUES, (J=1,25).
C NDATES = THE NUMBER OF DATES IN IDATE( ). (OUTPUT)
C PLAIN(N) = THE PLAIN LANGUAGE DESCRIPTION OF THE VARIABLES
C (N=1,ND4). (CHARACTER*32)
C IDPARS(J,N) = THE PARSED, INDIVIDUAL COMPONENTS OF THE VARIABLE
C ID'S CORRESPONDING TO ID( ,N) GENERATED IN
C RDVR37. (J=1,15), (N=1,NVRBL).
C (INTERNAL)
C J=1--CCC (CLASS OF VARIABLE),
C J=2--FFF (SUBCLASS OF VARIABLE),
C J=3--B (BINARY INDICATOR),
C 0 = NOT BINARY,
C 1 = CUMULATIVE FROM ABOVE, VALUES GE LOWER THRESHOLD
C TRESHL = 1,
C 2 = CUMULATIVE FROM BELOW, VALUES LT UPPER THRESHOLD
C TRESHU = 1.
C 3 = DISCRETE BINARY. VALUES GE LOWER THRESHOLD AND
C LT UPPER THRESHOLD = 1.
C 5 = GRID BINARY. VALUES GE LOWER THRESHOLD
C ONLY THE VALUE OF 0, 1, OR 5 SHOULD BE USED FOR
C PREDICTORS;
C 0, 1, 2, OR 3 CAN BE USED FOR PREDICTANDS.
C J=4--DD (DATA SOURCE, MODEL NUMBER),
C J=5--V (VERTICAL APPLICATION),
C J=6--LBLBLBLB (BOTTOM OF LAYER, 0 IF ONLY 1 LAYER),
C J=7--LTLTLTLT (TOP OF LAYER),
C J=8--T (TRANSFORMATION),
C J=9--RR (RUN TIME OFFSET, ALWAYS + AND 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), AND
C J=15--G (GRID INDICATOR). THIS HAS NO MEANING
C EXCEPT IN U201, AND IS SET TO ZERO. THIS
C IN CASE THE SAME VARIABLE LIST IS USED IN
C U201 AND OTHER PROGRAMS, SUCH AS U600.
C ID(J,N) = THE INTEGER VARIABLE IDS (J=1,4) (N=1,ND4).
C (INTERNAL)
C IOUTD = THE GIS FILE UNIT NUMBER (INTERNAL)
C IOUTG = THE SEQUENTIAL FILE UNIT NUMBER (INTERNAL)
C IOUTJ = THE SEQUENTIAL FILE UNIT NUMBER (INTERNAL)
C CFILX = HOLDS DATA SET NAME FOR THE UNIT NUMBER IN KFILX.
C (CHARACTER*60) (INTERNAL)
C NUMIN = THE NUMBER OF VALUES IN KFILIN( ), NAMES IN
C NAMIN( ), ETC. MAXIMUM OF ND6. THIS IS REDUCED
C IF THERE IS NO VARIABLE WITH A PARTICULAR
C MODEL NUMBER. (INTERNAL)
C NUMRA = THE NUMBER OF INPUT RANDOM ACCESS FILES
C NAMES TO READ (WILL ALWAYS BE ONE).
C NAM( ), AND MODEL NUMBERS IN MODNUM( ),
C MAXIMUM OF ND6. (INTERNAL)
C INCCYL = THE NUMBER OF HOURS BETWEEN DATES WHEN DATE SPANNING
C IS USED. (INTERNAL)
C NPROJ = MAP PROJECTION OF THE OUTPUT GRID. (INTERNAL)
C NX = X-EXTENT OF THE OUTPUT GRID. (INTERNAL)
C NY = Y-EXTENT OF THE OUTPUT GRID. (INTERNAL)
C XLATLL = LATITUDE OF LOWER LEFT CORNER POINT OF THE
C OUTPUT GRID. (INTERNAL)
C YLONLL = WEST LONGITUDE OF LOWER LEFT CORNER POINT
C OF THE OUTPUT GRID. DO NOT USE NEGATIVE.
C (INTERNAL)
C XMESHL = MESH LENGTH OF OUTPUT GRID IN KM AT XLAT DEGREES
C NORTH LATITUDE. (INTERNAL)
C ORIENT = ORIENTATION OF OUTPUT GRID IN DEGREES WEST
C LONGITUDE. DO NOT USE NEGATIVE. (INTERNAL)
C XLAT = LATITUDE OF OUTPUT GRID IN DEGREES AT WHICH
C XMESHL APPLIES. ALSO THE LATITUDE WHERE THE
C PROJECTION CUTS THE EARTH. DO NOT USE NEGATIVE.
C (INTERNAL)
C ICHARS = NUMBER OF CHARACTERS FOR CALL LETTERS IN
C PRINTING, MAX OF 8, MIN OF 4. (INTERNAL)
C MISSV = THE MISSING VALUE OPTION WHERE 0=9999.
C 1 = AVERAGE OF INPUT FIELD (INTERNAL).
C LNGTH = LINE LENGTH FOR PRINTING TO IP(16). (INTERNAL)
C NVRBL = THE NUMBER OF VARIABLES. (INTERNAL)
C ADJUSTED VARIABLES
C
C PLAIN_ADJ(N) = THE PLAIN LANGUAGE DESCRIPTION OF THE ADJUSTED
C VARIABLES (N=1,ND4). (CHARACTER*32) (INTERNAL)
C ID_ADJ(J,N) = THE INTEGER ADJUSTED VARIABLE ID'S (J=1,4)
C (N=1,ND4).
C ISCALD_ADJ(N) = THE SCALLING FACTORS FOR THE ADJUSTED
C VARIABLES (N=1,ND4). (OUTPUT)
C NVRBL_ADJ = THE NUMBER OF ADJUSTED VARIABLES(OUTPUT)
C
C CALLML(K,J) = 8-CHARACTER STATION CALL LETTERS (OR GRIDPOINT
C LOCATIONS FOR GRID DEVELOPMENT) TO PROVIDE
C OUTPUT FOR (J=1) AND 5 POSSIBLE OTHER STATION
C CALL LETTERS (J=2,6) THAT CAN BE USED INSTEAD
C IF THE PRIMARY (J=1) STATION CANNOT BE FOUND
C IN AN INPUT DIRECTORY (K=1,ND1). ALL STATION
C DATA ARE KEYED TO THIS LIST. (CHARACTER*8)
C (INTERNAL)
C NOTE: FOR GRIDDED MOS PURPOSES, ONLY CALLML( ,1)
C IS USED FOR COMPARISON WITH CCALLS( ).
C RCCALLD(K) = 8-CHARACTER STATION CALL LETTERS AS READ
C FROM THE INPUT LIST OF STATIONS (K=1,ND1)
C NOTE: THIS LIST IS NOT YET A REQUIREMENT
C OF U140, BUT A FILE NEEDS TO EXISTS IN
C U140.CN (INTERNAL)
C NELEV(K) = ELEVATION OF STATIONS (K=1,ND1). (INTERNAL)
C STALAT(K) = LATITUDE OF STATIONS (K=1,ND1). (INTERNAL)
C STALON(K) = LONGITUDE OF STATIONS (K=1,ND1). (INTERNAL)
C ISTA = THE NUMBER OF COUNTED STATIONS IN THE STATION
C TABLE. (INTERNAL)
C IPINIT = 4 CHARACTERS USED TO HELP IDENTIFY OUTPUT
C ASSOCIATED WITH THE IP( ) NUMBERS.
C (CHARACTER*4) (INTERNAL)
C ISTOP = 0 MEANS THE PROGRAM IS RUNNING OK UP TO THIS
C POINT. WHENEVER AN ERROR OCCURS THAT SHOULD
C HALT THE PROGRAM AFTER INPUT DIAGNOSTICS ARE
C PRINTED, ISTOP IS SET = ISTOP+1. (INPUT-OUTPUT)
C
C RDTDLM VARIABLES
C
C CCALLS(K) = 8-CHARACTER STATION CALL LETTERS (OR GRIDPOINT
C LOCATIONS FOR GRID DEVELOPMENT AS READ IN FROM
C THE INPUT SEQUENTIAL OR RANDOM ACCESS FILE
C (K=1,ND1). (CHARACTER*8) (INTERNAL)
C ID_START(K) = ID ARRAY FOR READING THE DIRECTORY RECORD FOR
C THE INPUT RANDOM ACCESS FILE. (INTERNAL)
C NVALUE = WITHIN ARGUMENT LIST OF SUBROUTINE. (INTERNAL)
C
C
C LMIJLL AND PSIJLL VARIABLES
C
C ALAT = NORTH LATITUDE IN DEGREES OF THE POINT CORRESPONDING
C TO XI, YJ.
C ALON = WEST LONGITUDE IN DEGREES OF THE POINT CORRESPONDING
C TO XI, YJ.
C XI(M) = IX (LEFT TO RIGHT) GRIDPOINT FOR WHICH THE
C LATITUDE AND LONGITUDE ARE WANTED, M=1,5 FOR CORNER
C POINTS (INTERNAL).
C YJ(M) = JY (BOTTON TO TOP) GRIDPOINT FOR WHICH THE
C LATITUDE AND LONGITUDE ARE WANTED, M=1,5 FOR CORNER
C POINTS (INTERNAL).
C IX(M) = THE XI*YJ ELEMENT IN THE GRIDDED ARRAY
C
C
C SEQUENTIAL FILE OUTPUT (PWOTGM)
C
C IOCTTG = THE PACKED GRID RECORD SIZE IN OCTETS (BYTES).
C (INTERNAL)
C ISCALE = THE SCALLING FACTOR FOR THE VARIABLE (INTERNAL).
C ITAUH = PROJECTION IN HOURS. (INTERNAL)
C ITAUM = PROJECTION IN MINUTES. (INTERNAL)
C LX = THE NUMBER OF GROUPS (THE NUMBER OF 2ND ORDER
C MINIMA). WHILE NEEDED ONLY IN SUBROUTINE PACK,
C IT IS OUTPUT IN THE ARGUMENT LIST OF PAWOTG IN
C CASE THE USER WANTS TO KNOW IT. (INTERNAL)
C MAX_NSTA = MAXIMUM NUMBER OF STATION THAT CAN BE WRITTEN.
C (INTERNAL)
C MODNO = MODEL NUMBER. (INTERNAL)
C NSEQ = SEQUENCE NUMBER. (INTERNAL)
C NTOTBG = THE TOTAL NUMBER OF BYTES IN PACKED DATA RECORDS
C WRITTEN FOR GRID FILE. (INTERNAL)
C NTOTRG = THE TOTAL NUMBER OF PACKED RECORDS WRITTEN TO
C GRID FILE. (INTERNAL)
C
C
C RANDOM ACCESS FILE OUTPUT (PAWRAG)
C
C IOCTET = THE TOTAL RECORD SIZE IN OCTETS WRITTEN TO THE
C RANDOM ACCESS FILE.
C LX = SEE PWOTGM
C XMISSP = SET TO 9999. INDICATING THAT ANY MISSING DATA
C VALUE WILL BE PACKED AS 9999.
C XMISSS = SET TO 0 TO INDICATE THERE WILL BE NO SECONDARY
C MISSING VALUE INDICATOR (SEE XMISSP).
C NCHAR = THE NUMBER OF CHARACTERS IN IPLAIN TO INSERT
C INTO IS1( ) FOR PACKING, MAXIMUM OF 32.
C IPLAIN( ,J) = PLAIN LANGUAGE TO INSERT INTO IS1( ) (J=1,4).
C EQUIVALENCED TO PLAIN2.
C PLAIN = PLAIN LANGUAGE TO INSERT INTO IS1( ).
C EQUIVALENCED TO IPLAIN( , ) (CHARACTER*32)
C MINPK = VALUES ARE PACKED IN GROUPS OF MINIMUM SIZE
C MINPK. ONLY WHEN THE NUMBER OF BITS TO HANDLE
C A GROUP CHANGES WILL A NEW GROUP BE FORMED.
C SET TO 14 BY DATA STATEMENT.
C
C PACKGR_OPER
C FD1(J) = WORK ARRAY. PASSED INTO PACKGR_OPER BECAUSE THE
C CALL HAS IT, BUT IT'S NOT ACTUALLY USED IN THE
C SUBROUTINE. J=1,ND5
C NGRIDC(L,M) = HOLDS THE GRID CHARACTERISTICS (L=1,6) FOR EACH GRID
C COMBINATION (M=1,NGRID).
C L=1--MAP PROJECTION NUMBER (3=LAMBERT, 5=POLAR
C STEREOGRAPHIC).
C L=2--GRID LENGTH IN MILLIMETERS,
C L=3--LATITUDE AT WHICH GRID LENGTH IS CORRECT *10000,
C L=4--GRID ORIENTATION IN DEGREES *10000,
C L=5--LATITUDE OF LL CORNER IN DEGREES *10000,
C L=6--LONGITUDE OF LL CORNER IN DEGREES *10000.
C NTOTGB = THE TOTAL NUMBER OF BYTES ON THE FILE ASSOCIATED
C WITH UNIT NO. KFILRA(JJ) (THE TDLPACK RA FILE).
C IT IS UPDATED WHEN THE DATA IN IPACK( ) ARE
C WRITTEN. (INPUT-OUTPUT)
C NTOTGR = THE TOTAL NUMBER OF RECORDS ON THE RA FILE. IT
C IS UPDATED WHEN THE DATA IN IPACK( ) ARE
C WRITTEN. (INPUT-OUTPUT)
C
C ADDITIONAL VARIABLES
C
C
C CCALLS(K) = 8-CHARACTER STATION CALL LETTERS (OR GRIDPOINT
C LOCATIONS FOR GRID DEVELOPMENT AS READ IN FROM
C THE INPUT SEQUENTIAL OR RANDOM ACCESS FILE
C (K=1,ND1). (CHARACTER*8) (INTERNAL)
C FOUND_MATCH = LOGICAL TO DECLARE WHEN A VARIABLE ID FROM THE
C THE INPUT LIST MATCHES A VARIABLE ID FROM THE
C INPUT FILE. (INTERNAL)
C KDATE = DATE OF PREVIOUSLY READ RECORD WHEN READING
C AN INPUT SEQUENTIAL FILE. (INTERNAL)
C ID_IMISS(J,N) = THE INTEGER VARIABLE IDS (J=1,4) (N=1,ND4) OF
C IDS WHICH COULD NOT BE FOUND IN THE INPUT
C SEQUENTIAL FILE. (INTERNAL)
C NOTE: BAD INPUT LIST VARIABLE IDS
C IFIRST = RECORD READER DETERMINES IF DIRECTORY RECORD
C NEEDS TO BE READ FROM THE INPUT FILE(S) (INTERNAL).
C IHOLD = VARIABLE USED IN STATION TABLE CHECK AND TO
C RECTANGULARIZE; FOR ADDED EFFICIENCY (INTERNAL).
C IMISS = COUNTER FOR HOW MANY BOGUS RECORDS NEED TO BE
C WRITTEN TO THE OUTPUT FILE(S) WHEN A SEQUENTIAL
C FILE (WITH BAD VARIABLE ID LISTS) IS THE
C INPUT FILE. (INTERNAL).
C IMISS_SEQ_POST(N) = ARRAY OF POSITIONS FOR ARRAYS ISCALD AND
C PLAIN EMINATING FROM INT140, FOR MISSING
C VARIABLE IDS FROM SEQUENTIAL FILE INPUT.
C INUM = THE NUMBER OF STATIONS FROM THE INPUT FILES
C (INTERNAL).
C INV = FLAG FOR WHEN THE DATE CHANGES FOR INPUT DATA
C (INTERNAL).
C ISEQ_POST = THE COUNTER FOR THE INPUT VARIABLE LIST WHEN A
C AN INPUT SEQUENTIAL FILE IS USED. (INTERNAL).
C I_PACK(N) = ARRAY OF REARRANGED POSITIONS FOR THE OUTPUT
C DATA; NECESSARY FOR U155 INPUT. (N=1,ND5)
C (INTERNAL)
C IVAREAD = VARIABLE TO KEEP TRACK OF NUMBER OF VARIABLES
C READ IN A RANDON ACCESS FILE ONLY, WHEN IT
C EXCEEDS NVRBL, EXIT THE 700 DO LOOP VIA
C GO TO 750. (INTERNAL)
C IVAR_CNT = VARIABLE COUNTER (NUMBER OF VARIABLES COUNTED)
C SEQUENTIAL FILE ONLY (INTERNAL).
C JFCLOS = CLOSE STATEMENT FOR MULTIPLE INPUT FILES
C NDATE = DATE OF CURRENT READ VARIABLE RECORD. (INTERNAL).
C N_FIND = THE NUMBER OF INPUTS STATION FOUND IN THE STATION
C TABLE (SHOULD EQUAL INUM) (INTERNAL).
C NID(J)= THE INTEGER DEFAULT ID (J=1,4)
C ID_NOP(J,N) = THE IDS NOT FOUND OR PROCESSED FROM A SEQUENTIAL
C INPUT FILE(S). (J=1,4),(N=1,ND4)
C N_ALAT = ALAT*10000. (INTERNAL)
C N_ALON = ALON*10000. (INTERNAL)
C N_STALAT = STALAT(IX)*10000. (INTERNAL)
C N_STALON = STALON(IX)*10000. (INTERNAL)
C PROCEED_DATE = LOGICAL TO DECLARE A MATCHING DATE WITH THE
C INPUT FILE. (INTERNAL)
C PROCEED_ID = LOGICAL TO DECLARE A MATCHING VARIABLE WITH THE
C INPUT FILE. (INTERNAL)
C STATE = VARIABLE SET TO STATEMENT NUMBER TO INDICATE
C WHERE AN ERROR OCCURRED. (CHARACTER*4)
C WRTE_BOG = LOGICAL TO DECLARE A THAT A RECORD WITH MISSING
C WILL BE WRITTEN TO THE OUTPUT FILE(S), WHEN THE
C REQUESTED VARIABLE LIST CAN'T MATCH A VARIABLE
C IN THE INPUT FILE. (INTERNAL)
C NOTE: IF WORD #1 IS PARTICURLY BAD, THE PROGRAM
C WILL STOP IN INT140.
C
C SUBPROGRAMS CALLED: INT140, RDTDLM, UNPACK, PAWRAG, PWOTGM,
C PSIJLL, LMIJLL, CFILM, IERX, W3TAGE
C UNIQUE: - INT140
C LIBRARY:
C MOSLIB - RDTDLM, UNPACK, PAWRAG, PWOTGM, PSIJLL, LMIJLL,
C CFILM, IERX
C W3LIB - W3TAGE
C
C NONSYSTEM SUBROUTINES USED
C EXIT STATES:
C COND = 0 - SUCCESSFUL RUN
C 20 - ERRORS FROM INT140
C 198 - TOO MANY RANDOM ACCESS FILES
C 225 - STATIONS NOT FOUND IN STATION TABLE LIST
C 295 - DATE ON INPUT FILE DOES NOT MATCH REQUESTED
C DATE
C 569 - ERROR IN PACKING ROUTINE
C 589 - ERROR WRITING RANDOM ACCESS FILE
C 602 - ERROR READING PACKED RECORDS
C 9999 - ERROR WITH CONTROL INFORMATION INPUT
C OTHER VALUES RETURNED FROM SUBROUTINES.
C
C REMARKS: NONE
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 90 (xlf90 compiler)
C MACHINE: IBM SP
C
C$$$
C
IMPLICIT NONE
C
CHARACTER*4 STATE,IPINIT
CHARACTER*8 RCCALLD(ND1),CCALLS(ND1)
CHARACTER*8 CALLML(ND1,6)
CHARACTER*20 NAME(ND1)
CHARACTER*32 PLAIN2
CHARACTER*32 PLAIN(ND4),PLAIN_ADJ(ND4)
CHARACTER*60 NAMIN(ND6),CFILX,RACESS
CINTEL
CHARACTER*20 CONVERTX
INTEGER :: ISYSEND,IFILEND
CINTEL
CCCC*
CCCC* GIS RELATED
CCCC*
CHARACTER*400 HEAD/' '/
CHARACTER*11 CHVAR1,CHVAR2,CHVAR3,CHVAR4,CHVAR5,CHVAR6,
1 CHVAR7,CHVAR8,CHVAR9,CHVAR10,CHVAR11,CHVAR12,
2 CHVAR13,CHVAR14,CHVAR15,CHVAR16
CCCC*
CCCC*
CCCC*
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
INTEGER :: KFILDI,KFILDO,KFILIN
INTEGER :: ND1,ND2,ND3,ND2X3,ND4,ND5,ND6,ND7,ND8
INTEGER :: ISCALD,IPLAIN,L3264B,L3264W
INTEGER :: IPACK,IWORK
INTEGER :: JFOPEN,MODNUM
INTEGER :: IS0,IS1,IS2,IS4
INTEGER :: IDATE,NWORK
C
C ADDITIONAL INTEGER VARIABLES (INT140.F)
C
INTEGER :: KFILDT,KFILRA,KFILGIS,KFILGO,KFILX,KFILD
INTEGER :: IP,IUSE,NDATES,IDPARS,ID
INTEGER :: IOUTD,IOUTG,IOUTJ,NUMIN
INTEGER :: NUMRA,INCCYL,NPROJ,NX,NY
INTEGER :: ICHARS,MISSV,LNGTH,NVRBL
INTEGER :: ID_ADJ,ISCALD_ADJ,NVRBL_ADJ
INTEGER :: NELEV,ISTA,ISTOP
C
INTEGER :: IX
INTEGER :: NVALUE,ID_START
C
C PAWRAG AND PWOTGM AND PACKGR_OPER
INTEGER :: IOCTET,LX,NCHAR,IA,IC,ISCALE,MINPK,MAX_NSTA
INTEGER :: ITAUH,ITAUM,MODNO,NSEQ,IOCTTG,NTOTBG,NTOTRG
INTEGER :: NGRIDC,NTOTGB,NTOTGR,NIDPARS
INTEGER :: NHR,NDA,NYR,NMO,NWORDS
C
C ADDITIONAL INTERNAL INTEGER VARIABLES
C
INTEGER :: KDATE,IFIRST,IHOLD,JFCLOS
INTEGER :: IMISS,ISEQ_POST,ID_IMISS,IMISS_SEQ_POST
INTEGER :: INUM,INUM_TOT,I_PACK
INTEGER :: IVAR_CNT,IVAREAD,INV
INTEGER :: NDATE,NID,ID_NOP,N_FIND
INTEGER :: N_ALAT,N_ALON,N_STALAT,N_STALON
INTEGER LNDATE,IOSTAT,IOS
INTEGER I,II,J,IJ,K,IK,KK,M,N,IN
INTEGER NC,NCA,NCB,ND7A
INTEGER NBYTES
INTEGER NREC,IER,IERG,MISSPX,MISSSX
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
REAL :: DATA,SDATA,TMP_DATA,GIS_DATA
REAL :: XMISSP,XMISSS
REAL :: FD1
C
C ADDITIONAL REAL VARIABLES
C
REAL :: XLATLL,YLONLL,XMESHL,ORIENT,XLAT
REAL :: STALAT,STALON
REAL :: ALAT,ALON,XI,YJ,AVG
REAL*8 SUM_TOT
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
DIMENSION KFILIN(ND6)
DIMENSION ISCALD(ND4),IPLAIN(L3264W,4)
DIMENSION IPACK(ND5),IWORK(ND5),FD1(ND5)
DIMENSION DATA(ND5),SDATA(ND5),TMP_DATA(ND5),GIS_DATA(ND5,ND7)
DIMENSION JFOPEN(ND6),MODNUM(ND6)
DIMENSION IS0(ND7),IS1(ND7),IS2(ND7),IS4(ND7)
DIMENSION IDATE(ND8),NWORK(ND8)
DIMENSION I_PACK(ND5),ID_IMISS(4,ND4),IMISS_SEQ_POST(ND4)
C
C ADDITIONAL VARIABLES
C
DIMENSION KFILD(2)
DIMENSION IP(25),IUSE(25)
DIMENSION IDPARS(15,ND4),ID(4,ND4)
DIMENSION ID_ADJ(4,ND4),ISCALD_ADJ(ND4)
DIMENSION NELEV(ND1),STALAT(ND1),STALON(ND1)
DIMENSION ISTOP(2)
C
DIMENSION ID_START(4)
DIMENSION XI(5),YJ(5),IX(5)
C
DIMENSION IA(ND5),IC(ND5)
DIMENSION NGRIDC(6),NIDPARS(15)
DIMENSION NBYTES(2)
DIMENSION NID(4),ID_NOP(4,ND4)
C
LOGICAL PROCEED_DATE,PROCEED_ID,FOUND_MATCH,WRTE_BOG
C
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C STEP 1. INITIALIZE VARIABLES AND READ IN THE .CN
C FILE COMPONENTS.
C
DATA ISTOP/0,0/
DATA IP/25*0/
DATA KFILGO/0/,KFILX/0/,KFILGIS/0/
DATA ID_START/400001000,0,0,0/
C
DATA IUSE/1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,1,1,1,0,0,0,0,1,0,0/
C
DATA XMISSP/9999./,XMISSS/9997./
DATA NUMRA/0/,NUMIN/0/
DATA NCHAR/32/,ITAUH/0/,ITAUM/0/,MODNO/0/,NSEQ/0/
DATA MINPK/14/
DATA NTOTGB/0/,NTOTGR/0/
CINTEL
CONVERTX='BIG_ENDIAN'
CINTEL
C INITIALIZE ARRAYS
DO 10 I = 1, ND1
NELEV(I) = 0
STALAT(I) = 0.
STALON(I) = 0.
10 CONTINUE
C
C
C
CALL INT140(KFILDI,KFILDO,KFILDT,KFILIN,KFILRA,
1 KFILGIS,KFILGO,KFILX,KFILD,
2 RACESS,IP,IUSE,IDATE,NDATES,PLAIN,
3 ND1,ND4,ND6,ND8,L3264B,L3264W,
4 IDPARS,ID,IOUTD,IOUTG,IOUTJ,CFILX,
5 NAMIN,MODNUM,JFOPEN,NUMIN,NUMRA,INCCYL,ISCALD,
6 NPROJ,NX,NY,XLATLL,YLONLL,XMESHL,ORIENT,XLAT,
7 MISSV,ICHARS,LNGTH,NVRBL,
8 PLAIN_ADJ,ID_ADJ,ISCALD_ADJ,NVRBL_ADJ,
8 CALLML,RCCALLD,NAME,NELEV,STALAT,STALON,
9 ISTA,IPINIT,ISTOP,IER)
C
IF (ISTOP(1) .GT. 0) THEN
WRITE(KFILDO,20) ISTOP, IER
20 FORMAT(/'****ERRORS HAVE OCCURRED IN INT140: ISTOP = ',I2,
1 ' AND IER = ',I4,/,
2 ' IT IS PRUDENT TO STOP HERE IN U140 AT 20.')
CALL W3TAGE('U140')
STOP 20
ENDIF
C
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C
C STEP 2. SELECT BY DATE AND VARIABLE ID
C IF((PROCEED_DATE).AND.(PROCEED_ID))THEN
C FOR EACH INPUT FILE (IN=1,NUMIN)
C
C
NDATE=IDATE(1)
JFCLOS=0
IVAREAD=0
INV=0
C
DO 700 IN=1,NUMIN
IVAR_CNT=0
IFIRST=0
IMISS=0
IF(IN.EQ.1)THEN
LNDATE=0
ELSE
LNDATE=NDATE
ENDIF
C
190 IF(IFIRST.EQ.0)THEN
C
C SEQUENTIAL
IF(NUMRA.EQ.0)THEN
IF(JFCLOS.EQ.1)THEN
CINTEL
CALL CKFILEND(KFILDO,KFILIN(IN),NAMIN(IN),ISYSEND,
1 IFILEND,CONVERTX,IER)
OPEN(UNIT=KFILIN(IN),FILE=NAMIN(IN),FORM='UNFORMATTED',
1 CONVERT=CONVERTX,STATUS='OLD',IOSTAT=IOS)
C OPEN(UNIT=KFILIN(IN),FILE=NAMIN(IN),FORM='UNFORMATTED',
C 1 STATUS='OLD',IOSTAT=IOS)
CINTEL
ENDIF
READ(KFILIN(IN),IOSTAT=IOS,ERR=601,END=665)
1 (NBYTES(J),J=1,L3264W),
2 (CCALLS(J),J=1,NBYTES(L3264W)/8)
C
CCC WRITE(KFILDO,191) NBYTES(L3264W)/8
C191 FORMAT('NBYTES(L3264W)/8=',I10,/)
C
INUM = NBYTES(L3264W)/8
C
C RANDOM ACCESS
ELSEIF(NUMRA.EQ.1)THEN
CINTEL
C CALL RDTDLM(KFILDO,KFILRA,RACESS,ID_START,CCALLS,ND1,
C 1 NVALUE,L3264B,IER)
CALL RDTDLMC(KFILDO,KFILRA,RACESS,ID_START,CCALLS,ND1,
1 NVALUE,L3264B,IER)
CINTEL
IF(IER.NE.0)THEN
IER=3
STATE='195 '
GO TO 900
ENDIF
INUM = NVALUE/L3264W
C
C TOO MANY RANDOM ACCESS
ELSEIF(NUMRA.GT.1)THEN
WRITE(KFILDO,198)NUMRA
198 FORMAT(/' ****TOO MANY INPUT RANDOM ACCESS: NUMRA=',I4,/,
1 ' STOP IN U140 AT 198')
STOP 198
ENDIF
C
C******************************************************************C
C******************************************************************C
C STEP 3. TEST THE STATION LIST OF THE INPUT FILE WITH THE
C STATION TABLE AND GRID SPECS FOR COMPATIBILITY
C
C TEST #1 COMPARE THE INPUT (FILE) LIST OF STATIONS WITH
C THE STATION TABLE LIST. IF THERE IS A STATION FROM THE
C INPUT FILE WHICH IS NOT IN THE STATION TABLE, THE
C PROGRAM WILL STOP. THE INPUT FILE LIST OF STATIONS
C SHOULD EITHER EXACTLY MATCH OR BE A SUBSET OF THE
C THE STATION TABLE LIST.
C
C THE OUTPUT FILE WILL CONTAIN VALUES FOR ALL GRID
C LOCATIONS AS SPECIFIED IN THE GRID SPECS. THIS
C GRID SPECIFICATION STATION LIST AND THE STATION
C TABLE LIST SHOULD BE THE SAME.
C
N_FIND=0
C
WRITE(KFILDO,200)INUM,ISTA
200 FORMAT(//,'INUM,ISTA=',2I10,//)
C
C NOTE: NO DUPLICATES ARE ASSUMED
C
IHOLD=1
DO 220 I = 1,INUM
DO 210 J=IHOLD,ISTA
IF(CCALLS(I).EQ.CALLML(J,1)) THEN
IHOLD=J+1
N_FIND=N_FIND+1
GO TO 220
ENDIF
210 CONTINUE
220 CONTINUE
C
IF(N_FIND.NE.INUM)THEN
WRITE(KFILDO,225) N_FIND
225 FORMAT(/'****ERROR:',4X,I8,' INPUT LIST STATIONS ',
1 'NOT FOUND IN THE STATION TABLE LIST',/,
3 'THE PROGRAM TERMINATES.',
4 ' IT IS PRUDENT TO STOP HERE IN U140 AT 225.')
STOP 225
ELSE
WRITE(KFILDO,226) N_FIND,INUM
226 FORMAT(/'ALL INPUT FILE STATIONS MATCH: N_FIND=',I10,
1 1X,'TOTAL LIST OF STATIONS = ',I10)
ENDIF
C
C TEST #2 GRID POINT NUMBER CHECKS: CHECK TO MAKE SURE
C NX AND NY ARE NOT GREATER THAN ND2 AND ND3, AND CHECK
C TO MAKE SURE THE TOTAL NUMBER OF GRID POINTS (MAX_NSTA)
C IS LESS THAN ND2X3.
C
IF((NX.GT.ND2).OR.(NY.GT.ND3))THEN
WRITE(KFILDO,230) NX,NY,ND2,ND3
230 FORMAT(/,' ****ERROR: NUMX OR NUMY IS GREATER',
1 ' THEN ND2 OR ND3',/,
2 'NX,NY,ND2,ND3=',4(1X,I5))
STATE='230 '
GO TO 900
ENDIF
C
C COMPUTE NUMBER OF GRID POINTS
C
MAX_NSTA=NX*NY
IF(MAX_NSTA.GT.ND2X3)THEN
WRITE(KFILDO,FMT='(/,'' ****NUMBER OF GRID POINTS IS'',
1 '' GREATER THAN THE ALLOTED AMOUNT'')')
WRITE(KFILDO,FMT='(/,'' ****ND2X3 IS '',I8,''AND MAX_NSTA'',
1 '' WAS CALCULATED AS '',I8)')ND2X3,MAX_NSTA
STATE='240 '
GO TO 900
ENDIF
C
C TEST #3 COMPARE THE STATION TABLE FILE LAT/LONS WITH
C THE LAT/LONS DERIVED FROM THE INPUT GRID SPECS. TO SAVE
C COMPUTER TIME ONLY THE FOUR CORNER GRID POINTS ARE
C COMPARED. TO DETERMINE THAT THE MESH LENGTH IS CORRECT,
C THE LAT/LONS WILL BE COMPARED TO GRIDPOINTS ADJACENT
C TO THE LOWER LEFT CORNER GRID POINT.
C NOTE: LIKE TEST#1 THIS TEST IS DONE ONLY ONCE
C WHEN IFIRST = 1
C
C SET UP THE LAT/LON CORNER GRID POINTS AND ONE ADJACENT POINT
C
XI(1)=1.
YJ(1)=1.
DO 250 IJ=1,5
IF(IJ.EQ.2)THEN
XI(2)=1.
YJ(2)=REAL(NY)
ELSEIF(IJ.EQ.3)THEN
XI(3)=REAL(NX)
YJ(3)=REAL(NY)
ELSEIF(IJ.EQ.4)THEN
XI(4)=REAL(NX)
YJ(4)=1.
ELSEIF(IJ.EQ.5) THEN
XI(5)=1.
YJ(5)=2.
ENDIF
IX(IJ)=NINT(XI(IJ)*YJ(IJ))
IX(4)=((NX*NY)-(NY-1))
250 CONTINUE
C
C
DO 260 IJ=1,5
II=IX(IJ)
C
C*****************************
C LAMBERT CONFORMAL *
C*****************************
IF(NPROJ.EQ.3) THEN
CCC IF(IJ.EQ.1) THEN
CCC WRITE(KFILDO,FMT='(/,''PROJ: LAMBERT CONFORMAL'')')
CCC WRITE(6,FMT='(/,''PROJ: LAMBERT CONFORMAL'')')
CCC ENDIF
C
CALL LMIJLL(KFILDO,XI(IJ),YJ(IJ),XMESHL,ORIENT,XLAT,
1 XLATLL,YLONLL,ALAT,ALON,IER)
IF(IER.NE.0)THEN
WRITE(KFILDO,FMT='(/,''****ERROR PROCESSING LMIJLL'')')
GO TO 900
ENDIF
C
C*****************************
C POLAR STEREOGRAPHIC *
C*****************************
ELSEIF(NPROJ.EQ.5) THEN
CCC IF(IJ.EQ.1) THEN
CCC WRITE(KFILDO,FMT='(/,''PROJ: POLAR STEREOGRAPHIC'')')
CCC WRITE(6,FMT='(/,''PROJ: POLAR STEREOGRAPHIC'')')
CCC ENDIF
CALL PSIJLL(KFILDO,XI(IJ),YJ(IJ),XMESHL,ORIENT,XLAT,
1 XLATLL,YLONLL,ALAT,ALON,IER)
IF(IER.NE.0)THEN
WRITE(KFILDO,FMT='(/,''****ERROR PROCESSING PSIJLL'')')
GO TO 900
ENDIF
C
C*****************************
C MERCATOR *
C*****************************
ELSEIF(NPROJ.EQ.7) THEN
CCC IF(IJ.EQ.1) THEN
CCC WRITE(KFILDO,FMT='(/,''PROJ: MERCATOR'')')
CCC WRITE(6,FMT='(/,''PROJ: MERCATOR'')')
CCC ENDIF
CALL MCIJLL(KFILDO,XI(IJ),YJ(IJ),XMESHL,XLAT,
1 XLATLL,YLONLL,ALAT,ALON,IER)
IF(IER.NE.0)THEN
WRITE(KFILDO,FMT='(/,''****ERROR PROCESSING MCIJLL'')')
GO TO 900
ENDIF
ENDIF
C
N_ALAT=NINT(ALAT*10000.)
CCCCC IF(NPROJ.EQ.5) ALON=-ALON
N_ALON=NINT(ALON*10000.)
N_STALAT=NINT(STALAT(II)*10000.)
N_STALON=NINT(STALON(II)*10000.)
C
IF(IJ.LE.4)THEN
IF(ABS(N_ALAT-N_STALAT).GT.5.OR.
1 ABS(N_ALON-N_STALON).GT.5)THEN
WRITE(KFILDO,252)IJ,NINT(XI(IJ)),NINT(YJ(IJ)),
1 ALAT,ALON,STALAT(II),STALON(II)
252 FORMAT(/' ****ERROR: THE GRID CHARACTERISTICS OF THE',
1 ' STATION TABLE DIFFER FROM THE INPUT GRID',
2 ' SPECIFICATIONS; CORNER POINT TESTED'/,
3 ' I J ALAT ALON STALAT STALON'/,
4 I2,1X,I4,1X,I4,1X,4(1X,F10.5))
GO TO 900
ELSE
WRITE(KFILDO,254)IJ,NINT(XI(IJ)),NINT(YJ(IJ)),
1 ALAT,ALON,STALAT(II),STALON(II)
254 FORMAT(/' ****THE GRID CHARACTERISTICS OF THE',
1 ' STATION TABLE MATCH THE INPUT GRID',
2 ' SPECIFICATIONS; CORNER POINT TESTED'/,
3 ' I J ALAT ALON STALAT STALON'/,
4 I2,1X,I4,1X,I4,1X,4(1X,F10.5))
ENDIF
ELSE
IF(ABS(N_ALAT-N_STALAT).GT.5.OR.
1 ABS(N_ALON-N_STALON).GT.5)THEN
WRITE(KFILDO,2252)IJ,NINT(XI(IJ)),NINT(YJ(IJ)),
1 ALAT,ALON,STALAT(II),STALON(II)
2252 FORMAT(/' ****ERROR: THE GRID CHARACTERISTICS OF THE',
1 ' STATION TABLE DIFFER FROM THE INPUT GRID',
2 ' SPECIFICATIONS; MESH LENGTH TESTED'/,
3 ' I J ALAT ALON STALAT STALON'/,
4 I2,1X,I4,1X,I4,1X,4(1X,F10.5))
GO TO 900
ELSE
WRITE(KFILDO,2254)IJ,NINT(XI(IJ)),NINT(YJ(IJ)),
1 ALAT,ALON,STALAT(II),STALON(II)
2254 FORMAT(/' ****THE GRID CHARACTERISTICS OF THE',
1 ' STATION TABLE MATCH THE INPUT GRID',
2 ' SPECIFICATIONS; MESH LENGTH TESTED'/,
3 ' I J ALAT ALON STALAT STALON'/,
4 I2,1X,I4,1X,I4,1X,4(1X,F10.5))
ENDIF
ENDIF
260 CONTINUE
C
C
C STEP 4. WHILE STILL IN IFIRST = 1, GENERATE AN ARRAY
C OF STORAGE ELEMENTS FOR PACKING PURPOSES:
C STORAGE ELEMENTS START AT THE LOWER LEFT
C CORNER AND PROCEED LEFT TO RIGHT PER
C ROW UNTIL THE UPPER RIGHT CORNER POINT
C IS REACHED: THIS STEP IS DONE ONLY ONCE
C FOR EFFICIENCY
IF(IN.EQ.1)THEN
NC=0
NCA=0
NCB=0
II=1
DO 265 I=1,ISTA
NC=NC+1
NCA=NC-1
NCB=MOD(NCA,NY)
IF((NCB.EQ.0).AND.(I.GE.NY))THEN
II=II+1
NC=1
ENDIF
I_PACK(I)=II+(NCB*NX)
265 CONTINUE
ENDIF
C
C
CC************************************************
C BEYOND THE DIRECTORY RECORD
C
C STEP 5. READ AND SORT OUT THE REQUESTED
C VARIABLES BY DATE(S) AND VARIABLE IDS
C FOR EITHER RANDOM ACCESS OR SEQUENTIAL
C FILE INPUT. (IFIRST > 2)
C
C AT THIS POINT IFIRST SET TO 2 REGARDLESS OF
C SEQUENTIAL OR RANDOM ACCESS INPUT
C
IFIRST=IFIRST+1
GO TO 190
C
C [ELSE IFIRST NE 0]
C
ELSE
C
WRTE_BOG=.FALSE.
C
C CHOICE #1 SEQUENTIAL INPUT RECORD
C
IF(NUMRA.EQ.0)THEN
KDATE=NDATE
IF(IVAR_CNT.EQ.NVRBL) GO TO 670
READ(KFILIN(IN),IOSTAT=IOS,ERR=601,END=665)
1 (NBYTES(J),J=1,L3264W),
2 (IPACK(J),J=1,NBYTES(L3264W)*8/L3264B)
C
C CALCULATE ISEQ_POST
ISEQ_POST=0
IF(IPACK(5).NE.9999)THEN
DO 267 I=1,NVRBL
IF((IPACK(6).EQ.ID(1,I)).AND.
1 (IPACK(7).EQ.ID(2,I)).AND.
2 (IPACK(8).EQ.ID(3,I)).AND.
3 (IPACK(9).EQ.ID(4,I)))THEN
ISEQ_POST=I
ENDIF
267 CONTINUE
ELSE
NDATE=IPACK(5)
WRTE_BOG=.TRUE.
GO TO 280
ENDIF
C
IFIRST=IFIRST+1
C
C CHOICE #2 RANDOM ACCESS INPUT RECORD
C NOTE: ASSUME ONLY ONE DATE IN RANDOM-ACCESS FILE
C
ELSEIF(NUMRA.EQ.1)THEN
IVAREAD=IVAREAD+1
C WRITE(KFILDO,269)IVAREAD,NVRBL
C269 FORMAT('IVAREAD,NVRBL=',2I10)
C
IF(IVAREAD.GT.NVRBL) THEN
DO 275 I=1,NVRBL
IF(ID(1,I).EQ.ID_NOP(1,I))THEN
WRITE(KFILDO,271) (ID_NOP(K,I),K=1,4)
271 FORMAT(/,'**** WARNING: ',4I10,' SUMMARY',
1 ' VARIABLES NOT READ FROM INPUT RANDOM',
2 ' ACCESS FILE')
ENDIF
275 CONTINUE
C
C GET OUT OF D0 700 GET OUT OF D0 700 GET OUT OF D0 700
C GET OUT OF D0 700 GET OUT OF D0 700 GET OUT OF D0 700
GO TO 750
ENDIF
C
CALL RDTDLM(KFILDO,KFILRA,RACESS,ID(1,IFIRST),IPACK,ND5,
1 NVALUE,L3264B,IER)
IFIRST=IFIRST+1
C
C VARIABLE NOT FOUND IN INPUT RANDOM ACCESS FILE
C THEREFORE WILL NEED TO WRITE BOGUS RECORD OF 9999'S
IF(IER.EQ.155)THEN
WRTE_BOG=.TRUE.
NID(1)=ID(1,IVAREAD)
NID(2)=ID(2,IVAREAD)
NID(3)=ID(3,IVAREAD)
NID(4)=ID(4,IVAREAD)
GO TO 280
ENDIF
C
IF((IER.NE.0).AND.(IER.NE.155))THEN
STATE='270 '
GO TO 900
ENDIF
ENDIF
C
ENDIF
C
C
C STEP 5A. SORT OUT THE REQUESTED RECORDS
C BY DATE(S) AND VARIABLE IDS
C
C
NDATE=IPACK(5)
NID(1)=IPACK(6)
NID(2)=IPACK(7)
NID(3)=IPACK(8)
NID(4)=IPACK(9)
C
PROCEED_DATE=.FALSE.
PROCEED_ID=.FALSE.
C
280 IF((NDATE.NE.9999).AND.(.NOT.WRTE_BOG))THEN
DO 300 IJ=1,NDATES
IF(NDATE.EQ.IDATE(IJ))THEN
IF(INV.NE.IJ)THEN
ccc write(kfildo,9997) inv,ij,idate(ij)
ccc 9997 format('INSIDE INV.NE.IJ LOOP INV IJ=',2I5,I10)
IVAR_CNT=0
DO 285 I=1,NVRBL
ID_NOP(1,I)=ID(1,I)
ID_NOP(2,I)=ID(2,I)
ID_NOP(3,I)=ID(3,I)
ID_NOP(4,I)=ID(4,I)
285 CONTINUE
ENDIF
PROCEED_DATE=.TRUE.
INV=IJ
DO 290 IK=1,NVRBL
IF((NID(1) .EQ. ID(1,IK)).AND.
1 (NID(2) .EQ. ID(2,IK)).AND.
2 (NID(3) .EQ. ID(3,IK)).AND.
3 (NID(4) .EQ. ID(4,IK)))THEN
PROCEED_ID=.TRUE.
ID_NOP(1,IK)=0
ID_NOP(2,IK)=0
ID_NOP(3,IK)=0
ID_NOP(4,IK)=0
ENDIF
290 CONTINUE
ENDIF
300 CONTINUE
IF(.NOT.PROCEED_DATE)THEN
WRITE(KFILDO,305) NDATE
305 FORMAT(/,'**** ERROR: INPUT FILE DATE DOES ',
1 'NOT MATCH REQUESTED DATE: FILE DATE=',I10,/,
2 'IT IS PRUDENT TO STOP HERE IN ',
3 'U140 AT 305')
STOP 295
ENDIF
C
C 1. INDICATES A TIME CHANGE (SEQUENTIAL TEST ONLY)
C
cc IF((NUMRA.EQ.0).AND.(INV.GT.1.AND.IVAR_CNT.EQ.0))THEN
cc IMISS=0
cc DO 310 I=1,NVRBL
cc IF(ID(1,I).EQ.ID_NOP(1,I))THEN
cc IMISS=IMISS+1
cc IMISS_SEQ_POST(IMISS)=I
cc WRTE_BOG=.TRUE.
cc WRITE(KFILDO,307) (ID_NOP(K,I),K=1,4)
cc 307 FORMAT(/,'**** WARNING: ',4I10,' VARIABLE NOT',
cc 1 ' READ FROM SEQUENTIAL INPUT FILE [END DATE]')
cc ID_IMISS(1,IMISS)=ID(1,I)
cc ID_IMISS(2,IMISS)=ID(2,I)
cc ID_IMISS(3,IMISS)=ID(3,I)
cc ID_IMISS(4,IMISS)=ID(4,I)
cc ENDIF
cc 310 CONTINUE
cc ENDIF
C
ELSEIF(NDATE.EQ.9999)THEN
C
C 2. INDICATES THE END OF AN INPUT FILE (SEQUENTIAL TEST ONLY)
C
IF(NUMRA.EQ.0)THEN
IMISS=0
DO 315 I=1,NVRBL
IF(ID(1,I).EQ.ID_NOP(1,I))THEN
IMISS=IMISS+1
IMISS_SEQ_POST(IMISS)=I
WRTE_BOG=.TRUE.
WRITE(KFILDO,312) (ID_NOP(K,I),K=1,4)
312 FORMAT(/,'**** WARNING: ',4I10,' VARIABLE NOT',
1 ' READ FROM SEQUENTIAL INPUT FILE [END FILE]')
ID_IMISS(1,IMISS)=ID(1,I)
ID_IMISS(2,IMISS)=ID(2,I)
ID_IMISS(3,IMISS)=ID(3,I)
ID_IMISS(4,IMISS)=ID(4,I)
ENDIF
315 CONTINUE
ENDIF
ENDIF
C
C 3. INDICATES AN INCORRECT VARIABLE ID (RANDOM ACCESS TEST ONLY)
C
IF((NUMRA.EQ.1).AND.(WRTE_BOG))THEN
WRITE(KFILDO,317) (ID(K,IVAREAD),K=1,4)
317 FORMAT(/,'**** WARNING: ',4I10,' VARIABLE NOT',
1 ' READ FROM RANDOM ACCESS INPUT FILE')
ENDIF
C
C
C ****** *** **** ****** *** ****
C SECOND BIG LOOP SECOND BIG LOOP
C ****** *** **** ****** *** ****
C
C
IF(((PROCEED_DATE).AND.(PROCEED_ID)).OR.(WRTE_BOG))THEN
ISCALE=9999
IVAR_CNT=IVAR_CNT+1
C
IF(.NOT.WRTE_BOG)THEN
CALL UNPACK(KFILDO,IPACK,IWORK,DATA,ND5,IS0,IS1,
1 IS2,IS4,ND7,MISSPX,MISSSX,2,L3264B,IER)
C
IF(MISSV.EQ.1)THEN
SUM_TOT=0.D0
INUM_TOT=INUM
DO 325 I=1,INUM
IF(NINT(DATA(I)).NE.9999)THEN
SUM_TOT=SUM_TOT+DATA(I)
ELSE
INUM_TOT=INUM_TOT-1
ENDIF
325 CONTINUE
IF(INUM_TOT.EQ.0)THEN
WRITE(KFILDO,330)
330 FORMAT(/,'**** WARNING: MISSING VALUE CAN NOT',
1 ' BE THE AVERAGE: ALL VALUES ARE MISSING',/)
AVG=9999.
ELSE
AVG=(SUM_TOT/DBLE(INUM_TOT))
ccc write(kfildo,339)SUM_TOT,AVG,INUM_TOT
ccc 339 format(//'SUM_TOT,AVG,INUM_TOT =',2F16.4,I10//)
ENDIF
ELSEIF(MISSV.EQ.0)THEN
AVG=9999.
ENDIF
C
DO 340 I=1,ND5
TMP_DATA(I) = AVG
340 CONTINUE
C
CCCCCCCCCC RECTANGULAR GRID CCCCCCCCCCCC
C
C
C STEP 6. FILL UP THE FULL GRID WITH VALUES (FILL AND
C ACTUAL VALUES) IF THE INPUT FILE IS INCOMPLETE:
CC
CC NOTE:
CC THE INPUT AND STATION TABLE FILES ARE ASSUMED
CC TO BE IN ALPHABETICAL ORDER
CC
C INUM=# OF STATION IDS FOR INPUT FILES
C ISTA=# OF STATION IDS FOR STATION TABLE
C
C
IF((INUM.NE.ISTA).AND.(N_FIND.EQ.INUM))THEN
IHOLD=1
DO 400 J=1,INUM
DO 390 I=IHOLD,ISTA
IF(CCALLS(J) .EQ. CALLML(I,1)) THEN
TMP_DATA(I)=DATA(J)
IHOLD=I+1
GO TO 400
ENDIF
390 CONTINUE
400 CONTINUE
ELSEIF((INUM.EQ.ISTA).AND.(N_FIND.EQ.INUM))THEN
DO 410 J=1,INUM
TMP_DATA(J)=DATA(J)
ccc DO 405 I=1,ISTA
ccc TMP_DATA(I)=DATA(J)
ccc 405 CONTINUE
410 CONTINUE
ENDIF
C
ENDIF
C
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C GIS PROCESSING NOT FINALIZED
C GIS PROCESSING NOT FINALIZED
C GIS PROCESSING NOT FINALIZED
C GIS PROCESSING NOT FINALIZED
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C STEP ??. FIRST FILL UP THE ARRAY GIS_DATA(ND5,ND7)
C [FOR FIRST DATE ONLY]
C FOR ALL SELECTED VARIABLES.
C
C
C STEP ??. WRITE OUT ARRAY GIS_DATA TO OUTPUT FILE
C WHEN ALL VARIABLES HAVE BEEN READ INTO
C GIS_DATA
C
IF(NDATE.EQ.IDATE(1))THEN
IF(IOUTD.NE.0)THEN
ND7A=ND7-2
DO 480 I=1,ISTA
IF(IVAR_CNT.EQ.1)THEN
GIS_DATA(I,1)=STALAT(I)
GIS_DATA(I,2)=-1.0*STALON(I)
GIS_DATA(I,IVAR_CNT+2)=TMP_DATA(I)
ELSEIF((IVAR_CNT.GT.1).AND.(IVAR_CNT.LE.ND7A))THEN
GIS_DATA(I,IVAR_CNT+2)=TMP_DATA(I)
ENDIF
480 CONTINUE
IF(IVAR_CNT.EQ.NVRBL)THEN
HEAD(1:12)='Station_ID, '
HEAD(13:19)='Link1, '
HEAD(20:29)='Latitude, '
HEAD(30:40)='Longitude,'
CHVAR1(1:11)=' Var_01, '
CHVAR2(1:11)=' Var_02, '
CHVAR3(1:11)=' Var_03, '
CHVAR4(1:11)=' Var_04, '
CHVAR5(1:11)=' Var_05, '
CHVAR6(1:11)=' Var_06, '
CHVAR7(1:11)=' Var_07, '
CHVAR8(1:11)=' Var_08, '
CHVAR9(1:11)=' Var_09, '
CHVAR10(1:11)=' Var_10, '
CHVAR11(1:11)=' Var_11, '
CHVAR12(1:11)=' Var_12, '
CHVAR13(1:11)=' Var_13, '
CHVAR14(1:11)=' Var_14, '
CHVAR15(1:11)=' Var_15, '
CHVAR16(1:11)=' Var_16 '
C WRITE MORE INTO HEAD
WRITE(HEAD(42:400),'(16(A11))')CHVAR1,
1 CHVAR2,CHVAR3,CHVAR4,CHVAR5,CHVAR6,CHVAR7,CHVAR8,
2 CHVAR9,CHVAR10,CHVAR11,CHVAR12,CHVAR13,CHVAR14,CHVAR15,
3 CHVAR16
C
WRITE(KFILGIS,485) HEAD
485 FORMAT(A218)
C
IJ=0
DO 500 I=1,NX
DO 490 J=1,NY
IJ=IJ+1
WRITE(KFILGIS,451) CALLML(IJ,1),CALLML(IJ,1),
2 (GIS_DATA(IJ,IK),IK=1,NVRBL+2)
CC 3 SPACE4
451 FORMAT(A8,',',A8,',',F8.4,',',F9.4,
1 ',',16(F10.4,','),F10.4)
CCCC WRITE(KFILGIS,451) CALLML(IJ,1),CALLML(IJ,1)
CCCC 451 FORMAT(A8,',',A8,',')
490 CONTINUE
500 CONTINUE
c
cc NXNY=NX*NY
cc DO 500 IJ=1,NXNY
cc 500 WRITE(KFILGIS,451) CALLML(IJ,1),CALLML(IJ,1),
cc 2 (GIS_DATA(IJ,IK),IK=1,NVRBL+2)
cc 451 FORMAT(A8,',',A8,',',F8.4,',',F9.4,
cc 1 ',',7(F10.4,','),F10.4)
cc
c
ELSEIF(IVAR_CNT.GT.NVRBL)THEN
WRITE(KFILDO,510)NDATE,IVAR_CNT,NVRBL
510 FORMAT(/,'**** ERROR: IVARCNT GT NVRBL FOR DATE=',I12,
1 /,'IVAR_CNT,NVRBL=',2I5)
ENDIF
ENDIF
C
ENDIF
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C
C
C
cc IF(NDATE.LE.LNDATE.AND.(IFIRST.EQ.1.OR.IFIRST.EQ.2))THEN
cc WRITE(KFILDO,515)KFILIN(IN-1),NAMIN(IN-1),
cc 1 LNDATE,KFILIN(IN),NAMIN(IN),NDATE
cc 515 FORMAT(/' ****INPUT FILES MUST BE ORDERED BY',
cc 1 ' INCREASING DATE.'/
cc 2 ' UNIT # ',I3,', FILE ',A60/
cc 3 ' HAS LAST DATE OF ',I10/
cc 4 ' UNIT # ',I3,', FILE ',A60/
cc 5 ' HAS FIRST DATE OF ',I10/
cc 6 ' STOP IN U140 AT 515')
cc STOP 515
cc ENDIF
C
C
C
C STEP 8. 1. REORDER OUTPUT DATA TO THE U155 INPUT DATA FORMAT
C 2. ADJUST THE IDS TO THEIR ANALYSIS IDS IF REQUESTED
C ID_ADJ SHOULD BE A SUBSET OF ID. IF A VARIABLE IN
C ID_ADJ CANNOT BE FOUND IN ID, A WARNING DIAGNOSTIC
C WILL BE PRINTED
C 2A. WHEN IMISS > 0 SET UP TO WRITE THE BOGUS RECORDS
C FOR SEQUENTIAL INPUT.
C 3. WRITE OUTPUT DATA TO A SEQUENTIAL AND/OR RANDOM
C ACCESS FILE.
C
C
C 1. REORDER DATA FOR U155
C
MAX_NSTA=NX*NY
DO 520 I=1,ND5
IF(I.LE.ISTA)THEN
NC=I_PACK(I)
SDATA(NC)=TMP_DATA(I)
ELSE
SDATA(I)=TMP_DATA(I)
ENDIF
C
520 CONTINUE
C
C
PLAIN2=PLAIN(IVAR_CNT)
ISCALE=ISCALD(IVAR_CNT)
IF(NUMRA.EQ.0)THEN
PLAIN2=PLAIN(ISEQ_POST)
ISCALE=ISCALD(ISEQ_POST)
ENDIF
C
FOUND_MATCH=.FALSE.
C
C 2. SPECIAL CONDITION FOR FILLING IN BOGUS RECORDS FOR
C SEQUENTIAL INPUT FILES (IMISS > 0)
C
C 10/2005 - COMMENTED OUT THE IF TEST THAT CHECKED THAT
C THE ID WENT FROM X0X TO X1X. THE USER CAN RESET THE
C ID TO ANYTHING THEY WANT. HAD TO ADD A CHECK TO FIND
C THE POSITION OF THE INPUT ID. THE OUTPUT ID BETTER BE
C IN THE SAME POSITION IN THE OUTPUT ID LIST OR THIS ISN'T
C GOING TO WORK.
IF(IMISS.EQ.0) THEN
DO 523 J=1,NVRBL_ADJ
C IF(NID(1)+10000000.EQ.ID_ADJ(1,J))THEN
C IF((NID(2).EQ.ID_ADJ(2,J)).AND.(NID(3).EQ.ID_ADJ(3,J))
C 1 .AND.(NID(4).EQ.ID_ADJ(4,J)))THEN
IF((NID(1).EQ.ID(1,J)).AND.(NID(2).EQ.ID(2,J)).AND.
1 (NID(3).EQ.ID(3,J)).AND.(NID(4).EQ.ID(4,J)))THEN
NID(1)=ID_ADJ(1,J)
NID(2)=ID_ADJ(2,J)
NID(3)=ID_ADJ(3,J)
NID(4)=ID_ADJ(4,J)
FOUND_MATCH=.TRUE.
ISCALE=ISCALD_ADJ(J)
PLAIN2=PLAIN_ADJ(J)
ENDIF
C ENDIF
523 CONTINUE
WRITE(KFILDO,*) PLAIN2(1:IS1(22)),NDATE,IVAR_CNT
IF(.NOT.FOUND_MATCH)THEN
WRITE(KFILDO,524) NID(1),NID(2),NID(3),NID(4)
524 FORMAT(/' ****WARNING: THE INPUT VARIABLE ID ',
1 'HAS NO ADJUSTED MATCH FOR INPUT ID =',4I10)
ENDIF
C
ELSEIF(IMISS.GT.0)THEN
DO 525 J=1,IMISS
WRITE(KFILDO,524)ID_IMISS(1,J),ID_IMISS(2,J),
1 ID_IMISS(3,J),ID_IMISS(4,J)
525 CONTINUE
ENDIF
C
C
C 2A. SETUP FOR WRITING BOGUS RECORDS WHEN SEQUENTIAL
C FILES ARE INPUT. BOGUS RECORDS WILL BE WRITTEN BY
C DEFAULT FOR RANDOM ACCESS INPUT FILES.
C
I=0
550 IF(IMISS.GT.0)THEN
I=I+1
IF(I.LE.IMISS)THEN
ISCALE=ISCALD(IMISS_SEQ_POST(I))
PLAIN2=PLAIN(IMISS_SEQ_POST(I))
NDATE=KDATE
NID(1)=ID_IMISS(1,I)
NID(2)=ID_IMISS(2,I)
NID(3)=ID_IMISS(3,I)
NID(4)=ID_IMISS(4,I)
ENDIF
ENDIF
C
C
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
CC
CC WRITE TO THE SEQUENTIAL FILE
CC
IF(IOUTG.NE.0)THEN
C
DO 560 J=1,ND7
IS0(J)=0
IS1(J)=0
IS2(J)=0
IS4(J)=0
560 CONTINUE
DO 562 J=1,ND5
IA(J)=0
IC(J)=0
562 CONTINUE
c call prsid to parse NID into the components
CALL PRSID1(KFILDO,NID,NIDPARS)
c now use nidpars to set DD and tau before they are
c sent into pwotgm
ITAUH = NIDPARS(12)
MODNO = NIDPARS(4)
C
CALL PWOTGM(KFILDO,KFILGO,IP(16),NDATE,
1 NID,ITAUH,ITAUM,MODNO,NSEQ,ISCALE,
2 NPROJ,XLATLL,YLONLL,ORIENT,XMESHL,XLAT,NX,NY,
3 SDATA,IA,IC,IPACK,MAX_NSTA,MINPK,
4 IS0,IS1,IS2,IS4,ND7,
5 IPLAIN,PLAIN2,NCHAR,
6 XMISSP,XMISSS,LX,IOCTTG,
7 NTOTBG,NTOTRG,L3264B,L3264W,IERG)
C
C NWRDSG=IOCTTG*8/L3264B
C IF(IERG.EQ.0) WRITE(KFILDO,563) NDATE,NTOTRG,NWRDSG,NTOTBG
C563 FORMAT(' FOR NDATE = ',I10,' WROTE PACKED GRID RECORD.',
C 1 ' NTOTRG,NWRDSG,NTOTBG = ',4I10)
C
IF(IERG.NE.0)THEN
WRITE(KFILDO,569)IERG
569 FORMAT(/' ****ERROR IN GRIDDED PACKING ROUTINE PWOTGM'/
1 ' ERROR VALUE IS ',I2,
2 ' CONSIDER AS FATAL'/
3 ' STOP IN U140 AT 569')
STOP 569
ENDIF
ENDIF
C
C
C
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
CC
CC WRITE TO THE RANDOM ACCESS FILE
CC
IF(IOUTJ.NE.0)THEN
C
DO 580 J=1,ND7
IS0(J)=0
IS1(J)=0
IS2(J)=0
IS4(J)=0
580 CONTINUE
DO 582 J=1,ND5
c commented out the ia and ic initializations because
c they were passed into pawrag but aren't into packgr_oper
c IA(J)=0
c IC(J)=0
IPACK(J)=0
582 CONTINUE
C
C FILL APPROPRIATE PORTIONS OF IS1( ) AND IS2( ) AND
C WRITE THE DATA. 3/2006 - commented this out because
c this is now done in packgr_oper
C
c IS1(2)=1
c IS1(2) SIGNIFIES NO BIT MAP AND GRIDPOINT DATA.
c IS1(17)=ISCALE
c IS2(2)=NPROJ
c IS2(3)=NX
c IS2(4)=NY
c IS2(5)=NINT(XLATLL*10000.)
c IS2(6)=NINT(YLONLL*10000.)
c IS2(7)=NINT(ORIENT*10000.)
cC IS2(8)=NINT(XMESHL*1000000.) (km)
c IS2(8)=NINT(XMESHL*1000.)
c IS2(9)=NINT(XLAT*10000.)
C
c WRITE(KFILDO,585)(NID(K),K=1,4)
c585 FORMAT(/,'VARIABLES ADJ BEFORE PAWRAG STEP 8:',/,4I10)
C
c CALL PAWRAG(KFILDO,KFILX,CFILX,NID,
c 1 SDATA,IA,IC,NX,NY,IPACK,ND5,MINPK,
c 2 IS0,IS1,IS2,IS4,ND7,
c 3 IPLAIN,PLAIN2,NCHAR,
c 4 XMISSP,XMISSS,LX,IOCTET,
c 5 L3264B,L3264W,IER)
C
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C set up array ngridc with grid specs
NGRIDC(1)=NPROJ
NGRIDC(2)=NINT(XMESHL*1000.)
NGRIDC(3)=NINT(XLAT*10000.)
NGRIDC(4)=NINT(ORIENT*10000.)
NGRIDC(5)=NINT(XLATLL*10000.)
NGRIDC(6)=NINT(YLONLL*10000.)
c call prsid to parse NID into the components
CALL PRSID1(KFILDO,NID,NIDPARS)
CALL PACKGR_OPER(KFILDO,KFILX,CFILX,NID,NIDPARS,
1 ISCALE,0,NGRIDC,IPLAIN,PLAIN2,
2 IDATE(1),NYR,NMO,NDA,NHR,
3 FD1,SDATA,ND5,NX,NY,IPACK,IWORK,ND5,
6 MINPK,IS0,IS1,IS2,IS4,ND7,
7 XMISSP,XMISSS,NWORDS,NTOTGB,NTOTGR,
8 L3264B,L3264W,ISTOP,IER)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
IF(IER.NE.0)THEN
WRITE(KFILDO,589)(NID(J),J=1,4),IER
589 FORMAT(/,' ****ERROR WRITING DATA FOR',1X,I9.9,2I10.9,
1 I11.3,' ON RANDOM ACCESS FILE, IER =',I4,/,
2 ' STOP IN U361 AT 589.')
STOP 589
ENDIF
ENDIF
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
C
C
IF(IMISS.GT.0)THEN
IF(I.LT.IMISS)GO TO 550
IF(I.GE.IMISS)GO TO 670
ENDIF
C
C
C
ENDIF
GO TO 190
C
C END OF PROCEED_ID AND PROCEED_DATE LOOP
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C
C
C
601 WRITE(KFILDO,602)KFILIN(IN),IPACK(5),IOS,NAMIN(IN)
602 FORMAT(/' ****ERROR READING PACKED RECORDS ON UNIT NO.',I3,
1 ' PROCESSING DATE',I11,' IN U140 AT 602,',
2 ' IOSTAT =',I5/,' FILE = ',A60)
STOP 602
C
C
665 WRITE(KFILDO,667)KFILIN(IN),IPACK(5),IOS,NAMIN(IN)
667 FORMAT(/' ****END READING PACKED RECORDS OR DIRECTORY.',I10,
1 ' PROCESSING DATE',I11,' IN U140 AT 667,',
2 ' IOSTAT =',I5/,' FILE = ',A60)
C
C
670 CLOSE(KFILIN(IN),IOSTAT=IOS)
IF(KFILIN(IN).EQ.KFILIN(IN+1))THEN
JFCLOS=1
ELSE
JFCLOS=0
ENDIF
WRITE(KFILDO,668)KFILIN(IN),NAMIN(IN)
668 FORMAT(/' CLOSING FILE ON UNIT NO.',I3,', FILE = ',A60)
C
C
700 CONTINUE
C
C
750 CONTINUE
C
C CLOSE RANDOM ACCESS FILE.
C
IF(IOUTJ.NE.0) CALL CLFILM(KFILDO,KFILX,IER)
C
RETURN
C
C ERROR STOP BELOW IS FOR ERRORS OF CONTROL INFORMATION INPUT.
C
900 CALL IERX(KFILDO,KFILDO,IOS,'U140 ',STATE)
STOP 9999
END