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 2018-07-09 SCHNAPP INCREASE MINPK TO 46 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/46/ 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, 1 ND1*L3264W,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