-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathwwm_m_fileio.F90
488 lines (488 loc) · 15.2 KB
/
wwm_m_fileio.F90
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
!-----------------------------------------------------------------------------!
module m_fileio
!-----------------------------------------------------------------------------!
!
! +-------+ ALKYON Hydraulic Consultancy & Research
! | | Gerbrant van Vledder
! | +---+
! | | +---+ Last update: 8 Feb. 2003
! +---+ | |
! +---+
!
! Module for storing file i/o related variables
!
! The values for the parameter i_log, i_prt and iw_tst must be set
! in one of the routines of the host program or in subroutine sys_init
!
! Version 1.1 29 May 2000 Initial version
! 1.2 21 Sep. 2001 Form=binary added (B)
! 1.3 5 Oct. 2001 Form=direct access, unformatted, fixed record (R)
! 1.4 24 Aug. 2002 Bug fixed and restructure of test output
! 1.5 8 Feb. 2003 Error check included when incorrect path (Z_FILEIO)
!
!-----------------------------------------------------------------------------!
! The following two parameters must be set by the user
! They define the overall test level and the output channel
!
integer,parameter :: i_print=0 ! (0/1/2) Test output printing off/on
! ! Output channel defined by i_out
!
integer,parameter :: i_out=6 ! Output channel to screen
! ! ==1 screen output for Unix/Linux systems
! ! ==6 screen output for Windows
!------------------------------------------------------------------------------
!
! Standard switches to activate Logging, Test and Print ouput
!
integer i_log ! (0/1) Logging off/on
integer i_prt ! (0/1) Printing off/on
integer i_tst ! (0,1,2...) Test level off/on
!
!
! Standard unit numbers of input & output files
!
integer lu_err ! standard error file
integer lu_inp ! standard input file
integer lu_log ! standard logging
integer lu_prt ! standard print output
integer lu_tst ! standard test output
!
contains
!-----------------------------------------------------------------------------!
subroutine z_fileio(filename,qual,iufind,iunit,iostat) !
!-----------------------------------------------------------------------------!
!
! +-------+ ALKYON Hydraulic Consultancy & Research
! | | Gerbrant van Vledder
! | +---+
! | | +---+
! +---+ | |
! +---+
!
implicit none
!
! 0. Update history
!
! 24/07/1999 First version
! 28/09/1999 Module name changed from FILEOPEN -> Z_FILEIO
! 27/10/1999 Option to delete an existing file added
! 18/11/1999 Argument IUNIT used to control use of Z_FLUNIT
! 22/11/1999 Parameter iunit not changed unless by z_flunit
! 28/12/1999 Interface with Z_FLUNIT updated and
! input parameter iufind added
! 14/04/2000 Module m_fileio included in this routine
! 25/05/2000 Module m_fileio excluded, if an already opened file is
! found, the corresponding unit number is assigned to output
! 21/09/2001 Form=binary added, extension to Fortran 95 standard
! 5/10/2001 Form=fixed Record length, as specified in input argument
! 17/06/2002 Initialisation of IUNIT=-1 included
! 24/08/2002 Bug fixed when routine called with IUFIND=0
! 08/02/2003 Bug fixed when file could not be created due to invalid path
!
! 1. Purpose
!
! Open file with name FILENAME and determine unit number IUNIT
! With file type determined in QUAL
!
! Depending on the value of IUFIND a search is performed for a
! free unit number
!
! 2. Method
!
! If file exists then
! if QUAL = 'D'
! delete file
! Else
! inquire if file opened
! If opened
! determine unit number
! Else
! If iunit >= 10 Find free unit number
! Open file with unit number and file qualifier
! End if
! End if
! Else
! If QUAL='SNU'
! If iunit >= 10 find free unit number
! Open new file with unit number and qualifier
! Else
! Iunit = -1 File does not exist
! End if
! End if
!
!
! 3. Parameter list
!
!Type I/O Name Description
!----------------------------------------------------
character(len=*), intent(in) :: filename ! File name
character(len=2), intent(in) :: qual ! File qualifyer
integer, intent(in) :: iufind ! Indicator for search of unit number
integer, intent(inout) :: iunit ! Unit number
integer, intent(out) :: iostat ! Error indicator
!
! 4. Subroutines used
!
! Z_FLUNIT
!
! 5. Error messages
!
! IUNIT > 0 File exists, is (already) connected to unit number IUNIT, or is
! created and connected to unit number
! IUNIT == 0 File has been deleted or does not exist
! < 0 An error occurred, no file or unit number found
!
! IOSTAT = 0 No errors detected
! -1 Incorrect file qualifier
! -2 Unit number does not exist
! -3 Attempt to open non-existing file with status=OLD
! -4 Attempt to open existing file with wrong FORMATTING
! -5 Incorrect value for IUFIND: not in range [0,1]
! -6 File could not be created due to,e.g. incorrect path
!
! 6. Remarks
!
! 1) Use of file qualifier:
!
! 1st char: O(ld),R(eplace),S(cratch),
! U(nknown),(D)elete
! 2nd char: F(ormatted),U(nformatted),B(inary)
!
! 2) Use of IUFIND
!
! if IUFIND==0, No search is performed for a free unit number
! ==1, A search is performed in routine Z_FLUNIT
!
! 3) This routine is based on routine FOR from
! SWAN version 40.00 of Delft University of Technology
!
!------------------------------------------------------------------------------
! Local variables
!
character(len=7) :: cstat ! string with status of file I/O
character(len=11) :: cform ! string with format of file I/O
integer junit ! temporary unit number
logical lexist ! indicator if a file exists
logical lopen ! indicator if a file is opened
integer iuerr ! error indicator from Z_FLUNIT
!-------------------------------------------------------------------------------------
! initialisations
!-------------------------------------------------------------------------------------
iostat = 0
if(iufind==1) iunit = -1
!
!
! Check value of IUFIND
!
if(iufind/=0 .and. iufind/=1) then
if(i_print >0) write(i_out,*) 'Z_FILEIO: Incorrect value for IUFIND:',iufind
iostat = -5
goto 9999
end if
!
!
! check input argument QUAL
!
if(i_print>=1) write(i_out,*) 'Z_FILEIO/A:',trim(filename),' ',qual,iunit,iostat
!
if (index('ORSUD',qual(1:1)) ==0 .or. index('FUB',qual(2:2)) ==0) then
if(i_print > 0) write(i_out,*) 'Incorrect file qualifier'
iostat = -1
else
if(qual(1:1) == 'O') cstat = 'old'
if(qual(1:1) == 'R') cstat = 'replace'
if(qual(1:1) == 'S') cstat = 'scratch'
if(qual(1:1) == 'U') cstat = 'unknown'
if(qual(1:1) == 'D') cstat = 'delete'
!
if(qual(2:2) == 'F') cform = 'formatted'
if(qual(2:2) == 'U') cform = 'unformatted'
if(qual(2:2) == 'B') cform = 'binary' ! extension to FORTRAN 95 standard
if(qual(2:2) == 'R') cform = 'unformatted'
!
! Check if file exists
!
inquire(file=filename,exist=lexist)
if(i_print >=2) write(i_out,*) 'Z_FILEIO file exists?:',trim(filename),':',lexist
!
! delete file if it exists and qual == 'D'
!
if(lexist .and. qual(1:1)=='D') then
inquire(file=filename,opened=lopen)
if(lopen) then
inquire(file=filename,number=junit)
else
if(iufind == 1) call z_flunit(iunit,iuerr)
junit = iunit
if(junit > 0) then
open(file=filename,unit=junit,form=cform,iostat=iostat)
if(iostat/=0) then
iostat = -4
goto 9999
end if
end if
end if
close(junit,status=cstat)
goto 9999
end if
!
! if the file exists, check if it is opened
!
if(lexist) then
if(i_print >=2) write(i_out,*) 'Z_FILEIO: File exists:',trim(filename)
inquire(file=filename,opened=lopen)
if(lopen) then
if(i_print >=2) write(i_out,*) 'Z_FILEIO: File is opened:',trim(filename)
!
! determine unit number to which this file is connected
! and assign it to the output number
!
inquire(file=filename,number=junit)
if(i_print >=2) write(i_out,*) 'Z_FILEIO: File is connected to unit:', junit
iunit = junit
else
!
! if the file exists and not connected to a unit number, search a free unit number
!
if(i_print >=2) write(i_out,*) 'Z_FILEIO: File is not connected to a unit number'
if(iufind==0) then
if(i_print >=2) write(i_out,*) 'Z_FILEIO: Assign user defined unit number:',iunit
elseif(iufind==1) then
call z_flunit(iunit,iuerr)
if(i_print >=2) write(i_out,*) 'Z_FILEIO: New unit number IUNIT:',iunit
end if
junit = iunit
!
if(junit > 0) then
open(file=filename,unit=junit,form=cform,status=cstat)
else
iostat = -2
end if
end if
!
! the file does not exist, so open it and find a free unit number
!
else
!
if(i_print>=2) then
write(i_out,*) 'Z_FILEIO: File does not exist !'
write(i_out,*) 'Z_FILEIO: Qual:',qual(1:1)
end if
!
if(index('SRU',qual(1:1)) > 0) then
if(iufind==1) then
call z_flunit(iunit,iuerr)
if(i_print >=1) write(i_out,*) 'Z_FILEIO: New unit number IUNIT:',iunit
end if
junit = iunit
!
! open file to IUNIT, if possible
!
if(junit > 0) then
open(file=filename,unit=junit,form=cform,iostat=iuerr)
!
! check added 8/2/2003
!
if(iuerr/=0) then
iunit = -1
iostat = -6
end if
else
iostat = -2
end if
!
! file cannot be opened because it does not exist
!
elseif('O'==qual(1:1)) then ! File should exist
if(i_print>=2) write(i_out,*) 'Z_FILEIO: File cannot be opened because it does not exist'
iostat = -3
end if
end if
end if
!
9999 continue
!
if(i_print>=1) write(i_out,*) 'Z_FILEIO/Z:',trim(filename),' ',qual,iunit,iostat
!
return
end subroutine
!
!-----------------------------------------------------------------------------!
subroutine z_fclose(iunit) !
!-----------------------------------------------------------------------------!
!
! +-------+ ALKYON Hydraulic Consultancy & Research
! | | Gerbrant van Vledder
! | +---+
! | | +---+
! +---+ | |
! +---+
!
implicit none
!
! 0. Update history
!
! 0.01 24/08/2000 First version
!
! 1. Purpose
!
! Close file with unit number IUNIT, and set IUNIT=-1
!
! 2. Method
!
!
! 3. Parameter list
!
!Type I/O Name Description
!-----------------------------------------------------------------------------
integer, intent(inout) :: iunit ! Unit number
!-----------------------------------------------------------------------------
close(iunit)
iunit = -1
!
return
end subroutine
!
!-----------------------------------------------------------------------------!
subroutine z_flunit(iunit,ierr) !
!-----------------------------------------------------------------------------!
!
! +-------+ ALKYON Hydraulic Consultancy & Research
! | | Gerbrant van Vledder
! | +---+
! | | +---+
! +---+ | |
! +---+
!
implicit none
!
! 0. Update history
!
! Version Date Modification
!
! 0.01 24/07/1999 Initial version
! 0.02 01/10/1999 Extra check added to ensure maximum unit number
! 0.03 07/10/1999 Check of existence of uni number deleted,
! since this test produces different answer
! on Lahey compiler
! 0.04 25/11/1999 Intent added
! 0.05 24/12/1999 Module M_GENVAR added for information about range of unit numbers
! 0.06 27/12/1999 Module M_GENVAR replaced by M_FILEIO
! Check added for forbidden unit numbers
! 0.07 28/12/1999 Internal checks added and IERR added to parameter list
! 0.08 08/02/2000 User of lu_min & lu_max deleted
! 0.09 14/04/2000 Module m_fileio included in this routine
!
! 1. Purpose
!
! Find a free unit number
!
! 2. Method
!
! Starting at LU_MIN till LU_MAX are investigated until
! a free (i.e. not connected to a file) is found.
! Use is made of the standard fortran INQUIRE function.
! The values of LU_MIN and LU_MAX should be specified
! in an initialisation routine
!
! 3. Parameter list
!
!Type I/O Name Description
!----------------------------------------------------------
integer, intent(out) :: iunit ! resulting unit number
integer, intent(out) :: ierr ! error level
!
! 4. Subroutines used
!
! None
!
! 5. Error messages
!
! ierr=0 No errors encountered
! 1 Invalud combination lu_low >= lu_high
! 2 Invalid value for lu_low
! 3 Invalid value for lu_high
! 4 No free unit number could be found
!
! 6. Remarks
!
! If no free unit number if found in the range
! lu_min - lu_high, then the function returns IUNIT = -1
!
! The switch i_print can be used to generate test output
!
!----------------------------------------------------------------------------------
! local parameters
!
integer junit ! counter for unit numbers
logical lopen ! indicator if a unit number is connected to a file
logical lnot ! indicates if a forbidden unit number is checked
integer i_not ! counter to check forbidded unit numbers
!
!---------------------------------------------------------------------------------
! range of unit numbers to search
!
integer, parameter :: lu_min=60 ! minimum unit number
integer, parameter :: lu_max=200 ! maximum unit number
!
! specification of forbidden unit numbers
!
integer, parameter :: lu_nr=3 ! number of forbidden unit numbers
integer lu_not(lu_nr) ! list of forbidden unit numbers
!----------------------------------------------------------------------------------
lu_not(1) = 100
lu_not(2) = 101
lu_not(3) = 102
!-----------------------------------------------------------------------------------
!
ierr = 0
!
if(i_print >= 2) then
write(i_out,*) 'Z_FLUNIT: forbidden :',lu_not
write(i_out,*) 'Z_FLUNIT: lu_min lu_max :',lu_min,lu_max
end if
!
! check data specified in Module Z_FILEIO
!
if(lu_min >= lu_max) then
ierr = 1
write(i_out,*) 'Z_FLUNIT: Incorrect boundaries for LU_MIN & LU_MAX:',&
& lu_min,lu_max
end if
!
junit = lu_min
!
iunit = -1
!
do while (iunit ==-1)
!
! Check if unit number is free, i.e. not in use by an opened file
!
inquire(unit=junit,opened=lopen)
!
! check if unit number is not a forbidden unit number
!
lnot = .false.
do i_not=1,lu_nr
if(lu_not(i_not)==junit) then
lnot = .true.
if(i_print >= 1) write(i_out,*) 'Z_FLUNIT: a forbidden unit number was encountered:',junit
end if
end do
!
if(lopen.or.lnot) then
junit = junit + 1
else
iunit = junit
end if
if(junit > lu_max) exit
end do
!
if(iunit < 0) then
write(i_out,*) 'ERROR in Z_FLUNIT: No free unit number could be found'
end if
!
return
end subroutine
!
end module