SUBROUTINE RDVR140(KFILDO,IP9,IP10,IP11,KFILP,KFILCP, 1 ID,IDPARS,JD,ND4,PLAIN,ISCALD, 2 NVRBL,ISTOP,IER) C C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: RDVR140 C PRGMMR: WEISS ORG: W/OST22 DATE: 2005-01-01 C C ABSTRACT: TO READ A VARIABLE LIST FROM A FILE ON UNIT KFILP. C THE IDS ARE READ FROM THE INPUT FILE. C ALSO, THE VARIABLE NAMES AND OTHER INFORMATION C FROM THE VARIABLE CONSTANT FILE ON C UNIT KFILCP CAN BE MATCHED WITH THE VARIABLES. C EACH VARIABLE ID IN ID( , ) IS DUPLICATED IN JD( , ), C BUT WITH SOME PORTIONS OMITTED; THE RESULT IS CALLED C THE "BASIC" ID. (THIS BASIC ID IS NOT DEFINED THE C SAME WAY IN U201.) THIS ROUTINE IS USED FOR U140. C SIMILAR CODE IS USED FOR U370 (RDVR37), C U201 (RDPRED), AND U600 (RDVRBL). C C PROGRAM HISTORY LOG: C 05-01-01 WEISS C 05-03-07 MALONEY ADDED NCEP DOCBLOCK. ADDED CALLS TO W3TAGE. C C USAGE: CALLED BY U140 C C DATA SET USE: C INPUT FILES: C FORT.KFILP - UNIT NUMBER FROM WHICH TO READ VARIABLE LIST. C IT IS ASSUMED FILE HAS BEEN OPENED. (INPUT) C FORT.KFILCP - UNIT NUMBER FROM WHICH TO READ VARIABLE NAMES AND C OTHER ASSOCIATED INFORMATION. IT IS ASSUMED FILE C HAS BEEN OPENED. (INPUT) C C OUTPUT FILES: C FORT.KFILDO - UNIT NUMBER OF OUTPUT (PRINT) FILE. (OUTPUT) C FORT.IP9 - UNIT NUMBER FOR OUTPUT (PRINT) FILE FOR VARIABLE C LIST AS READ IN. (OUTPUT) C FORT.IP10 - UNIT NUMBER FOR OUTPUT (PRINT) FILE FOR VARIABLE C LIST PARSED INTO ITS 15 COMPONENTS. (OUTPUT) C FORT.IP11 - UNIT NUMBER FOR OUTPUT (PRINT) FILE FOR PREDICTOR C LIST INCLUDING INFORMATION FROM THE PREDICTOR C CONSTANT FILE. (OUPUT) C C VARIABLES C KFILDO = DEFAULT UNIT NUMBER FOR OUTPUT (PRINT) FILE. (INPUT) C IP9 = INDICATES WHETHER (>0) OR NOT (=0) THE VARIABLE C ID WILL BE WRITTEN TO UNIT IP9 AS THE VARIABLES C ARE READ IN. THIS SHOULD BE USEFUL FOR CHECKOUT. C (INPUT) C IP10 = INDICATES WHETHER (>0) OR NOT (=0) THE VARIABLE C LIST WILL BE WRITTEN TO UNIT IP10 PARSED INTO ITS 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. (INPUT) CCCC IP11 = INDICATES WHETHER (>0) OR NOT (=0) THE VARIABLE CCCC LIST WILL BE WRITTEN TO UNIT IP11. THE OUTPUT WILL CCCC INCLUDE THE NON-PARSED IDS, THE PLAIN LANGUAGE CCCC AND THE SCALLING FACTORS OF THE IDS. THIS CCCC INFORMATION IS TAKEN FROM THE VARIABLE CCCC CONSTANT FILE READ ON UNIT KFILCP. (INPUT) C KFILP = UNIT NUMBER FROM WHICH TO READ VARIABLE LIST. C IT IS ASSUMED FILE HAS BEEN OPENED. (INPUT) C KFILCP = UNIT NUMBER FROM WHICH TO READ VARIOUS VARIABLE C CONSTANTS AND NAMES. IT IS ASSUMED FILE HAS BEEN C OPENED. (INPUT) C ID(J,N) = THE INTEGER VARIABLE ID'S (J=1,4) (N=1,NVRBL). C (OUTPUT) C IDPARS(J,N) = THE PARSED, INDIVIDUAL COMPONENTS OF THE VARIABLE C ID'S CORRESPONDING TO ID( ,N) (J=1,15), (N=1,NVRBL). C (OUTPUT) 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 JD(J,N) = THE BASIC INTEGER VARIABLE ID'S (J=1,4) (N=1,ND4). C THIS IS THE SAME AS ID(J,N), EXCEPT THAT THE FOLLOWING C PORTIONS ARE OMITTED: C B = IDPARS(3, ), C G = IDPARS(15, ), C JD( , ) IS USED IN SETPLN. THE "G" VARIABLE HAS C HAS NO MEANING IN U140. (OUTPUT) C PLAIN(N) = THE PLAIN LANGUAGE DESCRIPTION OF THE VARIABLES C (N=1,ND4). (CHARACTER*32) (OUTPUT) C ISCALD(N) = THE DECIMAL SCALING CONSTANT TO USE WHEN PACKING THE C COLLATED DATA (N=1,ND4). NO BINARY SCALING IS C PROVIDED FOR. ISCALD COMES FROM THE VARIABLE C CONSTANT FILE, MODIFIED TO BE 2 FOR GRID BINARIES, C AND 0 FOR BINARIES. ZERO WHEN NOT FOUND IN THE C FILE. (OUTPUT) C ND4 = MAXIMUM NUMBER OF VARIABLES THAT CAN BE DEALT WITH C IN ONE RUN. SECOND DIMENSION OF ID( , ) AND C IDPARS( , ). (INPUT) C NVRBL = THE NUMBER OF VARIABLES. (OUTPUT) C ISTOP = INCREASED BY 1 WHENEVER AN ERROR IS ENCOUNTERED. C (INPUT-OUTPUT) C IER = STATUS RETURN. (OUTPUT) C 0 = GOOD RETURN. C 40 = ERROR READING VARIABLE LIST. C 41 = DIMENSION ND4 ABOUT TO BE EXCEEDED. C 42 = NO PREDICTORS OR NO PREDICTANDS. C C OTHER VARIABLES C SADD = ARRAY RETURNED FROM SETPLN. (INTERNAL) C SMULT = ARRAY RETURNED FROM SETPLN. (INTERNAL) C ORIGIN = ARRAY USED IN SETPLN. (INTERNAL) C CINT = ARRAY USED IN SETPLN. (INTERNAL) C UNITS = ARRAY USED IN SETPLN. (INTERNAL) C ITEMP4 = LAST PORTION OF ID = ID(4). (INTERNAL) C ITERM = TERMINATOR VALUE FOR INPUT ID VALUES (NVALL = 2). C (INTERNAL) C NERR = COUNTS ERRORS FOR PURPOSES OF KNOWING WHEN TO C PRINT DIAGNOSTICS. IF NERR EXCEEDS 100, C RDVR140 WILL STOP. (INTERNAL) C C SUBPROGRAMS CALLED: PRSID1, SETPLN, W3TAGE C UNIQUE: NONE C LIBRARY: C MOSLIB - PRSID1, SETPLN C W3LIB - W3TAGE C C EXIT STATES: C COND = 0 - SUCCESSFUL RUN C 110 - CATASTROPHIC ERROR READING RECORDS C SEE OTHER ROUTINES FOR OTHER VALUES. C C REMARKS: NONE C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 (xlf90 compiler) C MACHINE: IBM SP C C$$$ C IMPLICIT NONE C INTEGER KFILDO, IP9, IP10, IP11, KFILP, KFILCP, 1 ID, IDPARS, JD, 2 ISCALD, ND4, 3 NVRBL, ISTOP, IER INTEGER ITEMP4, ITERM, NERR, IOS, N, J, L C REAL SMULT, SADD, ORIGIN, CINT C CHARACTER*12 UNITS(ND4) C UNITS( ) IS AN AUTOMATIC ARRAY FOR CALL TO SETPLN. CHARACTER*32 PLAIN(ND4) C DIMENSION ID(4,ND4), IDPARS(15,ND4), 1 JD(4,ND4), ISCALD(ND4) DIMENSION SMULT(ND4), SADD(ND4), ORIGIN(ND4), CINT(ND4) C SMULT( ), SADD( ), ORIGIN( ), AND CINT( ) ARE AUTOMATIC C ARRAYS FOR CALL TO SETPLN. C C FOR SOME UNKNOWN REASON, IT SEEMS TEMP AND CTEMP MUST C BE INITIALIZED FOR PRINT AT STATEMENT 1031 TO WORK. C ITERM = 99999999 IER = 0 NERR = 0 N = 1 CCCC IF(KFILCP.EQ.0)THEN C C READ PREDICTOR ID. C 102 READ(KFILP,103,IOSTAT=IOS,ERR=104,END=150)(ID(J,N),J=1,4) 103 FORMAT(I9,1X,I9,1X,I9,I10) C C NOTE: ERROR MESSAGE UNLIKELY TO BE FLAGGED C C IP(6) C IF(IP9 .NE. 0 .AND. N .EQ. 1) WRITE(IP9,1031) 1031 FORMAT(/' VARIABLES AS READ BY RDVR140') IF(IP9 .NE. 0) WRITE(IP9,1032)(ID(J,N),J=1,4) 1032 FORMAT(' ',I9.9,1X,I9.9,1X,I9.9,1X,I10.10) C GO TO 120 C 104 NERR = NERR+1 ISTOP = ISTOP+1 IER = 40 WRITE(KFILDO,107) N, IOS 107 FORMAT(/,' ****ERROR READING VARIABLE ID NO. ',I4, 1 '. IOSTAT = ',I5,'. VARIABLE SKIPPED.') IF(IP9 .NE. KFILDO) WRITE(IP9,107) N, IOS C ATTEMPT TO READ ANOTHER RECORD. HOWEVER, SOME ERRORS WILL C KEEP REPEATING AND FILL UP THE PRINT FILE. GO BACK ONLY IF C IT SEEMS THERE WAS AN ERROR ON AN INDIVIDUAL RECORD. A C LIMIT OF NERR = 100 HAS BEEN SET. C IF (NERR .GE. 100) THEN WRITE(KFILDO,110) 110 FORMAT(/' ****READING ERRORS IN RDVR140 HALTED PROGRAM', 1 ' AT 110. CATASTROPHIC ERROR.') CALL W3TAGE('RDVR140') STOP 110 ENDIF C IF (IOS .EQ. 900 .OR. 1 IOS .EQ. 915 .OR. 2 IOS .EQ. 922 .OR. 3 IOS .EQ. 933 .OR. 4 IOS .EQ. 945 .OR. 5 IOS .EQ. 958) GO TO 102 GO TO 150 C 120 IF (ID(1,N) .EQ. ITERM) GO TO 150 C C STORE THIS VARIABLE ID, UNLESS ND4 WILL BE EXCEEDED. C IF (N .LE. ND4) GO TO 125 IER = 41 NERR = NERR + 1 ISTOP = ISTOP + 1 WRITE(KFILDO,122) ND4 122 FORMAT(/,' ****ND4 = ',I4,' TOO SMALL IN RDVR140.') GO TO 180 C C REMOVE THE "MODEL NUMBER" FOR "CONSTANT" DATA. THIS IS HERE C FOR CONVENIENCE AND SAFETY, BECAUSE A DEFAULT MODEL NUMBER C IS USED IN "VECTOR" TYPE PROGRAMS WHICH HAVE ONLY ONE C POSSIBLE CONSTANT SOURCE, WHILE U201 USES A MODEL NUMBER C TO DESIGNATE MULTIPLE SOURCES. IF THE VARIABLES WERE JUST C COPIED FROM A U201 CONTROL FILE TO A U140 CONTROL FILE, C THE USER MIGHT FORGET TO REMOVE THE MODEL NUMBER. C 125 IF (ID(1,N) .GE. 400000000 .AND. 1 ID(1,N) .LE. 499000000) ID(1,N) = (ID(1,N)/100)*100 C C PARSE ID'S INTO 15 COMPONENT PARTS ID(J, ) (J=1,15) C CALL PRSID1(KFILDO,ID(:,N),IDPARS(1,N)) C C FOR ALL PROGRAMS EXCEPT U201, IDPARS(15, ) AND IT'S ROLE IN C ID(4) HAS NO MEANING. THE VECTOR INPUT FILE WILL NOT C INCLUDE IT. THEREFORE, SET IT TO ZERO. C ITEMP4 = MOD(ID(4,N),1000) IDPARS(13,N) = ITEMP4/100 IDPARS(14,N) = (ITEMP4 - IDPARS(13,N)*100)/10 IDPARS(15,N) = 0 ID(4,N) = (ID(4,N)/10)*10 C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C PREPARE "BASIC" VARIABLE ID'S. FOR PROGRAMS READING U201 C OUTPUT (E.G., U140), JD( , ) = ID( , ) EXCEPT IN ID(1, ) C THE BINARY INDICATOR IS OMITTED AND IN JD(4, ) THE C THRESHOLDS AND IDPARS(15, ) ARE OMITTED. C JD(1,N) = IDPARS(1,N)*1000000+IDPARS(2,N)*1000+IDPARS(4,N) JD(2,N) = ID(2,N) JD(3,N) = ID(3,N) JD(4,N) = IDPARS(13,N)*100+ 1 IDPARS(14,N)*10 C C OMIT VARIABLE IF IT IS A DUPLICATE. C IF (N .EQ. 1) GO TO 130 C DO 129 J = 1, N-1 IF(ID(1,J) .NE. ID(1,N) .OR. 1 ID(2,J) .NE. ID(2,N) .OR. 2 ID(3,J) .NE. ID(3,N) .OR. 3 ID(4,J) .NE. ID(4,N)) GO TO 129 WRITE(KFILDO,128) (ID(L,N),L=1,4) IF(IP9.NE.KFILDO.AND.IP9.NE.0)WRITE(IP9,128)(ID(L,N),L=1,4) 128 FORMAT(/' ****DUPLICATE VARIABLE DELETED', 1 1X,I9.9,1X,I9.9,1X,I9.9,1X,I10.3) ISTOP = ISTOP + 1 GO TO 102 129 CONTINUE C 130 N = N + 1 GO TO 102 C 150 NVRBL = N - 1 155 IF (NVRBL .EQ. 0) GO TO 228 C C WRITE VARIABLE LIST WHEN REQUIRED. LIST IS ALWAYS WRITTEN C TO DEFAULT OUTPUT WHEN THERE HAS BEEN AN ERROR. C 180 IF (NERR .NE. 0) WRITE(KFILDO,181) NVRBL 181 FORMAT(/' ',I4,' VARIABLES AND PARSED IDS IN ORDER READ IN') IF (NERR .NE. 0) WRITE(KFILDO,182)(N,(ID(J,N),J=1,4), 1 (IDPARS(J,N),J=1,15),N=1,NVRBL) 182 FORMAT(' NO. ID(1) ID(2) ID(3) ID(4)', 2 ' CCC FFF B DD V LLLL UUUU T RR O HH', 3 ' TAU I S G '/ 4 (' ',I4,1X,I9.9,1X,I9.9,1X,I9.9,1X,I10.3, 5 2X,I4.3,I4.3,I2,I3,3X,I2,I5,I5,3X, 6 I2,I3,I3,I3,I4,3X,I2,I2,I2)) C C IP(10) C IF(NERR.NE.0.AND.KFILDO.NE.IP10.OR.NERR.EQ.0.AND.IP10.NE.0)THEN WRITE(IP10,181)NVRBL WRITE(IP10,182)(N,(ID(J,N),J=1,4), 1 (IDPARS(J,N),J=1,15),N=1,NVRBL) ENDIF C C READ THE PLAIN LANGUAGE AND OTHER INFORMATION C FROM THE VARIABLE CONSTANT FILE, AND INITIALIZE C PLAIN( ) AND OTHER VARIABLES. C CCCC ELSEIF(KFILCP.NE.0)THEN CALL SETPLN(KFILDO,KFILCP, 1 ID,IDPARS,JD,ISCALD,SMULT,SADD, 2 ORIGIN,CINT,PLAIN,UNITS,ND4,NVRBL,ISTOP,IER) CCCC ENDIF C 228 IF (NVRBL .EQ. 0) THEN WRITE(KFILDO,229) 229 FORMAT(/' ****NO VARIABLES FOUND TO PROCESS.') ISTOP = ISTOP + 1 IER = 42 GO TO 250 ENDIF C C IP(9) C IF(IP11 .NE. 0) WRITE(IP11,231) NVRBL 231 FORMAT(/' ',I4,' VARIABLES AND INFORMATION FROM VARIABLE', 1 ' CONSTANT FILE',/, 2 ' NO. ID(1) ID(2) ID(3) ID(4) ', 3 ' PLAIN LANGUAGE ID ISCALD ') IF(IP11 .NE. 0) WRITE(IP11,235) (N,(ID(J,N),J=1,4), 1 PLAIN(N),ISCALD(N),N=1,NVRBL) 235 FORMAT(I4,1X,I9.9,1X,I9.9,1X,I9.9,1X,I10.3,2X,A32,I5) 250 RETURN END