! Copyright (C) GFD Dennou Club, 2000. All rights reserved module an_file use dc_types, only: string use dc_trace, only: beginsub, endsub, DbgMessage implicit none private type FILE_MEMO_ENTRY integer:: id integer:: count logical:: writable character(len = string):: filename type(FILE_MEMO_ENTRY), pointer:: next end type type(FILE_MEMO_ENTRY), save, pointer:: memo_head logical, save:: memo_used = .FALSE. public:: ANFileOpen, ANFileClose, ANFileReopen public:: ANFileDataMode, ANFileDefineMode, ANFileSync public:: Inquire ! 非公開なので an_generic には置かない interface inquire subroutine ANAttrInquirePlus(var, attrname, varid, nf_attrname) use an_types, only: AN_VARIABLE type(AN_VARIABLE), intent(in):: var character(len=*), intent(in):: attrname integer, intent(out):: varid character(len=*), intent(out):: nf_attrname end subroutine module procedure anfileinquirename end interface contains subroutine anfileinquirename(fileid, name) use netcdf_f77, only: NF_ENOTNC use dc_error integer, intent(in):: fileid character(len = *), intent(out):: name type(FILE_MEMO_ENTRY), pointer:: memop continue call beginsub('anfilename', 'fileid=%d', i=(/fileid/)) if (.not. memo_used) goto 999 memop => memo_head do if (.not. associated(memop)) exit if (memop%id == fileid) then name = memop%filename call endsub('anfilename', 'name=<%c>', c1=trim(name)) return endif memop => memop%next enddo 999 continue call StoreError(NF_ENOTNC, "ANFileName") call endsub('anfilename', 'err') end subroutine subroutine ANFileSync(fileid, stat) use netcdf_f77, only: nf_sync, NF_NOERR use dc_error integer, intent(in), optional:: fileid integer, intent(out), optional:: stat integer:: ncid, mystat type(FILE_MEMO_ENTRY), pointer:: memop mystat = NF_NOERR if (present(fileid)) then ncid = fileid mystat = ANFileDataMode(ncid) if (mystat /= NF_NOERR) goto 999 mystat = nf_sync(ncid) else if (memo_used) then memop => memo_head do if (.not. associated(memop)) exit ncid = memop%id mystat = ANFileDataMode(ncid) if (mystat /= NF_NOERR) exit mystat = nf_sync(ncid) if (mystat /= NF_NOERR) exit memop => memop%next enddo endif 999 continue ! 自発的には StoreError しない。StoreError の SysdepAbort ! からも呼ばれる可能性があるためである。 if (present(stat)) stat = mystat end subroutine subroutine ANFileOpen(fileid, filename, writable, overwrite, stat, err) use netcdf_f77, only: NF_WRITE, NF_NOWRITE, NF_ENOTNC, & NF_NOERR, NF_NOCLOBBER, NF_CLOBBER, NF_OPEN, NF_CREATE use dc_error, only: StoreError implicit none integer, intent(out):: fileid character(len = *), intent(in):: filename logical, intent(in), optional:: writable ! .TRUE. は上書モード .FALSE. は読込モード. ! - 上書モードでファイルが存在する場合エラーとする. ! - 読込モードでファイルが存在しない場合エラーとする. logical, intent(in), optional:: overwrite logical, intent(out), optional:: err integer, intent(out), optional:: stat logical:: writable_required logical:: overwrite_required type(FILE_MEMO_ENTRY), pointer:: memop, prev integer:: mystat, mode character(len = 256):: real_filename continue ! ! オプションの解釈 ! writable_required = .FALSE. if (present(writable)) writable_required = writable if (present(overwrite)) then overwrite_required = overwrite if (overwrite) writable_required = .TRUE. else overwrite_required = .FALSE. endif call beginsub('anfileopen', 'writable=%y overwrite=%y file=%c', & & L=(/writable_required, overwrite_required/), c1=trim(filename)) ! ! 同じ名前で書込み可能性も適合していれば nf_open しないで済ませる ! if (memo_used) then memop => memo_head nullify(prev) do if ((memop%filename == filename) & .and. (memop%writable .or. .not. writable_required)) then fileid = memop%id memop%count = memop%count + 1 if (present(err)) err = .FALSE. if (present(stat)) stat = NF_NOERR call endsub('anfileopen', 'id=%d', i=(/fileid/)) return endif prev => memop memop => memop%next if (.not. associated(memop)) exit enddo allocate(memop) prev%next => memop else nullify(prev) allocate(memo_head) memop => memo_head memo_used = .TRUE. endif nullify(memop%next) memop%filename = filename memop%writable = writable_required memop%count = 1 ! ! URL の部分的サポート ! real_filename = filename if (real_filename(1:8) == 'file:///') then real_filename = real_filename(8: ) else if (real_filename(1:5) == 'file:' .AND. real_filename(6:6) /= '/') then real_filename = real_filename(6: ) endif ! ! いざ nf_open ! mode = NF_NOWRITE if (writable_required) mode = ior(mode, NF_WRITE) ! 既に nc ファイルがあると思って開けてみる mystat = nf_open(real_filename, mode, memop%id) ! ! ファイルがある場合 ! if (mystat == NF_NOERR) then ! 上書きモードの場合 if (overwrite_required) then mode = NF_NOCLOBBER mystat = nf_create(real_filename, mode, memop%id) ! ファイルが既に存在している場合, エラーコードが返るので, ! そのエラーコードを用いて終了 if (present(err)) err = (mystat /= NF_NOERR) call StoreError(mystat, 'ANFileOpen', err, cause_c=filename) ! 読み込みモードの場合は何もしない endif ! ! ファイルが無かった場合 ! else ! 読み込みモードの場合 if (.not. overwrite_required) then ! 「無いよ」とエラーを吐いて終了 if (present(err)) err = (mystat /= NF_NOERR) call StoreError(mystat, 'ANFileOpen', err, cause_c=filename) ! 書き込みモードの場合 else mode = NF_CLOBBER ! ファイルを作成する mystat = nf_create(real_filename, mode, memop%id) if (present(err)) err = (mystat /= NF_NOERR) call StoreError(mystat, 'ANFileOpen', err, cause_c=filename) endif endif fileid = memop%id ! 失敗したら消しておく if (mystat /= NF_NOERR) then if (associated(prev)) then prev%next => memop%next else memo_head => memop%next if (.not. associated(memo_head)) memo_used = .FALSE. endif deallocate(memop) fileid = -1 endif if (present(stat)) then stat = mystat if (present(err)) err = (stat /= NF_NOERR) else call StoreError(mystat, 'ANFileOpen', err, cause_c=filename) endif call endsub('anfileopen', 'id=%d stat=%d', i=(/fileid, mystat/)) end subroutine ! 同じファイル番号の参照カウントを増加する。 subroutine ANFileReopen(fileid, err) use netcdf_f77 use dc_error, only: StoreError implicit none integer, intent(in):: fileid logical, intent(out), optional:: err type(FILE_MEMO_ENTRY), pointer:: memop continue call beginsub('anfilereopen', 'file=%d', i=(/fileid/)) if (memo_used) then memop => memo_head do if (memop%id == fileid) then memop%count = memop%count + 1 if (present(err)) err = .FALSE. call endsub('anfilereopen', 'count=%d', i=(/memop%count/)) return endif memop => memop%next if (.not. associated(memop)) exit enddo endif call StoreError(NF_ENOTNC, 'ANFileReopen', err, cause_i=fileid) call endsub('anfilereopen', 'err') end subroutine ! おなじ id のファイルの参照カウンタを減算し、ゼロになったら閉じる subroutine ANFileClose(fileid, err) use netcdf_f77, only: NF_CLOSE, NF_ENOTNC, NF_NOERR use dc_error, only: StoreError integer, intent(in):: fileid logical, intent(out), optional:: err type(FILE_MEMO_ENTRY), pointer:: memop, prev integer:: stat continue call beginsub('anfileclose') stat = NF_ENOTNC if (.not. memo_used) goto 999 memop => memo_head nullify(prev) do if (.not. associated(memop)) goto 999 if (memop%id == fileid) exit prev => memop memop => memop%next enddo memop%count = memop%count - 1 if (memop%count <= 0) then stat = nf_close(fileid) if (associated(prev)) then prev%next => memop%next else memo_head => memop%next if (.not. associated(memo_head)) memo_used = .FALSE. endif call DbgMessage('anfileclose: <%c> closed', c1=trim(memop%filename)) deallocate(memop) else call DbgMessage('anfileclose: %d<%c> skipped for refcount=%d', & & c1=trim(memop%filename), i=(/fileid, memop%count/)) stat = NF_NOERR endif 999 continue call endsub('anfileclose') call StoreError(stat, 'ANFileClose', err) end subroutine integer function ANFileDefineMode(fileid) result(result) use netcdf_f77, only: nf_redef, NF_EINDEFINE, NF_NOERR integer, intent(in):: fileid call DbgMessage('anfiledefinemode %d', i=(/fileid/)) result = nf_redef(fileid) if (result == NF_EINDEFINE) result = NF_NOERR end function integer function ANFileDataMode(fileid) result(result) use netcdf_f77, only: nf_enddef, NF_ENOTINDEFINE, NF_NOERR integer, intent(in):: fileid call DbgMessage('anfiledefinemode') result = nf_enddef(fileid) if (result == NF_ENOTINDEFINE) result = NF_NOERR end function end module an_file