SUBROUTINE GFETCH4(KFILDO,KFIL,ID,LOCPRD,LSTORE,ND9,LITEMS, 1 IS0,IS1,IS2,IS4,ND7,IPACK,IWORK,DATA,NDX, 2 NWORDS,NPACK,NDATE,NTIMES,CORE,ND10, 3 NBLOCK,NFETCH,NSLAB,MISSP,MISSS,L3264B, 4 NPROJ,ORIENT,XLAT,ITIME,IER) C C DECEMBER 2015 GLAHN TDL MOS-2000 C ADAPTED FROM GFETCH C JULY 2016 GLAHN IMPROVED DIAGNOSTICS C SEPTEMBER 2016 GLAHN CORRECTED SPELLING; COMMENTED OUT C SOME DIAGNOSTICS C C PURPOSE C TO FETCH DATA FROM EITHER A LINEAR ARRAY CORE( ) IN MEMORY C OR FROM DISK. (THIS IS THE SO-CALLED MOS-2000 INTERNAL C STORAGE SYSTEM.) THE ARRAY LSTORE( ,ND9) HOUSES THE KEYS, C THE FIRST 4 WORDS BEING THOSE CORRESPONDING TO ID( ). C WHEN LSTORE(1, ) = 0, THE DATA FOR THIS KEY HAVE BEEN C DEEMED NO LONGER NEEDED, AND CANNOT BE RETURNED. THE DATA C ARE RETURNED IN DATA( ) UNPACKED, WHETHER THEY ARE STORED C PACKED OR UNPACKED. DATA IDENTIFIERS ARE ALSO RETURNED C IN IS0( ), IS1( ), IS2( ), AND IS4( ) WHEN THE DATA ARE C PACKED. WHEN ITIME NE 0 AND WHEN THE TIME OFFSET RR C IN THE PREDICTOR ID(3) GT 0, THE DATE/TIME IS MODIFIED C ACCORDINGLY AND RR IS SET TO 0 FOR PURPOSES OF SEARCH (SEE C BELOW). GRIDPOINT DATA ARE ASSUMED TO BE PACKED, ELSE THE C GRID CHARACTERISTICS WOULD NOT BE AVAILABLE. ALSO, C VECTOR DATA CAN'T REASONABLY BE PACKED BECAUSE C THE DATA MUST MATCH THE STATIONS BEING USED. C A DATE/TIME OF ZERO IS USED FOR DATA THAT ARE NOT TO C BE DISCARDED, AND ARE NOT FOR SPECIFIC DATES, SUCH C AS CLIMATOLOGICAL VALUES AND INDICES TO THRESHOLD C MATRICES FOR LINEARIZATION ROUTINES. C C THE DIFFERENCE BETWEEN GFETCH4 AND GFETCH IS THAT C GFETCH RETURNS DATA BASED ONLY ON THE ID, WHILE C GRETCH4 ALSO CHECKS THE GRID CHARACTERISTICS. HENCE C THE CALL SEQUENCE CONTAINS THE NRPOJ, ORIENT, AND XLAT C THAT ARE WANTED. THIS ALLOWS TWO GRIDS WITH THE SAME C IDS TO BE ON THE INPUT FILES, BUT WITH DIFFERENT C GRID CHARACTERISTICS. USED IN FSTGS5 IN U155. C C A COMMON BLOCK FETCH MAINTAINS CONTACT BETWEEN GFETCH, C GFETCH1, GFETCH2, GFETCH3, AND GFETCH4. C C DATA SET USE C KFILDO - UNIT NUMBER FOR OUTPUT (PRINT) FILE. (OUTPUT) C KFIL - UNIT NUMBER FOR READING THE DATA INTO DATA( ) C FROM DISK. (INPUT) C C VARIABLES C KFILDO = UNIT NUMBER FOR OUTPUT (PRINT) FILE. (INPUT) C KFIL = UNIT NUMBER FOR READING THE DATA INTO DATA( ) C FROM DISK. (INPUT) C ID(J) = THE 4-WORD ID OF THE VARIABLE TO FETCH C (J=1,4). (INPUT) C LOCPRD = THE LOCATION OF THE PREDICTOR ID( ) IN THE C PREDICTOR LIST WHEN GFETCH IS ACCESSED FROM PRED1. C WHEN GFETCH IS ACCESSED FROM OPTION OR C COMPUTATION ROUTINES CALLED FROM OPTION, C LOCPRD MUST BE 7777. THIS MAY BE STORED IN C LSTORE(11, ). (INPUT) C LSTORE(L,J) = THE ARRAY HOLDING INFORMATION ABOUT THE DATA C STORED (L=1,12) (J=1,LITEMS). (INPUT-OUTPUT) C L=1,4--THE 4 ID'S FOR THE DATA. C L=5 --LOCATION OF STORED DATA. WHEN IN CORE, C THIS IS THE LOCATION IN CORE( ) WHERE C THE DATA START. WHEN ON DISK, C THIS IS MINUS THE RECORD NUMBER WHERE C THE DATA START. C L=6 --THE NUMBER OF 4-BYTE WORDS STORED. C L=7 --2 FOR DATA PACKED IN TDL GRIB, 1 FOR NOT. C L=8 --THE DATE/TIME OF THE DATA IN FORMAT C YYYYMMDDHH. FOR DATA LIKE CLIMATOLOGICAL C VALUES THAT ARE NOT TO BE DISCARDED, THIS C IS ZERO. C L=9 --NUMBER OF TIMES DATA HAVE BEEN RETRIEVED. C UPON RETRIEVAL BY GFETCH. C L=10 --NCOMBO, THE NUMBER OF THE SLAB IN DIR( , ,L) C AND IN NGRIDC( ,L) DEFINING THE CHARACTERISTICS C OF THIS GRID. C L=11 --THE NUMBER OF THE FIRST PREDICTOR IN THE SORTED C LIST IN ID( ,N) (N=1,NPRED) FOR WHICH THIS C VARIABLE IS NEEDED, WHEN IT DOES NOT NEED C TO BE STORED AFTER DAY 1. WHEN THE VARIABLE C MUST BE STORED (TO BE ACCESSED THROUGH OPTION) C FOR ALL DAYS, ID(11,N) IS 7777 + THE NUMBER C OF THE FIRST PREDICTOR IN THE SORTED LIST C FOR WHICH THIS VARIABLE IS NEEDED. C L=12 --USED INITIALLY IN ESTABLISHING MSTORE( , ). C LATER USED AS A WAY OF DETERMINING WHETHER C TO KEEP THIS VARIABLE. C ND9 = THE SECOND DIMENSION OF LSTORE( , ). (INPUT) C LITEMS = THE NUMBER OF ITEMS (COLUMNS) IN LSTORE( , ). C (INPUT) C IS0(L) = HOLDS THE BYTES DECODED FROM SECTION 0 (L=1,3). C (OUTPUT) C IS1(L) = HOLDS THE BYTES DECODED FROM SECTION 1 C (L=1,MAX OF ND7). (OUTPUT) C IS2(L) = HOLDS THE OCTETS DECODED FROM SECTION 2 (L=1,12). C SECTION 2 IS NOT PRESENT WHEN DATA ARE NOT C GRIDPOINT. (OUTPUT) C IS4(L) = HOLDS THE BYTES DECODED FROM SECTION 4 (L=1,4), C EXCEPT FOR THE DATA THEMSELVES. (OUTPUT) C ND7 = DIMENSION OF IS0( ), IS1( ), IS2( ), AND IS4( ). C (INPUT) C IPACK(J) = WORK ARRAY (J=1,NDX). USED ONLY BY UNPACK C WHEN DATA ARE PACKED AND MUST BE UNPACKED. C (INTERNAL) C IWORK(J) = WORK ARRAY (J=1,NDX). USED ONLY BY UNPACK C WHEN DATA ARE PACKED AND MUST BE UNPACKED. C (INTERNAL) C DATA(J) = THE DATA ARE RETURNED IN DATA( ) (J=1,NWORDS). C IF THEY WERE STORED PACKED, THE UNPACKER IS C CALLED. (OUTPUT) C NDX = DIMENSION OF IPACK( ) AND DATA( ). MUST BE LARGE C ENOUGH TO HOLD NWORDS OF DATA FROM CORE( ) OR C (NWORDS+NBLOCK-1)/NBLOCK WORDS FROM DISK. C NORMALLY, NDX WILL BE ND5 IN THE CALLING PROGRAM, C BUT IF "STATION" DATA ARE BEING RETURNED, NDX MAY C BE SOME OTHER VARIABLE (E.G., ND1). (INPUT) C NWORDS = NUMBER OF WORDS RETURNED IN DATA( ). THIS IS C STORED IN LSTORE(6, ) (ONLY) WHEN THE DATA C ARE STORED UNPACKED. MUST BE LE NDX. C FOR UNPACKED DATA, NWORDS COMES FROM LSTORE(6, ); C FOR PACKED DATA, NWORDS COMES FROM IS4(3). (OUTPUT) C NPACK = 2 FOR TDL GRIB PACKED DATA; 1 FOR NOT PACKED. C THIS IS STORED IN LSTORE(7, ). (OUTPUT) C NDATE = DATE/TIME OF THE DATA TO BE FETCHED IN FORMAT C YYYYMMDDHH. THIS IS MATCHED TO THE VALUE C STORED IN LSTORE(8, ), AFTER POSSIBLE MODIFICATION C BY THE RR IN THE ID. WHEN THE DATA ARE NOT C ATTACHED TO A SPECIFIC DATE, LIKE CLIMATOLOGICAL C VALUES OR INDICES FOR LINEARIZATION ROUTINES, C NDATE MUST BE INPUT AS ZERO. (INPUT) C NTIMES = THE NUMBER OF TIMES, INCLUDING THIS ONE, THAT THE C DATA HAVE BEEN FETCHED. THIS IS STORED IN C LSTORE(9, ). (OUTPUT) C CORE(J) = THE LINEAR ARRAY WHERE THE DATA ARE STORED, C WHEN SPACE IS AVAILABLE (J=1,ND10). NORMALLY, THIS C IS USED ONLY WITHIN GSTORE AND GFETCH. (INPUT) C ND10 = DIMENSION OF CORE( ). (INPUT) C NBLOCK = THE BLOCK SIZE IN WORDS OF THE RANDOM DISK FILE. C THIS MUST MATCH THE VALUE PROVIDED TO GSTORE C AND MUST NOT CHANGE DURING THE RUN. (INPUT) C NFETCH = INCREMENTED EACH TIME GFETCH IS ENTERED. IT IS C A RUNNING COUNT FROM THE BEGINNING OF THE PROGRAM. C THIS COUNT IS MAINTAINED IN CASE THE USER NEEDS C IT (DIAGNOSTICS, ETC.). (OUTPUT) C NSLAB = FOR U201, THE NUMBER OF THE SLAB IN DIR( , , ) AND C IN NGRIDC( , ) DEFINING THE CHARACTERISTICS C OF THIS GRID. FOR OTHER ROUTINES, THIS NUMBER C MAY MEAN SOMETHING ELSE. FOR INSTANCE, IN U600 C IT IS THE "MODEL NUMBER" OR SOURCE OF THE DATA. C SEE LSTORE(10, ). (OUTPUT) C MISSP = PRIMARY MISSING VALUE INDICATOR. RETURNED AS ZERO C WHEN DATA ARE NOT PACKED. (OUTPUT) C MISSS = SECONDARY MISSING VALUE INDICATOR. RETURNED AS ZERO C WHEN DATA ARE NOT PACKED. (OUTPUT) C L3264B = INTEGER WORD LENGTH OF MACHINE BEING USED. C (INPUT) C ITIME = SERVES FOUR FUNCTIONS. C 1--WHEN EQ 0, AN ADJUSTMENT IN TIME USING RR C IS NOT TO BE MADE. C 2--WHEN 5555, RR ADJUSTMENT IS TO BE MADE AND C MAY BE GT 99. THIS IS ACCOMMODATED BY C USING TRR AS RRR. C 3--GE 0 BUT NOT 5555, THE RR ADJUSTMENT IS TO C BE MADE, 2 DIGITS ONLY. THIS RETAINS USE C OF T. C 4--LESS THAN ZERO, ITIME IS STORED IN C LSTORE(12, ). C U201 AND U855 ROUTINES REQUIRE THE TIME C ADJUSTMENT, BECAUSE GRIDS FOR PREVIOUS C DATE/TIMES MAY BE NEEDED. U855 ALSO REQUIRES C RR BE GREATER THAN 99, HENCE THE ITIME VALUE C OF 5555. HOWEVER, FOR MOST OTHER PROGRAMS, C SUCH AS U600, THE VARIABLE IS PRESENT FOR THE C TIME IN NDATE. WHEN LT 0, THIS VALUE IS TO C BE STORED IN LSTORE(12, ). THIS IS USED IN C VRBL61 AND GTVECT AND ALLOWS A MAXIMUM TAU TO C BE CALCULATED FOR PREDICTANDS IN LMSTR6. C (INPUT) C IER = STATUS RETURN. (OUTPUT) C 0 = GOOD RETURN. C 47 = DATA CANNOT BE FOUND. C 48 = DIMENSION NDX IS NOT LARGE ENOUGH FOR DATA( ) C TO HOLD THE DATA. C 49 = IS2(3)*IS2(4).NE.IS4(3) FOR GRIDPOINT DATA. C 900- = IOSTAT RETURNS FROM SYSTEM ON READING DISK. C JD(J) = THE 4-WORD ID OF THE VARIABLE TO RETRIEVE FROM THE C MOS-2000 INTERNAL STORAGE SYSTEM (J=1,4). THIS MAY C BE THE SAME AS ID( ), BUT MAY BE MODIFIED WITH RR C (SEE NRR). (INTERNAL) C LDATE = DATE/TIME OF THE DATA TO BE FETCHED IN FORMAT C YYYYMMDDHH AFTER POSSIBLE MODIFICATION BY RR C IN THE ID. THIS IS MATCHED TO THE VALUE C STORED IN LSTORE(8, ). (INTERNAL) C IENTER = 0 INITIALLY AND INCREMENTED BY 1 UPON EACH ENTRY. IT C IS THE INTERNAL COUNT BY WHICH NFETCH IS RETURNED AND C IS IMPERVIOUS TO ACTIONS BY THE USER. (COMMON) C LWORDS = WHEN DATA ARE STORED ON DISK, THE NUMBER OF WORDS C STORED. (INTERNAL) C NRR = RUN TIME OFFSET OF PREDICTOR BEING SEARCHED FOR. C WHEN NONZERO, THE DATE/TIME IS UPDATED BY -NRR. C (INTERNAL) C 1 2 3 4 5 6 7 X C C NON SYSTEM SUBROUTINES CALLED C RDDISK, UNPACK, CKGRID C COMMON /FETCH/ IENTER C DIMENSION ID(4),JD(4) DIMENSION LSTORE(12,ND9) DIMENSION IPACK(NDX),IWORK(NDX),DATA(NDX) DIMENSION IS0(ND7),IS1(ND7),IS2(ND7),IS4(ND7) DIMENSION CORE(ND10) C C INCREMENT IENTER AND SET NFETCH. C D WRITE(KFILDO,101)LOCPRD,ND9,LITEMS,NDX,NTIMES,ND10, D 1 NBLOCK,NFETCH,NSLAB,MISSP,MISSS,L3264B,ITIME D101 FORMAT(/' AT 101 IN GFETCH4--LOCPRD,ND9,LITEMS,NDX,NTIMES,', D 1 'ND10,NBLOCK,NFETCH,NSLAB,MISSP,MISSS,L3264B,ITIME',/, D 2 14I9) IER=0 MISSP=0 MISSS=0 C IENTER=IENTER+1 NFETCH=IENTER C C MUST USE TIME OFFSET RR IN ID(3) TO ADJUST NDATE, UNLESS C ITIME = 0, OR RR = 0. C DO 105 J=1,4 JD(J)=ID(J) 105 CONTINUE C LDATE=NDATE IF(NDATE.EQ.0)GO TO 106 C WHEN THE ABOVE TEST IS MET, THE DATE IS NOT TO BE MATCHED. C RATHER, THE DATA ARE INDICES OR CLIMATOLOGICAL DATA THAT C ARE NEVER DISCARDED. IF(ITIME.EQ.0)GO TO 106 C WHEN ITIME NE 0, RR IS TO BE USED. NR=ID(3)/1000000 C IF(ITIME.EQ.5555)THEN NRR=NR ELSE NT=NR/100 NRR=NR-NT*100 ENDIF C IF(NRR.NE.0)THEN CALL UPDAT(NDATE,-NRR,LDATE) C IF(ITIME.EQ.5555)THEN JD(3)=ID(3)-NRR*1000000 C THIS REMOVES RRR. ELSE JD(3)=NT*100000000+(ID(3)-NR*1000000) C THIS REMOVES RR AND LEAVES T INTACT. ENDIF C ENDIF C 106 CONTINUE C WRITE(KFILDO,107)(JD(J),J=1,4),LDATE,NDX 107 FORMAT(/,' IN GFETCH4,',25X,' LOOKING FOR',2X,I9.9,2I10.9,I11.3, 1 ' FOR DATE',I11,' NDX =',I8) C C FIND A LOCATION IN LSTORE( , ) MATCHING ID( ), IF ANY. C D WRITE(KFILDO,108)(ID(J),J=1,4),NDATE,NRR,ITIME D108 FORMAT(/' AT 108 IN GFETCH4--(ID(J),J=1,4),NDATE,NRR,ITIME', D 1 7I12) C DO 170 J=1,LITEMS C IF(LSTORE(8,J).NE.LDATE.AND. 1 LSTORE(8,J).NE.0)GO TO 170 C DROP THROUGH HERE MEANS THE NEEDED DATE HAS BEEN FOUND, C OR THE NEEDED "DATE" IS ZERO WHICH IS THE CASE FOR C 'CONSTANT" DATA. C DO 110 L=1,4 IF(LSTORE(L,J).NE.JD(L))GO TO 170 110 CONTINUE C C DROP THROUGH HERE MEANS THAT THE DATA ID HAS BEEN FOUND. C WHEN LSTORE(1, ) HAS BEEN SET TO ZERO, MEANING DATA FOR C THIS SLOT HAVE BEEN DECLARED NONRETRIEVABLE, THEN C LSTORE(1, ) WILL NOT MATCH ID(1). NOTE THAT THE FIRST C ID CANNOT EQUAL 0. C CCCCC WRITE(KFILDO,114)(LSTORE(M,J),M=1,12) CCCCC 114 FORMAT(/' GFETCH4 AT 114 ',3I10.9,I10.3,I8,I8,I2,I11,2I4,I5,I11) C C***D WRITE(KFILDO,115)((LSTORE(M,N),M=1,12),N=1,LITEMS) C***D115 FORMAT(/' GFETCH4 AT 115 ',3I10.9,I10.3,I8,I8,I2,I11,2I4,I5,I11/ C***D 1 (' ',3I10.9,I10.3,I8,I8,I2,I11,2I4,I5,I11)) NWORDS=LSTORE(6,J) C C DETERMINE WHETHER DATA ARE STORED PACKED OR UNPACKED. C IF(LSTORE(7,J).EQ.2)GO TO 120 C A DROP THROUGH HERE MEANS THE DATA ARE NOT PACKED. C THEREFORE, DATA ARE VECTOR. C C DETERMINE WHETHER DATA ARE STORED IN CORE OR ON DISK C AND WHETHER NDX IS LARGE ENOUGH. C IF(LSTORE(5,J).LT.0)GO TO 117 IF(NDX.LT.NWORDS)GO TO 177 C C FETCH FROM CORE( ). C DO 116 M=1,NWORDS DATA(M)=CORE(LSTORE(5,J)+M-1) 116 CONTINUE C IS2(3)=NWORDS IS2(4)=1 C IS2(3) AND IS2(4) ARE NX AND NY IN SOME CALLING PROGRAMS. GO TO 160 C C FETCH FROM DISK, PROVIDED NDX IS LARGE ENOUGH. C DATA ARE NOT PACKED; THEREFORE ARE VECTOR. C 117 LWORDS=LSTORE(6,J) C*** 117 LWORDS=((LSTORE(6,J)+NBLOCK-1)/NBLOCK)*NBLOCK C TESTING HAS SHOWN THAT THE NUMBER OF WORDS TO READ C FROM THIS RANDOM ACCESS FILE, WHICH IS ALSO THE C SIZE OF DATA( ) IN RDDISK, MUST BE AN EVEN MULTIPLE OF C THE BLOCK SIZE NBLOCK. (FURTHER TESTING, JANUARY 1997, C PUTS THE ABOVE CONCLUSION IN QUESTION. THE TEST HAS BEEN C LEFT AND DOES NO HARM, EXCEPT NDX MAY HAVE TO BE C NBLOCK-1 LARGER THAN NECESSARY. THIS SHOULD BE C NO BIG DEAL.) USERS WERE COMPLAINING; TEST REMOVED 5/16/99. IF(NDX.LT.LWORDS)GO TO 176 C*************************** WRITE(KFILDO,118)LWORDS 118 FORMAT(' READING ',I10,' WORDS IN GFETCH.') CALL RDDISK(KFILDO,KFIL,-LSTORE(5,J),DATA,LWORDS, 1 NBLOCK,NOREC,IER) IF(IER.NE.0)GO TO 180 C IER NE 0 SHOULD BE TREATED AS A FATAL ERROR. A DIAGNOSTIC C WILL HAVE BEEN PRINTED BY RDDISK. IS2(3)=NWORDS IS2(4)=1 C IS2(3) AND IS2(4) ARE NX AND NY IN SOME CALLING PROGRAMS. GO TO 160 C C DATA ARE PACKED. THEREFORE ARE GRIDDED. C DETERMINE WHETHER DATA ARE STORED IN CORE OR ON DISK. C 120 IF(LSTORE(5,J).LT.0)GO TO 127 C C FETCH FROM CORE( ). DATA CAN BE PUT DIRECTLY INTO DATA( ). C SUBROUTINE UNPACK WILL NOT OVERFLOW DATA. C CALL UNPACK(KFILDO,CORE(LSTORE(5,J)),IPACK,DATA,NDX, 1 IS0,IS1,IS2,IS4,ND7,MISSP,MISSS,3,L3264B, 2 IER) IF(IER.NE.0)GO TO 180 C IER NE 0 SHOULD BE TREATED AS A FATAL ERROR. A DIAGNOSTIC C WILL HAVE BEEN PRINTED BY UNPACK. NWORDS=IS4(3) C C CHECK GRID CHARACTERISTICS. WRITE(KFILDO,124)IS2(2),NPROJ,IS2(9),NINT(XLAT*10000.), 1 IS2(7),NINT(ORIENT*10000.), 2 IS2(3),IS2(4),NWORDS C IF(IS2(2).NE.NPROJ.OR. 1 IS2(9).NE.NINT(XLAT*10000.).OR. 2 IS2(7).NE.NINT(ORIENT*10000.))THEN WRITE(KFILDO,123) 123 FORMAT(' ID FOUND BUT GRID CHARACTERISTICS DO NOT MATCH.') WRITE(KFILDO,124)IS2(2),NPROJ,IS2(9),NINT(XLAT*10000.), 1 IS2(7),NINT(ORIENT*10000.), 2 IS2(3),IS2(4),NWORDS 124 FORMAT(/' AT 124_IN GFETCH4--IS2(2),NPROJ,IS2(9),', 1 'NINT(XLAT*10000.),', 2 'IS2(7),NINT(ORIENT*10000.),IS2(3),IS2(4),NWORDS',/ 3 9I12) GO TO 170 C ON TRANSFER THE GRID CHARACTERISTICS DID NOT MATCH. ENDIF C IF(IS2(3)*IS2(4).NE.NWORDS)THEN C THIS TEST WAS ADDED 10/9/98 AND IS NOT NECESSARY IF C PACKING WAS DONE CORRECTLY. WRITE(KFILDO,125)(ID(M),M=1,4) 125 FORMAT(/,' ****IS2(3)*IS2(4) DOES NOT EQUAL IS4(3) FOR', 1 ' GRIDPOINT DATA IN GFETCH4.',/, 2 ' VARIABLE NOT RETURNED = ',3(I9.9,1X),I3) IER=49 GO TO 180 ENDIF C GO TO 160 C C FETCH FROM DISK AND UNPACK, PROVIDED NDX IS LARGE ENOUGH. C 127 LWORDS=LSTORE(6,J) C*** 127 LWORDS=((LSTORE(6,J)+NBLOCK-1)/NBLOCK)*NBLOCK C SEE STATEMENT 117. IF(NDX.LT.LWORDS)GO TO 176 C CALL RDDISK(KFILDO,KFIL,-LSTORE(5,J),DATA,LWORDS, 1 NBLOCK,NOREC,IER) IF(IER.NE.0)GO TO 180 C CALL UNPACK(KFILDO,DATA,IWORK,DATA,NDX, 1 IS0,IS1,IS2,IS4,ND7,MISSP,MISSS,3,L3264B, 2 IER) C SUBROUTINE UNPACK WILL NOT OVERFLOW DATA. C D WRITE(KFILDO,155)(IS1(JJ),JJ=1,22) D155 FORMAT(/' IN GFETCH4 AT 155--IS1( )'/(10I12)) D WRITE(KFILDO,156)(IS2(JJ),JJ=1,9) D156 FORMAT(/' IN GFETCH4 AT 156--IS2( )'/(9I12)) C IF(IER.NE.0)GO TO 180 C IER NE 0 SHOULD BE TREATED AS A FATAL ERROR. A DIAGNOSTIC C WILL HAVE BEEN PRINTED BY UNPACK. NWORDS=IS4(3) C C CHECK GRID CHARACTERISTICS. C CCCC WRITE(KFILDO,158)IS2(2),NPROJ,IS2(9),NINT(XLAT*10000.), CCCC 1 IS2(7),NINT(ORIENT*10000.), CCCC 2 IS2(3),IS2(4),NWORDS CCCC 158 FORMAT(/' 158_IN GFETCH4--IS2(2),NPROJ,IS2(9),NINT(XLAT*10000.),', CCCC 1 'IS2(7),NINT(ORIENT*10000.),IS2(3),IS2(4),NWORDS',/ CCCC 2 9I12) C IF(IS2(2).NE.NPROJ.OR. 1 IS2(9).NE.NINT(XLAT*10000.).OR. 2 IS2(7).NE.NINT(ORIENT*10000.))THEN CCCC WRITE(KFILDO,159)XLAT,ORIENT CCCC 159 FORMAT(' AT 159--XLAT,ORIENT',2F20.6) CCCC WRITE(KFILDO,123) CCCC WRITE(KFILDO,124)IS2(2),NPROJ,IS2(9),NINT(XLAT*10000.), CCCC 1 IS2(7),NINT(ORIENT*10000.), CCCC 2 IS2(3),IS2(4),NWORDS GO TO 170 C ON TRANSFER THE GRID CHARACTERISTICS DID NOT MATCH. ENDIF C C THE STATEMENTS FROM HERE TO 200 ARE FOR BOTH CORE AND DISK C STORAGE AND FOR EITHER PACKED OR UNPACKED DATA. C 160 NPACK=LSTORE(7,J) NTIMES=LSTORE(9,J)+1 NSLAB=LSTORE(10,J) LSTORE(9,J)=NTIMES IF(ITIME.LT.0.AND.LSTORE(12,J).EQ.0)LSTORE(12,J)=ITIME C**************** C THE ABOVE TEST ON LSTORE(12,J)=0 WAS ADDED FEB. 1, 1998 C FOR U850. IT HAS NOT BEEN TESTED WITH U201, U600, OR U660. C THE FOLLOWING STATEMENTS ARE USED FOR INITIALIZING LSTORE(11, ) IF(LOCPRD.LT.7777)THEN IF(LSTORE(11,J).EQ.7777.OR. 1 LSTORE(11,J).EQ.0)LSTORE(11,J)=LSTORE(11,J)+LOCPRD ELSE IF(LOCPRD.EQ.7777)THEN IF(LSTORE(11,J).LT.7777)LSTORE(11,J)=LSTORE(11,J)+LOCPRD ENDIF C C***D WRITE(KFILDO,164)NFETCH,LOCPRD,(LSTORE(L,J),L=1,12) C***D164 FORMAT(/' GFETCH4 '2I4,I11.9,2I10.9,I10.3,I8,I8,I2,I11,2I4,I5,I10) C***D WRITE(KFILDO,165)(IS1(JJ),JJ=1,22) C***D165 FORMAT(/' IN GFETCH4 AT 165--IS1( )'/(10I12)) C***D WRITE(KFILDO,166)(IS2(JJ),JJ=1,9) C***D166 FORMAT(/' IN GFETCH4 AT 166--IS2( )'/(9I12)) C***D WRITE(KFILDO,167)(DATA(JJ),JJ=1,30) C***D167 FORMAT(/' IN GFETCH4 AT 167--(DATA(JJ),JJ=1,30)'/(10F10.3)) C GO TO 200 C 170 CONTINUE C C A FALL THROUGH HERE MEANS DATA HAVE NOT BEEN FOUND. C IER=47 C DATA WERE NOT FETCHED. NWORDS=0 C SET NWORDS = 0 WHEN NO DATA RETURNED. NSLAB=0 C SET NSLAB = 0 WHEN NO DATA RETURNED. WRITE(KFILDO,175)(JD(J),J=1,4),LDATE,IER 175 FORMAT(' ****DATA NOT FOUND BY GFETCH4.', 1 ' LOOKING FOR',2X,I9.9,2I10.9,I11.3, 2 ' FOR DATE',I11,' IER =',I5) GO TO 180 C C NDX IS NOT LARGE ENOUGH TO HOLD THE DATA. THIS IS C A FATAL ERROR. C 176 WRITE(KFILDO,178)NDX,LWORDS,(JD(L),L=1,4) GO TO 179 C 177 WRITE(KFILDO,178)NDX,NWORDS,(JD(L),L=1,4) 178 FORMAT(/,' ****DIMENSION NDX =',I6,' NOT LARGE ENOUGH TO HOLD', 1 ' RECORD OF',I8,' WORDS.',/, 2 ' DATA NOT RETURNED BY GFETCH4. ID( ) =', 3 1X,I9.9,2I10.9,I11.3) 179 IER=48 C IER=48 SHOULD PROBABLY BE A FATAL ERROR. C 180 DO 190 M=1,NDX DATA(M)=9999. 190 CONTINUE C 200 CONTINUE C C***D IF(LITEMS.LT.10) C***D 1 WRITE(KFILDO,201)NFETCH,((LSTORE(L,J),L=1,12),J=1,LITEMS) C***D201 FORMAT(/' GFETCH4 ',I4,I11.9,2I10.9,I10.3,I8,I8,I2,I11,2I4,I5,I11/ C***D 1 (' ',I11.9,2I10.9,I10.3,I8,I8,I2,I11,2I4,I5,I11)) C***D WRITE(KFILDO,202)(LSTORE(M,J),M=1,12) C***D202 FORMAT(/' GFETCH4 AT 202 ',3I10.9,I10.3,I8,I8,I2,I11,2I4,I5,I11) C RETURN END