C get5d.f C C SUBROUTINE GET5D C Read a McIDAS GR3Dnnnn file to obtain the COMMON/JTIME info C including grid size, parameters, time steps, etc. C include "vis5d.h" PARAMETER (IHSIZE=64) CHARACTER*8 FILNAM CHARACTER*4 CLIT INTEGER ITABLE(64),IHEAD(64) COMMON/JTIME/NTIMES,NPARMS,MR,MC,ML, * XLATN,XLONW,XHGTT,XLATIN,XLONIN,XHGTIN, * JDAY(NTIME),JTIME(NTIME),JPARM(NPARM) COMMON/NGRID/IGRIDF,NGRIDF,NGRID(NFILE) C C INITIALIZE GRID POINTERS IF (NGRIDF .GT. NFILE) GO TO 94 KGRIDF = IGRIDF LGRIDF = IGRIDF+NGRIDF-1 IGRID=1 ITIME=1 IPARM=1 C C READ FIRST GRID DIRECTORY (ACCESS CODE COPIED FROM IGPT3D) IF (IGOP3D(KGRIDF,FILNAM) .NE. 0) GOTO 99 I=LWI(FILNAM,0,64,IHEAD) NGRIDS=IHEAD(12) C IF(LWI(FILNAM,IGRID*IHSIZE,IHSIZE,ITABLE) .NE. 0) GO TO 99 ISIZE=ITABLE(1) IF(ISIZE .LT. 1 .OR. ISIZE .GT. 20000000) GOTO 98 C GET GRID DESCRIPTION TO MATCH TO DATA SET MR=ITABLE(2) MC=ITABLE(3) ML=ITABLE(4) IF(MR .LT. 1) GOTO 98 C ITYPE=ITABLE(22) IF(ITYPE .NE. 1 .AND. ITYPE .NE. 4) GO TO 98 XLATN=ITABLE(23)/10000.0 XLONW=ITABLE(24)/10000.0 XLATIN=ITABLE(25)/10000.0 ILONIN=26 IF(ITYPE .EQ. 1) ILONIN=25 XLONIN=ITABLE(ILONIN)/10000.0 IHTYPE=ITABLE(31) IF(IHTYPE .NE. 1) GO TO 98 XHGTT=ITABLE(32)/1000.0 XHGTIN=ITABLE(33)/1000.0 C XLATS=XLATN-(MR-1)*XLATIN XLONE=XLONW-(MC-1)*XLONIN XHGTB=XHGTT-(ML-1)*XHGTIN C C RECORD TIME AND PARAM OF FIRST GRID IDAYL=IDAYS(ITABLE(6)) ITIMEL=ISECS(ITABLE(7)) JDAY(ITIME)=IDAYL JTIME(ITIME)=ITIMEL JPARM(IPARM)=ITABLE(9) C C GET GRIDS IN FIRST TIME SET 10 IGRID=IGRID+1 IF(IGRID .LE. NGRIDS) GO TO 30 20 KGRIDF = KGRIDF+1 II = KGRIDF-IGRIDF NGRID(II) = IGRID-1 IF (KGRIDF .GT. LGRIDF) GO TO 70 IF (IGOP3D(KGRIDF,FILNAM) .NE. 0) GOTO 99 I = LWI(FILNAM,0,64,IHEAD) NGRIDS = IHEAD(12) IGRID = 1 30 IF (LWI(FILNAM,IGRID*IHSIZE,IHSIZE,IHEAD) .NE. 0) GO TO 20 IF (IHEAD(1) .LT. 0) GO TO 20 C IF (IDAYL .NE. IDAYS(IHEAD(6)) .OR. * ITIMEL .NE. ISECS(IHEAD(7)) ) GO TO 100 C C MR, MC & ML MATCH? DO 40 J=2,4 40 IF(IHEAD(J) .NE. ITABLE(J)) GO TO 97 C C XLAT & XLON MATCH? DO 50 J=22,ILONIN 50 IF(IHEAD(J) .NE. ITABLE(J)) GO TO 97 C C XHGT MATCH? DO 60 J=31,33 60 IF(IHEAD(J) .NE. ITABLE(J)) GO TO 97 C IPARM=IPARM+1 IF(IPARM .GT. NPARM) GO TO 93 JPARM(IPARM)=IHEAD(9) GO TO 10 70 NPARMS=IPARM NTIMES=1 RETURN C C NOW GET SUCCEEDING TIME SETS 100 NPARMS=IPARM CALL SCOUT('IDAYL',IDAYL,ITIMEL,IDAYS(IHEAD(6)), * ISECS(IHEAD(7)),0,0) CALL LDEST('NPARMS = ',NPARMS) DO 80 I=1,NPARMS 80 CALL LDEST(CLIT(JPARM(I)),I) IGRID=IGRID-1 110 ITIME=ITIME+1 IF(ITIME .GT. NTIME) GO TO 92 DO 200 IP=1,NPARMS IGRID=IGRID+1 IF(IGRID .LE. NGRIDS) GO TO 130 120 KGRIDF=KGRIDF+1 II=KGRIDF-IGRIDF NGRID(II)=IGRID-1 IF(KGRIDF .GT. LGRIDF) GO TO 210 IF (IGOP3D(KGRIDF,FILNAM) .NE. 0) GOTO 99 I=LWI(FILNAM,0,64,IHEAD) NGRIDS=IHEAD(12) IGRID=1 130 IF(LWI(FILNAM,IGRID*IHSIZE,IHSIZE,IHEAD) .NE. 0) GO TO 120 IF(IHEAD(1) .LE. 0) GO TO 120 C C RECORD AND CHECK TIME IF(IP .GT. 1) GO TO 140 JDAY(ITIME)=IDAYS(IHEAD(6)) JTIME(ITIME)=ISECS(IHEAD(7)) IF( JDAY(ITIME) .LT. JDAY(ITIME-1) .OR. * (JDAY(ITIME) .EQ. JDAY(ITIME-1) .AND. * JTIME(ITIME) .LE. JTIME(ITIME-1) ) ) GO TO 96 GO TO 150 140 IF(JDAY(ITIME) .NE. IDAYS(IHEAD(6)) .OR. * JTIME(ITIME) .NE. ISECS(IHEAD(7)) ) GO TO 100 C PARAMETER MATCH? 150 IF(JPARM(IP) .NE. IHEAD(9)) GO TO 95 C C MR, MC & ML MATCH? DO 160 J=2,4 160 IF(IHEAD(J) .NE. ITABLE(J)) GO TO 97 C XLAT & XLON MATCH? DO 170 J=22,ILONIN 170 IF(IHEAD(J) .NE. ITABLE(J)) GO TO 97 C XHGT MATCH? DO 180 J=31,33 180 IF(IHEAD(J) .NE. ITABLE(J)) GO TO 97 200 NTIMES=ITIME GO TO 110 210 CONTINUE CALL DOUBT('JDAY',NTIMES,JDAY) CALL DOUBT('JTIME',NTIMES,JTIME) CALL DOUBT('NGRID',NFILE,NGRID) RETURN C 92 CALL EDEST('TOO MANY TIME STEPS ',0) CALL EXIT(0) 93 CALL EDEST('TOO MANY PARAMETERS ',0) CALL EXIT(0) 94 CALL EDEST('TOO MANY GRID FILES ',0) CALL EXIT(0) 95 CALL EDEST('PARAMETERS DO NOT MATCH ',0) CALL SDEST(CLIT(JPARM(IP))//' '//CLIT(ITABLE(9)),IP) CALL SDEST('ITIME',ITIME) CALL EXIT(0) 96 CALL EDEST('GRID TIMES OUT OF ORDER ',0) CALL SCOUT('ITIME',ITIME,JDAY(ITIME),JTIME(ITIME), * JDAY(ITIME-1),JTIME(ITIME-1),IP) CALL EXIT(0) 97 CALL EDEST('GRIDS DO NOT MATCH ',0) CALL SCOUT('JGRIDF',JGRIDF,IGRID,NSETS,ISETD,ISET,I) CALL SCOUT('MR',MR,MC,ML,JGRID,KGRID,IRES) CALL SCOUT('KDAYL',KDAY,JDAYL,KTIMEL,JTIMEL,IGRIDF,0) CALL DOUBT('IHEAD',64,IHEAD) CALL DOUBT('ITABLE',64,ITABLE) CALL EXIT(0) 98 CALL EDEST('BAD GRID SIZE OR TYPE ',0) CALL SCOUT('ISIZE',ISIZE,MR,ITYPE,IHTYPE,MC,ML) CALL EXIT(0) 99 CALL EDEST('BAD GRID FILE READ ',0) CALL EXIT(0) RETURN END C C C C C SUBROUTINE GETGRD(IT,IP,NPARMI,GRID,MRMCML) C Get a single 3-D grid from a grid file. The grid file is C specified by the info in the COMMON/NGRID block. C Input: IT - the time step of the 3-D grid. C IP - the parameter number of the 3-D grid. C NPARMI - the number of parameters in the grid file. C GRID - array to put the 3-D grid into. C MRMCML - size of the GRID array. C Output: GRID - this array will be loaded with the 3-D grid data. C include "vis5d.h" C REAL*4 GRID(*) C COMMON/JTIME/NTIMES,NPARMS,MR,MC,ML, * XLATN,XLONW,XHGTT,XLATIN,XLONIN,XHGTIN, * JDAY(NTIME),JTIME(NTIME),JPARM(NPARM) C COMMON/NGRID/IGRIDF,NGRIDF,NGRID(NFILE) C INTEGER ITAB(64) C JGRID = NPARMI*(IT-1)+IP DO 30 IFILE=1,NGRIDF IF (JGRID .GT. NGRID(IFILE)) GO TO 30 JGRIDF = IGRIDF+IFILE-1 ISTAT = IGGT3D(JGRIDF,JGRID,MRMCML,GRID,KR,KC,KL,ITAB) IF (ISTAT .NE. 0) GOTO 99 CALL SCOUT('GETGRD',IT,IP,JGRIDF,JGRID,MRMCML,IFILE) RETURN 30 JGRID = JGRID-NGRID(IFILE) CALL SDEST('GETGRD BOMB ',0) CALL SCOUT('SHARDS',IT,IP,JGRIDF,JGRID,NPARMI,IFILE) CALL EXIT(0) 99 CALL SDEST('IGGT3D FAILURE',0) CALL EXIT(0) END