7f90924706
Former-commit-id:7fa9dbd5fb[formerly4bfbdad17d] [formerly9f8cb727a5] [formerly7fa9dbd5fb[formerly4bfbdad17d] [formerly9f8cb727a5] [formerly8485b90ff8[formerly9f8cb727a5[formerly bf53d06834caa780226121334ac1bcf0534c3f16]]]] Former-commit-id:8485b90ff8Former-commit-id:40aa780b3d[formerly33a67cdd82] [formerly 73930fb29d0c1e91204e76e6ebfdbe757414f319 [formerlya28d70b5c5]] Former-commit-id: a16a1b4dd44fc344ee709abbe262aeed58a8339b [formerlye5543a0e86] Former-commit-id:0c25458510
143 lines
5 KiB
Fortran
143 lines
5 KiB
Fortran
SUBROUTINE GD_OPEN ( ffnam, wrtfg, mxanl, mxnav, iacss,
|
|
+ bkanl, bknav, mxgrd, iret )
|
|
C************************************************************************
|
|
C* GD_OPEN *
|
|
C* *
|
|
C* This subroutine opens a managed grid file. *
|
|
C* *
|
|
C* This subroutine manages the available DM file slots. GD_OPEN should *
|
|
C* be called before any operation is done on a file. If GD_OPEN has *
|
|
C* been called for a different file previously, then GD_OPEN should be *
|
|
C* called again even if GD_OPEN has been called before for the same *
|
|
C* file. Good practice is to always call GD_OPEN before accessing a *
|
|
C* file. *
|
|
C* *
|
|
C* GD_OPEN ( FFNAM, WRTFG, MXANL, MXNAV, IACSS, BKANL, BKNAV, *
|
|
C* MXGRD, IRET ) *
|
|
C* *
|
|
C* Input parameters: *
|
|
C* FFNAM CHAR* Fully qualified file name *
|
|
C* WRTFG LOGICAL Flag set true if write needed *
|
|
C* MXANL INTEGER Number of analysis block return *
|
|
C* MXNAV INTEGER NUmber of nav block return *
|
|
C* *
|
|
C* Output parameters: *
|
|
C* IACSS INTEGER Access number to do I/O on file *
|
|
C* BKANL (MXANL) REAL Analysis block data array *
|
|
C* BKNAV (MXNAV) REAL Navigation block data array *
|
|
C* MXGRD INTEGER Maximum number of grids *
|
|
C* IRET INTEGER Return code *
|
|
C* 0 = normal return *
|
|
C* -14 = file name is blank *
|
|
C* -17 = file number limit reached *
|
|
C** *
|
|
C* Log: *
|
|
C* R. Tian/SAIC 1/04 *
|
|
C* R. Tian/SAIC 3/04 Recoded *
|
|
C* R. Tian/SAIC 3/05 Added mgrid *
|
|
C************************************************************************
|
|
INCLUDE 'GEMPRM.PRM'
|
|
INCLUDE 'GMBDTA.CMN'
|
|
INCLUDE 'grdcmn.cmn'
|
|
C
|
|
CHARACTER*(*) ffnam
|
|
LOGICAL wrtfg
|
|
REAL bkanl (*), bknav (*)
|
|
C*
|
|
LOGICAL avail, shrfg
|
|
REAL rnvblk (LLNNAV), anlblk (LLNANL)
|
|
CHARACTER message*720, funcnm*8, loglevel*6
|
|
C------------------------------------------------------------------------
|
|
loglevel = "debug"
|
|
funcnm="GD_OPEN"
|
|
CALL ST_NULL ( funcnm, funcnm, lenq, ier )
|
|
CALL ST_NULL ( loglevel, loglevel, lenq, ier )
|
|
message = "ffnam=" // ffnam
|
|
CALL ST_NULL ( message, message, lenq, ier )
|
|
CALL DB_MSGCAVE ( funcnm, loglevel, message, ier )
|
|
iret = 0
|
|
iacss = 0
|
|
mxgrd = 0
|
|
nucode = .true.
|
|
shrfg = .false.
|
|
C
|
|
C* Check for blank file name.
|
|
C
|
|
IF ( ffnam .eq. ' ' ) THEN
|
|
iret = -14
|
|
RETURN
|
|
END IF
|
|
C
|
|
C* Check if the file has already been opened.
|
|
C
|
|
avail = .false.
|
|
DO i = 1, MMFILE
|
|
IF ( ffnam .eq. gdflnm (i) ) THEN
|
|
igdfln = i
|
|
iacss = iflacc (i)
|
|
avail = .true.
|
|
END IF
|
|
END DO
|
|
WRITE (message, 1001 ) avail
|
|
1001 FORMAT ("avail=", L1 )
|
|
CALL ST_NULL ( message, message, lenq, ier )
|
|
CALL DB_MSGCAVE ( funcnm, loglevel, message, ier )
|
|
C
|
|
C* Try to open the file if it is not opened.
|
|
C
|
|
IF ( .not. avail ) THEN
|
|
ier2 = 0
|
|
CALL GD_OFIL ( ffnam, wrtfg, shrfg, igdfln, navsz,
|
|
+ rnvblk, ianlsz, anlblk, ihdrsz,
|
|
+ mxgrd, ier1 )
|
|
|
|
|
|
C
|
|
C* MMFILE files have been opened, close the least recently
|
|
C* used file and open again.
|
|
C
|
|
IF ( ier1 .eq. -15 ) THEN
|
|
ier1 = 0
|
|
ismlst = MXFLNM
|
|
DO i = 1, MMFILE
|
|
IF ( iflacc(i) .ne. 0 .and. iflacc(i) .lt. ismlst )
|
|
+ THEN
|
|
ismlst = iflacc (i)
|
|
END IF
|
|
END DO
|
|
CALL GD_CLOS ( ismlst, ier )
|
|
CALL GD_OFIL ( ffnam, wrtfg, shrfg, igdfln, navsz,
|
|
+ rnvblk, ianlsz, anlblk, ihdrsz,
|
|
+ mxgrd, ier2 )
|
|
END IF
|
|
IF ( ier1 .ne. 0 .or. ier2 .ne. 0 ) THEN
|
|
iret = -2
|
|
RETURN
|
|
END IF
|
|
C
|
|
mgrid (igdfln) = mxgrd
|
|
nflnum = nflnum + 1
|
|
IF ( nflnum .gt. MXFLNM ) THEN
|
|
iret = -17
|
|
RETURN
|
|
END IF
|
|
iflacc ( igdfln ) = nflnum
|
|
gdflnm ( igdfln ) = ffnam
|
|
iacss = nflnum
|
|
END IF
|
|
C
|
|
mxgrd = mgrid (igdfln)
|
|
IF ( mxanl .gt. 0 ) THEN
|
|
DO i = 1, MIN ( mxanl, LLNANL )
|
|
bkanl (i) = savanl (i,igdfln)
|
|
END DO
|
|
END IF
|
|
C
|
|
IF ( mxnav .gt. 0 ) THEN
|
|
DO i = 1, MIN (mxnav, LLNNAV )
|
|
bknav (i) = savnav (i,igdfln)
|
|
END DO
|
|
END IF
|
|
C*
|
|
RETURN
|
|
END
|