|
XBeach
|
00001 module filefunctions 00002 use typesandkinds, only: slen 00003 use xmpi_module, only: xmaster 00004 use paramsconst 00005 implicit none 00006 private 00007 public create_new_fid, checkbcfilelength, get_file_length, check_file_exist, check_file_length 00008 save 00009 interface check_file_length 00010 module procedure check_file_length_1D 00011 module procedure check_file_length_2D 00012 module procedure check_file_length_3D 00013 end interface check_file_length 00014 contains 00015 00016 integer function create_new_fid() 00017 use xmpi_module, only: halt_program 00018 use logging_module, only: writelog 00019 00020 integer :: fileunit 00021 00022 fileunit = -1 ! temporary 00023 fileunit = create_new_fid_generic() 00024 if (fileunit==-1) then 00025 call writelog('les','','Serious problem: not enough free unit ids to create new file') 00026 call halt_program 00027 endif 00028 create_new_fid = fileunit 00029 end function create_new_fid 00030 00031 subroutine check_file_exist(filename,exist,forceclose) 00032 use xmpi_module, only: halt_program 00033 use logging_module, only: writelog 00034 00035 implicit none 00036 00037 character(*) :: filename 00038 logical,intent(out),optional :: exist 00039 logical,intent(in), optional :: forceclose 00040 logical :: endsim 00041 integer :: error 00042 00043 if (present(forceclose)) then 00044 endsim = forceclose 00045 else 00046 endsim = .true. 00047 endif 00048 00049 error = 0 00050 if (xmaster) call check_file_exist_generic(filename,error) 00051 00052 if (error==1 .and. endsim) then 00053 if (xmaster) then 00054 call writelog('sle','','File ''',trim(filename),''' not found. Terminating simulation') 00055 endif 00056 call halt_program 00057 endif 00058 00059 if (present(exist)) then 00060 if (error==1) then 00061 exist = .false. 00062 else 00063 exist = .true. 00064 endif 00065 endif 00066 end subroutine check_file_exist 00067 00068 00069 00070 subroutine check_file_length_1D(fname,d1) 00071 use xmpi_module, only: halt_program 00072 use logging_module, only: writelog 00073 00074 implicit none 00075 character(*) :: fname 00076 integer, intent(in) :: d1 00077 integer :: fid,iost 00078 integer :: i 00079 real,dimension(:),allocatable :: dat 00080 00081 if (xmaster) then 00082 allocate(dat(d1)) 00083 fid = create_new_fid() 00084 open(fid,file=trim(fname)) 00085 read(fid,*,iostat=iost)(dat(i),i=1,d1) 00086 if (iost .ne. 0) then 00087 call writelog('sle','','Error processing file ''',trim(fname),'''. File may be too short or contains invalid values.', & 00088 ' Terminating simulation' ) 00089 call halt_program 00090 endif 00091 close(fid) 00092 deallocate(dat) 00093 endif 00094 00095 end subroutine check_file_length_1D 00096 00097 subroutine check_file_length_2D(fname,d1,d2) 00098 use xmpi_module, only: halt_program 00099 use logging_module, only: writelog 00100 00101 implicit none 00102 character(*) :: fname 00103 integer, intent(in) :: d1,d2 00104 integer :: fid,iost 00105 integer :: i,j 00106 real,dimension(:,:),allocatable :: dat 00107 00108 00109 if (xmaster) then 00110 allocate(dat(d1,d2)) 00111 fid = create_new_fid() 00112 open(fid,file=trim(fname)) 00113 read(fid,*,iostat=iost)((dat(i,j),i=1,d1),j=1,d2) 00114 if (iost .ne. 0) then 00115 call writelog('sle','','Error processing file ''',trim(fname),'''. File may be too short or contains invalid values.',& 00116 ' Terminating simulation') 00117 call halt_program 00118 endif 00119 close(fid) 00120 deallocate(dat) 00121 endif 00122 end subroutine check_file_length_2D 00123 00124 subroutine check_file_length_3D(fname,d1,d2,d3) 00125 use xmpi_module, only: halt_program 00126 use logging_module, only: writelog 00127 00128 implicit none 00129 character(*) :: fname 00130 integer, intent(in) :: d1,d2,d3 00131 integer :: fid,iost 00132 integer :: i,j,k 00133 real,dimension(:,:,:),allocatable :: dat 00134 00135 00136 if (xmaster) then 00137 allocate(dat(d1,d2,d3)) 00138 fid = create_new_fid() 00139 open(fid,file=trim(fname)) 00140 read(fid,*,iostat=iost)(((dat(i,j,k),i=1,d1),j=1,d2),k=1,d3) 00141 if (iost .ne. 0) then 00142 call writelog('esl','Error processing file ''',trim(fname),'''. File may be too short or contains invalid values.', & 00143 ' Terminating simulation') 00144 call halt_program 00145 endif 00146 close(fid) 00147 deallocate(dat) 00148 endif 00149 end subroutine check_file_length_3D 00150 00151 subroutine checkbcfilelength(tstop,wbctype,filename,filetype,nonh) 00152 use logging_module, only: writelog, report_file_read_error 00153 use xmpi_module, only: halt_program 00154 00155 IMPLICIT NONE 00156 type fileinfo 00157 character(slen) :: fname 00158 integer :: nlines 00159 end type 00160 00161 real*8, intent(in) :: tstop 00162 integer, intent(in):: wbctype 00163 character(slen) :: filename,dummy 00164 character(slen) :: testc 00165 character(len=1) :: ch 00166 integer :: i,ier=0,nlines,filetype,fid,nlocs,ifid,fid2 00167 real*8 :: t,dt,total,d1,d2,d3,d4,d5 00168 type(fileinfo),dimension(:),allocatable :: bcfiles 00169 logical,intent(in),optional :: nonh 00170 logical :: lnonh 00171 00172 if (present(nonh)) then 00173 lnonh=nonh 00174 else 00175 lnonh = .false. 00176 endif 00177 00178 if (xmaster) then 00179 ier = 0 00180 fid = create_new_fid() 00181 open(fid,file=trim(filename)) 00182 i=0 00183 do while (ier==0) 00184 read(fid,'(a)',iostat=ier)ch 00185 if (ier==0)i=i+1 00186 enddo 00187 nlines=i 00188 rewind(fid) 00189 00190 ! test for multiple locations setting 00191 read(fid,*,iostat=ier)testc 00192 if (ier .ne. 0) then 00193 call report_file_read_error(filename) 00194 endif 00195 ! wwvv fid2 was not initialized, so: 00196 fid2=create_new_fid() 00197 if (trim(testc)=='LOCLIST') then 00198 nlocs = nlines-1 00199 allocate(bcfiles(nlocs)) 00200 do ifid = 1,nlocs 00201 read(fid,*,iostat=ier)d1,d2,bcfiles(ifid)%fname 00202 if (ier .ne. 0) then 00203 call report_file_read_error(filename) 00204 endif 00205 call check_file_exist(trim(bcfiles(ifid)%fname)) 00206 open(fid2,file=trim(bcfiles(ifid)%fname)) 00207 i=0 00208 ier = 0 00209 do while (ier==0) 00210 read(fid2,'(a)',iostat=ier)ch 00211 if (ier==0)i=i+1 00212 enddo 00213 close(fid2) 00214 bcfiles(ifid)%nlines=i 00215 enddo 00216 else 00217 nlocs = 1 00218 allocate(bcfiles(1)) 00219 bcfiles(1)%fname = filename 00220 bcfiles(1)%nlines = nlines 00221 endif 00222 close(fid) 00223 00224 do ifid=1,nlocs 00225 fid = create_new_fid() 00226 open(fid,file=trim(bcfiles(ifid)%fname)) 00227 if (wbctype==WBCTYPE_PARAMETRIC .or. wbctype==WBCTYPE_SWAN .or. wbctype==WBCTYPE_VARDENS) then 00228 read(fid,*,iostat=ier)testc 00229 if (ier .ne. 0) then 00230 call report_file_read_error(bcfiles(ifid)%fname) 00231 endif 00232 if (trim(testc)=='FILELIST') then 00233 filetype = 1 00234 bcfiles(ifid)%nlines=bcfiles(ifid)%nlines-1 00235 else 00236 filetype = 0 00237 endif 00238 elseif (wbctype==WBCTYPE_JONS_TABLE) then 00239 filetype = 2 00240 elseif (wbctype==WBCTYPE_REUSE) then 00241 filetype = 3 00242 endif 00243 00244 total=0.d0 00245 i=0 00246 select case (filetype) 00247 case(0) 00248 total=2.d0*tstop 00249 case(1) 00250 do while (total<tstop .and. i<bcfiles(ifid)%nlines) 00251 read(fid,*,iostat=ier)t,dt,dummy 00252 if (ier .ne. 0) then 00253 call report_file_read_error(bcfiles(ifid)%fname) 00254 endif 00255 total=total+t 00256 i=i+1 00257 call check_file_exist(trim(dummy)) 00258 enddo 00259 case(2) 00260 do while (total<tstop .and. i<bcfiles(ifid)%nlines) 00261 read(fid,*,iostat=ier)d1,d2,d3,d4,d5,t,dt 00262 if (ier .ne. 0) then 00263 call report_file_read_error(bcfiles(ifid)%fname) 00264 endif 00265 total=total+t 00266 i=i+1 00267 enddo 00268 case (3) 00269 do while (total<tstop .and. i<bcfiles(ifid)%nlines) 00270 if (lnonh) then 00271 read(fid,*,iostat=ier)d1,total,d2,dummy 00272 else 00273 read(fid,*,iostat=ier)total,d2,d3,d4,d5,dummy 00274 endif 00275 if (ier .ne. 0) then 00276 call report_file_read_error(bcfiles(ifid)%fname) 00277 endif 00278 call check_file_exist(trim(dummy)) 00279 i=i+1 00280 enddo 00281 end select 00282 close(fid) 00283 if (total<tstop) then 00284 call writelog('sle',' ','Error: Wave boundary condition time series too short in ',trim(bcfiles(ifid)%fname)) 00285 call writelog('sle','(a,f0.2,a,f0.2)',' Total wave condition time series is ',total, & 00286 ' but simulation length is ',tstop) 00287 call writelog('sle',' ','Stopping calculation') 00288 call halt_program 00289 endif 00290 enddo ! nlocs 00291 endif ! xmaster 00292 00293 end subroutine checkbcfilelength 00294 00295 function get_file_length(filename) result (n) 00296 00297 implicit none 00298 00299 character(slen), intent(in) :: filename 00300 integer :: n 00301 integer :: io, error 00302 real*8 :: temp 00303 00304 n = 0 00305 io = 0 00306 00307 if (filename==' ') then 00308 n = 0 00309 else 00310 call check_file_exist_generic(filename, error) 00311 00312 if (error == 1) then 00313 n = 0 00314 else 00315 open(11,file=filename) 00316 do while (io==0) 00317 n = n + 1 00318 read(11,*,IOSTAT=io) temp 00319 enddo 00320 close(11) 00321 n = n - 1 00322 endif 00323 endif 00324 00325 end function get_file_length 00326 00327 subroutine check_file_exist_generic(filename,error) 00328 implicit none 00329 00330 character(*) :: filename 00331 integer :: error 00332 logical :: file_exists 00333 00334 inquire(file=filename,exist=file_exists) 00335 00336 error = 0 00337 00338 if (.not. file_exists) then 00339 error = 1 00340 endif 00341 00342 end subroutine check_file_exist_generic 00343 00344 00345 integer function create_new_fid_generic() 00346 integer :: tryunit = 9999 00347 logical :: fileopen 00348 00349 fileopen = .true. 00350 do while (fileopen) 00351 inquire(tryunit,OPENED=fileopen) 00352 if (fileopen) then 00353 tryunit=tryunit-1 00354 endif 00355 if (tryunit<=10) then 00356 tryunit = -1 00357 fileopen = .false. 00358 endif 00359 enddo 00360 create_new_fid_generic = tryunit 00361 end function create_new_fid_generic 00362 00363 end module filefunctions
1.7.6.1
