! Copyright (C) GFD Dennou Club, 2000. All rights reserved ! GrADS ファイルの機能を提供 module gr_file use dc_string, only: VSTRING implicit none ! 属性は単連結リストで表現。 type GR_ATTR_ENTRY character(len = 8):: var character(len = 72):: attr type(VSTRING):: value type(GR_ATTR_ENTRY), pointer:: next end type type GR_FILE_ENTRY integer:: id integer:: count logical:: writable type(VSTRING):: ctlfile type(VSTRING):: dsetfile type(GR_FILE_ENTRY), pointer:: next ! コントロールファイル情報 type(VSTRING):: title real:: undef ! 次元変数は4つだけ real, pointer:: lon(:) real, pointer:: lat(:) real, pointer:: lev(:) character(len = 16):: time_origin character(len = 2):: time_unit integer:: time_step integer:: time_count ! 変数表情報 integer:: nvars character(len = 8), pointer:: varname(:) type(VSTRING), pointer:: vardesc(:) integer, pointer:: levels(:) ! 属性表 type(GR_ATTR_ENTRY), pointer:: attr_table end type type(GR_FILE_ENTRY), save, pointer:: file_table_head logical, save:: file_table_used = .FALSE. contains subroutine GRFileName(fileid, result) use dc_string use dc_error integer, intent(in):: fileid type(VSTRING), intent(out):: result type(GR_FILE_ENTRY), pointer:: cursor if (.not. file_table_used) goto 999 cursor => file_table_head do if (.not. associated(cursor)) exit if (cursor%id == fileid) then result = cursor%ctlfile return endif cursor => cursor%next enddo 999 continue result = "" call StoreError(GR_ENOTGR, "GRFileName") end subroutine subroutine parse_ctl_file(grfile, filename, writable, mystat) implicit none type(GR_FILE_ENTRY), intent(out):: grfile character(len = *), intent(in):: filename logical, intent(in):: writable integer, intent(out):: mystat mystat = 0 grfile%count = 1 grfile%writable = writable grfile%ctlfile = filename end subroutine subroutine GRFileOpen(fileid, filename, writable, overwrite, stat, err) use dc_string use netcdf_f77 use dc_error use dcl, only: DclGetUnitNum implicit none integer, intent(out):: fileid character(len = *), intent(in):: filename logical, intent(in), optional:: writable logical, intent(in), optional:: overwrite logical, intent(out), optional:: err integer, intent(out), optional:: stat logical:: writable_required logical:: overwrite_required type(GR_FILE_ENTRY), pointer:: cursor, prev integer:: mystat integer:: recl character(len = 7):: new character(len = 256):: dsetname continue ! ! オプション操作 ! writable_required = .FALSE. if (present(writable)) writable_required = writable if (present(overwrite)) then writable_required = .TRUE. overwrite_required = overwrite else overwrite_required = .FALSE. endif ! ! 同じ名前で書込み可能性も適合していれば open しないで済ませる ! if (file_table_used) then cursor => file_table_head nullify(prev) do if ((cursor%ctlfile == filename) & .and. (cursor%writable .or. .not. writable_required)) & then fileid = cursor%id cursor%count = cursor%count + 1 if (present(err)) err = .FALSE. return endif prev => cursor cursor => cursor%next if (.not. associated(cursor)) exit enddo allocate(cursor) prev%next => cursor else nullify(prev) allocate(file_table_head) cursor => file_table_head file_table_used = .TRUE. endif ! ! ファイル表の新しく確保したエントリに書き込む ! nullify(cursor%next, cursor%lat, cursor%lon, cursor%lev) call parse_ctl_file(cursor, filename, writable_required, mystat) if (mystat /= 0) goto 900 dsetname = cursor%dsetfile inquire(iolength=recl) 0.0 cursor%id = DclGetUnitNum() if (.not. writable_required) then open(unit=cursor%id, file=dsetname, access="DIRECT", & recl=recl, form="UNFORMATTED", status="OLD", & action="READ", iostat=mystat) else open(unit=cursor%id, file=dsetname, access="DIRECT", & recl=recl, form="UNFORMATTED", status="OLD", & action="READWRITE", iostat=mystat) if (mystat /= 0) then new = "NEW" if (overwrite_required) new = "REPLACE" open(unit=cursor%id, file=dsetname, access="DIRECT", & recl=recl, form="UNFORMATTED", status=new, & action="READWRITE", iostat=mystat) endif endif fileid = cursor%id 900 continue ! 失敗したら GR_FILE 表から消しておく if (mystat /= 0) then if (associated(prev)) then prev%next => cursor%next else file_table_head => cursor%next if (.not. associated(file_table_head)) file_table_used = .FALSE. endif deallocate(cursor) fileid = -1 endif if (present(stat)) then stat = mystat if (present(err)) err = (stat /= 0) else if (present(err)) then err = (stat /= 0) else call StoreError(mystat, 'GrFileOpen', err, cause_c=trim(filename)) endif end subroutine end module