|
XBeach
|
00001 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00002 ! Copyright (C) 2007 UNESCO-IHE, WL|Delft Hydraulics and Delft University ! 00003 ! Dano Roelvink, Ap van Dongeren, Ad Reniers, Jamie Lescinski, ! 00004 ! Jaap van Thiel de Vries, Robert McCall ! 00005 ! ! 00006 ! d.roelvink@unesco-ihe.org ! 00007 ! UNESCO-IHE Institute for Water Education ! 00008 ! P.O. Box 3015 ! 00009 ! 2601 DA Delft ! 00010 ! The Netherlands ! 00011 ! ! 00012 ! This library is free software; you can redistribute it and/or ! 00013 ! modify it under the terms of the GNU Lesser General Public ! 00014 ! License as published by the Free Software Foundation; either ! 00015 ! version 2.1 of the License, or (at your option) any later version. ! 00016 ! ! 00017 ! This library is distributed in the hope that it will be useful, ! 00018 ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! 00019 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ! 00020 ! Lesser General Public License for more details. ! 00021 ! ! 00022 ! You should have received a copy of the GNU Lesser General Public ! 00023 ! License along with this library; if not, write to the Free Software ! 00024 ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 ! 00025 ! USA ! 00026 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 00027 00028 module readkey_module 00029 00030 use typesandkinds, only: slen 00031 implicit none 00032 save 00033 private 00034 public readkey_int, readkey_name, readkey_dbl, isSetParameter, parmapply, readkey_dblvec, readkey_inio, strippedline 00035 public count_lines, readkey_intvec, lowercase, setallowednames, setoldnames, readkey, read_v 00036 ! before using any of the routines here, set readkey_inio 00037 ! .true. : value read will be broadcasted to all processes, including the 00038 ! output process. 00039 ! otherwise: the value will be broadcasted to the computational processes only 00040 ! 00041 logical :: readkey_inio = .false. 00042 00043 integer, parameter, private :: maxnames = 20 00044 character(slen), dimension(maxnames), private :: allowednames 00045 character(slen), dimension(maxnames), private :: oldnames 00046 character(slen), private :: varname 00047 integer, dimension(maxnames), private :: intvalues 00048 integer, private :: numallowednames 00049 integer, private :: numoldnames 00050 00051 interface read_v 00052 module procedure read_v_array 00053 module procedure read_v_9 00054 end interface read_v 00055 00056 contains 00057 real*8 function readkey_dbl(fname,key,defval,mnval,mxval,bcast,required,silent,strict) 00058 ! if USEMPI then the master process will read the parameter, 00059 ! this value is subsequently broadcasted to the other processes 00060 00061 use xmpi_module 00062 use logging_module, only: writelog, report_file_read_error 00063 implicit none 00064 character(len=*) :: fname,key 00065 character(slen) :: printkey 00066 real*8 :: defval,mnval,mxval 00067 logical, intent(in), optional :: bcast,required,silent,strict 00068 00069 character(slen) :: value,tempout 00070 real*8 :: value_dbl 00071 logical :: lbcast,lrequired,lsilent,lstrict 00072 character(slen) :: fmt 00073 integer :: ier 00074 00075 fmt = '(a,a,a,f0.4,a,f0.4)' 00076 00077 if (present(bcast)) then 00078 lbcast = bcast 00079 else 00080 lbcast = .true. 00081 endif 00082 00083 if (present(required)) then 00084 lrequired = required 00085 else 00086 lrequired = .false. 00087 endif 00088 00089 if (present(silent)) then 00090 lsilent = silent 00091 else 00092 lsilent = .false. 00093 endif 00094 00095 if (present(strict)) then 00096 lstrict = strict 00097 else 00098 lstrict = .false. 00099 endif 00100 00101 !printkey=key 00102 printkey = ' ' 00103 printkey(2:24)=trim(key) 00104 printkey(1:1)=' ' 00105 00106 if (xmaster) then 00107 call readkey(fname,key,value) 00108 00109 if (value/=' ') then 00110 read(value,'(f10.0)',iostat=ier)value_dbl 00111 if (ier .ne. 0) then 00112 tempout = trim(fname)//' (value of '''//trim(printkey)//''' cannot be interpreted)' 00113 call report_file_read_error(tempout) 00114 endif 00115 if(lstrict .and. (value_dbl>mxval .or. value_dbl<mnval)) then 00116 call writelog('sle','(a,a,a,f0.4)','Value of ',trim(printkey),' is ',value_dbl) 00117 call writelog('sle','(a,a,f0.4,a,f0.4)',trim(printkey),' must be set between ',mnval,' and ',mxval) 00118 call writelog('sle','','Terminating simulation') 00119 call halt_program 00120 elseif (value_dbl>mxval) then 00121 call writelog('lw','(a24,a,f0.4,a,f0.4)',(printkey),' = ',value_dbl,' Warning: value > recommended value of ',mxval) 00122 call writelog('s','(a24,a,a,f0.4)','Warning: ',trim(printkey),' > recommended value of ',mxval) 00123 elseif (value_dbl<mnval) then 00124 call writelog('lw','(a24,a,f0.4,a,f0.4)',(printkey),' = ',value_dbl,' Warning: value < recommended value of ',mnval) 00125 call writelog('s','(a24,a,a,f0.4)','Warning: ',trim(printkey),' < recommended value of ',mnval) 00126 else 00127 call writelog('l','(a24,a,f0.4)',(printkey),' = ',value_dbl) 00128 endif 00129 else 00130 if (lrequired) then 00131 call writelog('lse','','Error: missing required value for parameter ',printkey) 00132 call halt_program 00133 else 00134 value_dbl=defval 00135 if (.not. lsilent) call writelog('l','(a24,a,f0.4,a)',(printkey),' = ', & 00136 value_dbl,' (no record found, default value used)') 00137 endif 00138 endif 00139 ! write to basic params data file 00140 ! write(pardatfileid,*)'f ',printkey,' ',value_dbl 00141 endif 00142 00143 #ifdef USEMPI 00144 if (lbcast) then 00145 call xmpi_bcast(value_dbl,readkey_inio) 00146 endif 00147 #endif 00148 00149 readkey_dbl=value_dbl 00150 end function readkey_dbl 00151 00152 function readkey_int(fname,key,defval,mnval,mxval,bcast,required,silent,strict) result (value_int) 00153 use xmpi_module 00154 use logging_module 00155 implicit none 00156 character*(*) :: fname,key 00157 character(slen) :: printkey 00158 character(slen) :: value 00159 integer*4 :: value_int 00160 integer*4 :: defval,mnval,mxval,ier 00161 logical, intent(in), optional :: bcast, required,silent,strict 00162 logical :: lbcast,lrequired,lsilent,lstrict 00163 character(slen) :: fmt,tempout 00164 00165 fmt = '(a,a,a,i0,a,i0)' 00166 00167 if (present(bcast)) then 00168 lbcast = bcast 00169 else 00170 lbcast = .true. 00171 endif 00172 00173 if (present(required)) then 00174 lrequired = required 00175 else 00176 lrequired = .false. 00177 endif 00178 00179 if (present(silent)) then 00180 lsilent = silent 00181 else 00182 lsilent = .false. 00183 endif 00184 00185 if (present(strict)) then 00186 lstrict = strict 00187 else 00188 lstrict = .false. 00189 endif 00190 00191 printkey = ' ' 00192 printkey(2:24)=trim(key) 00193 printkey(1:1)=' ' 00194 if (xmaster) then 00195 call readkey(fname,key,value) 00196 00197 if (value/=' ') then 00198 read(value,'(i256)',iostat=ier)value_int 00199 if (ier .ne. 0) then 00200 tempout = trim(fname)//' (value of '''//trim(printkey)//''' cannot be interpreted)' 00201 call report_file_read_error(tempout) 00202 endif 00203 if(lstrict .and. (value_int>mxval .or. value_int<mnval)) then 00204 call writelog('sle','(a,a,a,i0)','Value of ',trim(printkey),' is ',value_int) 00205 call writelog('sle','(a,a,i0,a,i0)',trim(printkey),' must be set between ',mnval,' and ',mxval) 00206 call writelog('sle','','Terminating simulation') 00207 call halt_program 00208 elseif (value_int>mxval) then 00209 call writelog('lw',fmt,'Warning: variable ',(printkey),' ',value_int,' > recommended value of ',mxval) 00210 call writelog('s','(a24,a,a,i0)','Warning: ',trim(printkey),' > recommended value of ',mxval) 00211 elseif (value_int<mnval) then 00212 call writelog('lw',fmt,'Warning: variable ',(printkey),' ',value_int,' < recommended value of ',mnval) 00213 call writelog('s','(a24,a,a,i0)','Warning: ',trim(printkey),' < recommended value of ',mnval) 00214 else 00215 call writelog('l','(a24,a,i0)',(printkey),' = ',value_int) 00216 endif 00217 else 00218 if (lrequired) then 00219 call writelog('lse','','Error: missing required value for parameter ',printkey) 00220 call halt_program 00221 else 00222 value_int=defval 00223 if (.not. lsilent) call writelog('l','(a24,a,i0,a)',(printkey),' = ', & 00224 value_int,' (no record found, default value used)') 00225 endif 00226 endif 00227 ! write to basic params data file 00228 ! write(pardatfileid,*)'i ',printkey,' ',value_int 00229 endif 00230 #ifdef USEMPI 00231 if (lbcast) then 00232 call xmpi_bcast(value_int,readkey_inio) 00233 endif 00234 #endif 00235 00236 end function readkey_int 00237 00238 function readkey_str(fname,key,defval,nv,nov,allowed,old,bcast,required,silent) result (value_str) 00239 use xmpi_module 00240 use logging_module 00241 implicit none 00242 character*(*) :: fname,key,defval 00243 character(slen) :: value_str 00244 character(slen) :: value 00245 integer*4 :: nv,nov,i,j 00246 character(slen),dimension(nv) :: allowed 00247 character(slen),dimension(nov):: old 00248 logical, intent(in), optional :: bcast,required,silent 00249 logical :: lbcast,lrequired,passed,lsilent 00250 character(slen) :: printkey 00251 00252 printkey(2:slen)=key 00253 printkey(1:1)=' ' 00254 00255 if (present(bcast)) then 00256 lbcast = bcast 00257 else 00258 lbcast = .true. 00259 endif 00260 00261 if (present(required)) then 00262 lrequired = required 00263 else 00264 lrequired = .false. 00265 endif 00266 00267 if (present(silent)) then 00268 lsilent = silent 00269 else 00270 lsilent = .false. 00271 endif 00272 00273 passed = .false. 00274 if (xmaster) then 00275 call readkey(fname,key,value) 00276 ! Change to lowercase 00277 value = lowercase(value) 00278 if (value == ' ') then 00279 if (lrequired) then 00280 call writelog('lse','','Error: missing required value for parameter ',printkey) 00281 call halt_program 00282 else 00283 value_str=defval 00284 if (.not. lsilent) call writelog('l','(a24,a,a,a)',(printkey),' = ', & 00285 trim(value_str),' (no record found, default value used)') 00286 endif 00287 else 00288 value=adjustl(value) 00289 do i=1,nv 00290 if (trim(value)==trim(allowed(i))) then 00291 passed = .true. 00292 value_str = value 00293 endif 00294 enddo 00295 do j=1,nov 00296 if (trim(value)==trim(old(j))) then 00297 passed = .true. 00298 value_str = allowed(j) 00299 endif 00300 enddo 00301 if (passed) then 00302 call writelog('l','(a24,a,a)',printkey,' = ',trim(value_str)) 00303 else 00304 call writelog('sle','(a24,a,a,a)','Invalid option for ',trim(printkey),' : ',trim(value)) 00305 call writelog('sle','(a24,a,a)','Valid options for ',trim(printkey),' are:') 00306 do i=1,nv 00307 call writelog('sle','(a24)',trim(allowed(i))) 00308 enddo 00309 do j=1,nov 00310 call writelog('sle','(a24)',trim(old(j))) 00311 enddo 00312 call halt_program 00313 endif 00314 endif 00315 ! write to basic params data file 00316 ! write(pardatfileid,*)'c ',printkey,' ',value_str 00317 endif 00318 #ifdef USEMPI 00319 if (lbcast) then 00320 call xmpi_bcast(value_str,readkey_inio) 00321 endif 00322 #endif 00323 end function readkey_str 00324 00325 00326 function readkey_name(fname,key,bcast,required,silent) result (value_str) 00327 use xmpi_module 00328 use logging_module 00329 implicit none 00330 character*(*) :: fname,key 00331 character(slen) :: value_str 00332 character(slen) :: value 00333 logical, intent(in), optional :: bcast,required,silent 00334 logical :: lbcast,lrequired,lsilent 00335 character(slen) :: printkey 00336 00337 printkey(2:slen)=key 00338 printkey(1:1)=' ' 00339 00340 if (present(bcast)) then 00341 lbcast = bcast 00342 else 00343 lbcast = .true. 00344 endif 00345 00346 if (present(required)) then 00347 lrequired = required 00348 else 00349 lrequired = .false. 00350 endif 00351 00352 if (present(silent)) then 00353 lsilent = silent 00354 else 00355 lsilent = .false. 00356 endif 00357 00358 if (xmaster) then 00359 call readkey(fname,key,value) 00360 if (value == ' ') then 00361 if (lrequired) then 00362 call writelog('lse','','Error: missing required value for parameter ',printkey) 00363 call halt_program 00364 else 00365 value_str=' ' 00366 if (.not. lsilent) call writelog('l',' (a24,a)' ,printkey,' = None specified') 00367 ! write to basic params data file 00368 ! write(pardatfileid,*)'c ',key,' ','none' 00369 endif 00370 else 00371 value_str=adjustl(value) 00372 call writelog('l','(a24,a,a)',printkey,' = ',trim(value_str)) 00373 ! write to basic params data file 00374 ! write(pardatfileid,*)'c ',printkey,' ',value_str 00375 endif 00376 endif 00377 #ifdef USEMPI 00378 if (lbcast) then 00379 call xmpi_bcast(value_str,readkey_inio) 00380 endif 00381 #endif 00382 end function readkey_name 00383 00384 function readkey_dblvec(fname,key,vlength,tlength,defval,mnval,mxval,bcast,required,silent) result (value_vec) 00385 use xmpi_module 00386 use logging_module 00387 implicit none 00388 character*(*) :: fname,key 00389 integer, intent(in) :: vlength,tlength 00390 real*8,dimension(tlength) :: value_vec 00391 real*8 :: defval,mnval,mxval 00392 logical, intent(in), optional :: bcast,required,silent 00393 logical :: lbcast,lrequired,lsilent 00394 00395 integer :: i, ioerr 00396 character(slen) :: value 00397 character(slen) :: printkey 00398 00399 printkey(2:slen)=key 00400 printkey(1:1)=' ' 00401 00402 if (present(bcast)) then 00403 lbcast = bcast 00404 else 00405 lbcast = .true. 00406 endif 00407 00408 if (present(required)) then 00409 lrequired = required 00410 else 00411 lrequired = .false. 00412 endif 00413 00414 if (present(silent)) then 00415 lsilent = silent 00416 else 00417 lsilent = .false. 00418 endif 00419 00420 if (xmaster) then 00421 call readkey(fname,key,value) 00422 if (value/=' ') then 00423 read(value,*,IOSTAT=ioerr)value_vec(1:vlength) 00424 if (ioerr < 0) then 00425 call writelog('lse','','Error reading value for parameter ',printkey) 00426 call writelog('lse','','Check whether parameter is given sufficient number of input values') 00427 call halt_program 00428 endif 00429 do i=1,vlength 00430 if (value_vec(i)>mxval) then 00431 call writelog('lw','(a24,a,f0.4,a,f0.4)',(printkey),' = ',value_vec(i), & 00432 ' Warning: value > recommended value of ',mxval) 00433 call writelog('s','(a24,a,a,f0.4)','Warning: ',trim(printkey),' > recommended value of ',mxval) 00434 elseif (value_vec(i)<mnval) then 00435 call writelog('lw','(a24,a,f0.4,a,f0.4)',(printkey),' = ',value_vec(i), & 00436 ' Warning: value < recommended value of ',mnval) 00437 call writelog('s','(a24,a,a,f0.4)','Warning: ',trim(printkey),' < recommended value of ',mnval) 00438 else 00439 call writelog('l','(a24,a,f0.4)',(printkey),' = ',value_vec(i)) 00440 endif 00441 enddo 00442 else 00443 if (lrequired) then 00444 call writelog('lse','','Error: missing required value for parameter ',printkey) 00445 call halt_program 00446 else 00447 value_vec(1:vlength)=defval 00448 do i=1,vlength 00449 if (.not. lsilent) call writelog('l','(a,a,f0.4,a)',(printkey),' = ', & 00450 value_vec(i),' (no record found, default value used)') 00451 enddo 00452 endif 00453 endif 00454 endif 00455 00456 #ifdef USEMPI 00457 if (lbcast) then 00458 do i=1,vlength 00459 call xmpi_bcast(value_vec(i),readkey_inio) 00460 enddo 00461 endif 00462 #endif 00463 end function readkey_dblvec 00464 00465 function readkey_intvec(fname,key,vlength,tlength,defval,mnval,mxval,bcast,required,silent) result (value_vec) 00466 use xmpi_module 00467 use logging_module, only: writelog 00468 implicit none 00469 character*(*) :: fname,key 00470 integer, intent(in) :: vlength,tlength 00471 integer,dimension(tlength) :: value_vec 00472 integer :: defval,mnval,mxval 00473 logical, intent(in), optional :: bcast,required,silent 00474 logical :: lbcast,lrequired,lsilent 00475 00476 integer :: i, ioerr 00477 character(slen) :: value 00478 character(slen) :: printkey 00479 00480 printkey(2:slen)=key 00481 printkey(1:1)=' ' 00482 00483 if (present(bcast)) then 00484 lbcast = bcast 00485 else 00486 lbcast = .true. 00487 endif 00488 00489 if (present(required)) then 00490 lrequired = required 00491 else 00492 lrequired = .false. 00493 endif 00494 00495 if (present(silent)) then 00496 lsilent = silent 00497 else 00498 lsilent = .false. 00499 endif 00500 00501 if (xmaster) then 00502 call readkey(fname,key,value) 00503 if (value/=' ') then 00504 read(value,*,IOSTAT=ioerr)value_vec(1:vlength) 00505 if (ioerr < 0) then 00506 call writelog('lse','','Error reading value for parameter ',printkey) 00507 call writelog('lse','','Check whether parameter is given sufficient number of input values') 00508 call halt_program 00509 endif 00510 do i=1,vlength 00511 if (value_vec(i)>mxval) then 00512 call writelog('lw','(a24,a,i0,a,i0)',(printkey),' = ',value_vec(i), & 00513 ' Warning: value > recommended value of ',mxval) 00514 call writelog('s','(a24,a,a,i0)','Warning: ',trim(printkey),' > recommended value of ',mxval) 00515 elseif (value_vec(i)<mnval) then 00516 call writelog('lw','(a24,a,i0,a,i0)',(printkey),' = ',value_vec(i), & 00517 ' Warning: value < recommended value of ',mnval) 00518 call writelog('s','(a24,a,a,i0)','Warning: ',trim(printkey),' < recommended value of ',mnval) 00519 else 00520 call writelog('l','(a24,a,i0)',(printkey),' = ',value_vec(i)) 00521 endif 00522 enddo 00523 else 00524 if (lrequired) then 00525 call writelog('lse','','Error: missing required value for parameter ',printkey) 00526 call halt_program 00527 else 00528 value_vec(1:vlength)=defval 00529 do i=1,vlength 00530 if (.not. lsilent) call writelog('l','(a,a,i0,a)',(printkey),' = ', & 00531 value_vec(i),' (no record found, default value used)') 00532 enddo 00533 endif 00534 endif 00535 endif 00536 00537 #ifdef USEMPI 00538 if (lbcast) then 00539 do i=1,vlength 00540 call xmpi_bcast(value_vec(i),readkey_inio) 00541 enddo 00542 endif 00543 #endif 00544 end function readkey_intvec 00545 00546 function isSetParameter(fname,key,bcast) result (isSet) 00547 ! Function return logical true if the keyword is specified in file, 00548 ! or logical false if the keyword is not specified in the file. 00549 use xmpi_module 00550 implicit none 00551 character*(*) :: fname,key 00552 logical, intent(in), optional :: bcast 00553 logical :: isSet 00554 character(slen) :: value 00555 logical :: lbcast 00556 00557 isSet = .false. 00558 if (present(bcast)) then 00559 lbcast = bcast 00560 else 00561 lbcast = .true. 00562 endif 00563 00564 if (xmaster) then 00565 call readkey(fname,key,value) 00566 if (value == ' ') then 00567 isSet = .false. 00568 else 00569 isSet = .true. 00570 endif 00571 endif 00572 #ifdef USEMPI 00573 if (lbcast) then 00574 call xmpi_bcast(isSet,readkey_inio) 00575 endif 00576 #endif 00577 end function isSetParameter 00578 00579 ! 00580 ! readkey is only to be called from master, ie: 00581 ! if(xmaster) then 00582 ! call readkey(....) 00583 ! No need to cache these results. 00584 ! 00585 subroutine readkey(fname,key,value) 00586 ! Reads through input file (fname) looking for key = value combinations 00587 ! Return value as string 00588 ! Subroutine also used to keep track of which lines have been succesfully read 00589 ! If called by readkey('params.txt','checkparams'), will output unsuccesful key = value 00590 ! combinations in params.txt 00591 use xmpi_module 00592 use logging_module 00593 integer :: lun,i,ier,nlines,ic,ikey,itab 00594 character*1 :: ch 00595 character(len=*), intent(in) :: fname,key 00596 character(len=*), intent(out) :: value 00597 character(slen), dimension(1024),save :: keyword,values 00598 character(slen) :: line,lineWithoutSpecials 00599 integer, save :: nkeys 00600 character(slen), save :: fnameold='' 00601 integer, dimension(:),allocatable,save :: readindex 00602 00603 ! If the file name of the input file changes, the file should be reread 00604 if (fname/=fnameold) then 00605 ! Make sure this reset only recurs when the input file name changes 00606 fnameold=fname 00607 nkeys=0 00608 ier=0 00609 ! Read the file for all lines with "=" 00610 call writelog('ls','','XBeach reading from ',trim(fname)) 00611 lun=99 00612 i=0 00613 open(lun,file=fname) 00614 do while (ier==0) 00615 read(lun,'(a)',iostat=ier)ch 00616 if (ier==0)i=i+1 00617 enddo 00618 close(lun) 00619 nlines=i 00620 ! reset keyword values and readindex 00621 keyword = '' 00622 values = '' 00623 if (allocated(readindex)) deallocate(readindex) 00624 ! Read through the file to fill all the keyword = value combinations 00625 open(lun,file=fname) 00626 ikey=0 00627 do i=1,nlines 00628 read(lun,'(a)')line 00629 lineWithoutSpecials = strippedline(line) 00630 line = lineWithoutSpecials 00631 ic=scan(line,'=') 00632 if (ic>0) then 00633 ikey=ikey+1 00634 keyword(ikey)=adjustl(line(1:ic-1)) 00635 values(ikey)=adjustl(line(ic+1:slen)) 00636 endif 00637 enddo 00638 nkeys=ikey 00639 close(lun) 00640 ! allocate index vector that stores which values have succesfully been called to be read 00641 allocate(readindex(nkeys)) 00642 readindex=0 00643 endif 00644 00645 ! Compare the input key with any keyword stored in the keyword vector and return the value. 00646 ! A succesful key - keyword match is recorded in readindex with a value "1" 00647 ! Note: in case more than one keyword matches the key, the first keyword - value combination is returned 00648 value=' ' 00649 do ikey=1,nkeys 00650 ! check for keywords ignoring case difference 00651 if (lowercase(key) .eq. lowercase(keyword(ikey))) then 00652 value=values(ikey) 00653 readindex(ikey)=1 00654 exit 00655 endif 00656 enddo 00657 00658 ! Easter egg! 00659 ! With call for key "checkparams", the subroutine searches readindex for keyword - value combinations that 00660 ! have not yet been read. It returns a warning to screen and log file for each unsuccesful keyword. 00661 if (lowercase(key) .eq. 'checkparams') then 00662 do ikey=1,nkeys 00663 if (readindex(ikey)==0) then 00664 call writelog('slw','','Unknown, unused or multiple statements of parameter ', & 00665 trim(uppercase(keyword(ikey))),' in ',trim(fname)) 00666 endif 00667 enddo 00668 endif 00669 00670 end subroutine readkey 00671 00672 00673 ! The following code is taken from program "CHCASE" @ http://www.davidgsimpson.com/software/chcase_f90.txt: 00674 ! Programmer: Dr. David G. Simpson 00675 ! NASA Goddard Space Flight Center 00676 ! Greenbelt, Maryland 20771 00677 ! 00678 ! Date: January 24, 2003 00679 ! 00680 ! Language: Fortran-90 00681 ! 00682 ! Version: 1.00a 00683 ! 1.1 : Modified uppercase into function form by R.T. McCall 23/7/2013 00684 ! 00685 00686 pure function UPPERCASE(STR) result(upperstr) 00687 00688 IMPLICIT NONE 00689 00690 CHARACTER(LEN=*),intent(in) :: STR 00691 character(slen) :: upperstr 00692 INTEGER :: I, DEL 00693 00694 upperstr = STR 00695 00696 DEL = IACHAR('a') - IACHAR('A') 00697 00698 DO I = 1, LEN_TRIM(upperstr) 00699 IF (LGE(upperstr(I:I),'a') .AND. LLE(upperstr(I:I),'z')) THEN 00700 upperstr(I:I) = ACHAR(IACHAR(upperstr(I:I)) - DEL) 00701 END IF 00702 END DO 00703 00704 end function UPPERCASE 00705 ! 00706 ! LOWERCASE 00707 ! 00708 pure function LOWERCASE(STR) result(lowerstr) 00709 00710 IMPLICIT NONE 00711 00712 CHARACTER(LEN=*), INTENT(IN) :: STR 00713 character(slen) :: lowerstr 00714 INTEGER :: I, DEL 00715 00716 lowerstr = STR 00717 00718 DEL = IACHAR('a') - IACHAR('A') 00719 00720 DO I = 1, LEN_TRIM(lowerstr) 00721 IF (LGE(lowerstr(I:I),'A') .AND. LLE(lowerstr(I:I),'Z')) THEN 00722 lowerstr(I:I) = ACHAR(IACHAR(lowerstr(I:I)) + DEL) 00723 END IF 00724 END DO 00725 00726 RETURN 00727 00728 END FUNCTION LOWERCASE 00729 00730 ! End of code taken from CHCASE 00731 00732 00733 00734 ! The following 00735 ! defines the following method to read a string parameter: 00736 ! 00737 ! for example: 00738 00739 ! integer NAME1, NAME2, NAME3 00740 ! call setallowednames('name1',NAME1,'name2',NAME2,'name3',NAME3) 00741 ! this defines the allowed names ('name1', 'name2', 'name3') and 00742 ! the to-be associated integer values (NAME1, NAME2, NAME3) 00743 ! call setoldname('0','1') 00744 ! this defines alternate allowed names for 'name1' and 'name2' 00745 ! integer intvalue 00746 ! character(slen) stringvalue 00747 ! call parmapply('gridform',2,intvalue[,stringvalue]) 00748 ! | 00749 ! this searches for 'gridform' in file 'params.txt'. 00750 ! let us assume that there is a line 00751 ! gridform = name3 00752 ! then intvalue becomes NAME2, and stringvalue becomes 'name3' 00753 ! If no line defining gridform is found, the default numer allowed name 00754 ! is used, in this case number 2: NAME2 and 'name2' 00755 ! 00756 ! Notes: 00757 ! setoldnames must be called after setallowednames and is optional 00758 ! the 3rd parameter in parmapply is optional 00759 ! 00760 00761 00762 subroutine parmapply(vname,idefname,parm,parm_str,bcast,required,silent) 00763 use typesandkinds 00764 use xmpi_module 00765 implicit none 00766 character(*), intent(in) :: vname 00767 integer, intent(in) :: idefname 00768 integer, intent(out) :: parm 00769 character(*), intent(out), optional :: parm_str 00770 logical, intent(in), optional :: bcast,required,silent 00771 00772 character(slen) :: d 00773 integer :: i 00774 logical :: lbcast 00775 00776 d = readkey_str('params.txt',vname,allowednames(idefname), & 00777 numallowednames,numoldnames,allowednames,oldnames, & 00778 bcast, required, silent) 00779 00780 if (present(bcast)) then 00781 lbcast = bcast 00782 else 00783 lbcast = .true. 00784 endif 00785 00786 if (xmaster) then 00787 do i=1,numallowednames 00788 if (d .eq. allowednames(i)) then 00789 parm = intvalues(i) 00790 if (present(parm_str)) then 00791 parm_str = d 00792 endif 00793 exit 00794 endif 00795 enddo 00796 endif 00797 00798 #ifdef USEMPI 00799 if (lbcast) then 00800 call xmpi_bcast(parm,readkey_inio) 00801 endif 00802 #endif 00803 00804 end subroutine parmapply 00805 00806 subroutine setallowednames(a1,v1,a2,v2,a3,v3,a4,v4,a5,v5,a6,v6,a7,v7,a8,v8, & 00807 a9,v9,a10,v10,a11,v11,a12,v12,a13,v13,a14,v14, & 00808 a15,v15,a16,v16,a17,v17,a18,v18,a19,v19,a20,v20) 00809 character(*), intent(in) :: a1 00810 character(*), intent(in), optional :: a2,a3,a4,a5,a6,a7,a8,a9,a10 00811 ,a11,a12,a13,a14,a15,a16,a17,a18,a19,a20 00812 integer , intent(in) :: v1 00813 integer , intent(in), optional :: v2,v3,v4,v5,v6,v7,v8,v9,v10 00814 ,v11,v12,v13,v14,v15,v16,v17,v18,v19,v20 00815 numoldnames = 0 00816 allowednames(1) = a1 00817 intvalues(1) = v1 00818 numallowednames = 1 00819 if (present(a2)) then 00820 allowednames(2) = a2 00821 intvalues(2) = v2 00822 numallowednames = 2 00823 endif 00824 if (present(a3)) then 00825 allowednames(3) = a3 00826 intvalues(3) = v3 00827 numallowednames = 3 00828 endif 00829 if (present(a4)) then 00830 allowednames(4) = a4 00831 intvalues(4) = v4 00832 numallowednames = 4 00833 endif 00834 if (present(a5)) then 00835 allowednames(5) = a5 00836 intvalues(5) = v5 00837 numallowednames = 5 00838 endif 00839 if (present(a6)) then 00840 allowednames(6) = a6 00841 intvalues(6) = v6 00842 numallowednames = 6 00843 endif 00844 if (present(a7)) then 00845 allowednames(7) = a7 00846 intvalues(7) = v7 00847 numallowednames = 7 00848 endif 00849 if (present(a8)) then 00850 allowednames(8) = a8 00851 intvalues(8) = v8 00852 numallowednames = 8 00853 endif 00854 if (present(a9)) then 00855 allowednames(9) = a9 00856 intvalues(9) = v9 00857 numallowednames = 9 00858 endif 00859 if (present(a10)) then 00860 allowednames(10) = a10 00861 intvalues(10) = v10 00862 numallowednames = 10 00863 endif 00864 if (present(a11)) then 00865 allowednames(11) = a11 00866 intvalues(11) = v11 00867 numallowednames = 11 00868 endif 00869 if (present(a12)) then 00870 allowednames(12) = a12 00871 intvalues(12) = v12 00872 numallowednames = 12 00873 endif 00874 if (present(a13)) then 00875 allowednames(13) = a13 00876 intvalues(13) = v13 00877 numallowednames = 13 00878 endif 00879 if (present(a14)) then 00880 allowednames(14) = a14 00881 intvalues(14) = v14 00882 numallowednames = 14 00883 endif 00884 if (present(a15)) then 00885 allowednames(15) = a15 00886 intvalues(15) = v15 00887 numallowednames = 15 00888 endif 00889 if (present(a16)) then 00890 allowednames(16) = a16 00891 intvalues(16) = v16 00892 numallowednames = 16 00893 endif 00894 if (present(a17)) then 00895 allowednames(17) = a17 00896 intvalues(17) = v17 00897 numallowednames = 17 00898 endif 00899 if (present(a18)) then 00900 allowednames(18) = a18 00901 intvalues(18) = v18 00902 numallowednames = 18 00903 endif 00904 if (present(a19)) then 00905 allowednames(19) = a19 00906 intvalues(19) = v19 00907 numallowednames = 19 00908 endif 00909 if (present(a20)) then 00910 allowednames(20) = a20 00911 intvalues(20) = v20 00912 numallowednames = 20 00913 endif 00914 00915 end subroutine setallowednames 00916 00917 subroutine setoldnames(a1,a2,a3,a4,a5,a6,a7,a8,a9,a10 & 00918 ,a11,a12,a13,a14,a15,a16,a17,a18,a19,a20) 00919 character(*), intent(in) :: a1 00920 character(*), intent(in), optional :: a2,a3,a4,a5,a6,a7,a8,a9,a10 00921 ,a11,a12,a13,a14,a15,a16,a17,a18,a19,a20 00922 oldnames(1) = a1 00923 numoldnames = 1 00924 if (present(a2)) then 00925 oldnames(2) = a2 00926 numoldnames = 2 00927 endif 00928 if (present(a3)) then 00929 oldnames(3) = a3 00930 numoldnames = 3 00931 endif 00932 if (present(a4)) then 00933 oldnames(4) = a4 00934 numoldnames = 4 00935 endif 00936 if (present(a5)) then 00937 oldnames(5) = a5 00938 numoldnames = 5 00939 endif 00940 if (present(a6)) then 00941 oldnames(6) = a6 00942 numoldnames = 6 00943 endif 00944 if (present(a7)) then 00945 oldnames(7) = a7 00946 numoldnames = 7 00947 endif 00948 if (present(a8)) then 00949 oldnames(8) = a8 00950 numoldnames = 8 00951 endif 00952 if (present(a9)) then 00953 oldnames(9) = a9 00954 numoldnames = 9 00955 endif 00956 if (present(a10)) then 00957 oldnames(10) = a10 00958 numoldnames = 10 00959 endif 00960 if (present(a11)) then 00961 oldnames(11) = a11 00962 numoldnames = 11 00963 endif 00964 if (present(a12)) then 00965 oldnames(12) = a12 00966 numoldnames = 12 00967 endif 00968 if (present(a13)) then 00969 oldnames(13) = a13 00970 numoldnames = 13 00971 endif 00972 if (present(a14)) then 00973 oldnames(14) = a14 00974 numoldnames = 14 00975 endif 00976 if (present(a15)) then 00977 oldnames(15) = a15 00978 numoldnames = 15 00979 endif 00980 if (present(a16)) then 00981 oldnames(16) = a16 00982 numoldnames = 16 00983 endif 00984 if (present(a17)) then 00985 oldnames(17) = a17 00986 numoldnames = 17 00987 endif 00988 if (present(a18)) then 00989 oldnames(18) = a18 00990 numoldnames = 18 00991 endif 00992 if (present(a19)) then 00993 oldnames(19) = a19 00994 numoldnames = 19 00995 endif 00996 if (present(a20)) then 00997 oldnames(20) = a20 00998 numoldnames = 20 00999 endif 01000 01001 end subroutine setoldnames 01002 01003 subroutine read_v_array(fid,a) 01004 use xmpi_module 01005 ! 01006 ! reads array from unit fid 01007 ! to be called by everyone 01008 ! only xmaster reads 01009 ! fid is only needed on xmaster 01010 ! 01011 integer, intent(in) :: fid 01012 real*8, dimension(:), intent(out) :: a 01013 if (xmaster) then 01014 read(fid,*) a 01015 endif 01016 #ifdef USEMPI 01017 call xmpi_bcast(a,readkey_inio) 01018 #endif 01019 end subroutine read_v_array 01020 01021 subroutine read_v_9(fid,a,a1,a2,a3,a4,a5,a6,a7,a8) 01022 use xmpi_module 01023 ! 01024 ! reads doubles from unit fid 01025 ! to be called by everyone 01026 ! only xmaster reads 01027 ! fid is only needed on xmaster 01028 ! 01029 integer, intent(in) :: fid 01030 real*8, intent(out) :: a 01031 real*8, optional, intent(out) :: a1,a2,a3,a4,a5,a6,a7,a8 01032 if (present(a8)) then 01033 if(xmaster) read(fid,*) a,a1,a2,a3,a4,a5,a6,a7,a8 01034 #ifdef USEMPI 01035 call xmpi_bcast(a1,readkey_inio) 01036 call xmpi_bcast(a2,readkey_inio) 01037 call xmpi_bcast(a3,readkey_inio) 01038 call xmpi_bcast(a4,readkey_inio) 01039 call xmpi_bcast(a5,readkey_inio) 01040 call xmpi_bcast(a6,readkey_inio) 01041 call xmpi_bcast(a7,readkey_inio) 01042 call xmpi_bcast(a8,readkey_inio) 01043 #endif 01044 elseif (present(a7)) then 01045 if(xmaster) read(fid,*) a,a1,a2,a3,a4,a5,a6,a7 01046 #ifdef USEMPI 01047 call xmpi_bcast(a1,readkey_inio) 01048 call xmpi_bcast(a2,readkey_inio) 01049 call xmpi_bcast(a3,readkey_inio) 01050 call xmpi_bcast(a4,readkey_inio) 01051 call xmpi_bcast(a5,readkey_inio) 01052 call xmpi_bcast(a6,readkey_inio) 01053 call xmpi_bcast(a7,readkey_inio) 01054 #endif 01055 elseif (present(a6)) then 01056 if(xmaster) read(fid,*) a,a1,a2,a3,a4,a5,a6 01057 #ifdef USEMPI 01058 call xmpi_bcast(a1,readkey_inio) 01059 call xmpi_bcast(a2,readkey_inio) 01060 call xmpi_bcast(a3,readkey_inio) 01061 call xmpi_bcast(a4,readkey_inio) 01062 call xmpi_bcast(a5,readkey_inio) 01063 call xmpi_bcast(a6,readkey_inio) 01064 #endif 01065 elseif (present(a5)) then 01066 if(xmaster) read(fid,*) a,a1,a2,a3,a4,a5 01067 #ifdef USEMPI 01068 call xmpi_bcast(a1,readkey_inio) 01069 call xmpi_bcast(a2,readkey_inio) 01070 call xmpi_bcast(a3,readkey_inio) 01071 call xmpi_bcast(a4,readkey_inio) 01072 call xmpi_bcast(a5,readkey_inio) 01073 #endif 01074 elseif (present(a4)) then 01075 if(xmaster) read(fid,*) a,a1,a2,a3,a4 01076 #ifdef USEMPI 01077 call xmpi_bcast(a1,readkey_inio) 01078 call xmpi_bcast(a2,readkey_inio) 01079 call xmpi_bcast(a3,readkey_inio) 01080 call xmpi_bcast(a4,readkey_inio) 01081 #endif 01082 elseif (present(a3)) then 01083 if(xmaster) read(fid,*) a,a1,a2,a3 01084 #ifdef USEMPI 01085 call xmpi_bcast(a1,readkey_inio) 01086 call xmpi_bcast(a2,readkey_inio) 01087 call xmpi_bcast(a3,readkey_inio) 01088 #endif 01089 elseif (present(a2)) then 01090 if(xmaster) read(fid,*) a,a1,a2 01091 #ifdef USEMPI 01092 call xmpi_bcast(a1,readkey_inio) 01093 call xmpi_bcast(a2,readkey_inio) 01094 #endif 01095 elseif (present(a1)) then 01096 if(xmaster) read(fid,*) a,a1 01097 #ifdef USEMPI 01098 call xmpi_bcast(a1,readkey_inio) 01099 #endif 01100 else 01101 if(xmaster) read(fid,*) a 01102 endif 01103 #ifdef USEMPI 01104 call xmpi_bcast(a,readkey_inio) 01105 #endif 01106 end subroutine read_v_9 01107 01108 integer function count_lines(f) 01109 ! 01110 ! returns number of lines in file f 01111 ! to be called by all, xmaster will count 01112 ! result is broadcasted to all 01113 ! 01114 use xmpi_module 01115 use filefunctions 01116 character(len=*), intent(in) :: f 01117 integer lines,fid,ierr 01118 if(xmaster) then 01119 fid = create_new_fid() 01120 open(fid,file=f) 01121 lines = 0 01122 ierr = 0 01123 do while(ierr == 0) 01124 read(fid,*,iostat=ierr) 01125 if (ierr == 0) lines = lines+1 01126 enddo 01127 close(fid) 01128 endif 01129 #ifdef USEMPI 01130 call xmpi_bcast(lines,readkey_inio) 01131 #endif 01132 count_lines = lines 01133 01134 end function count_lines 01135 01136 character(slen) function strippedline(line) 01137 01138 character(slen),intent(in) :: line 01139 integer :: itab 01140 01141 do itab=1,slen 01142 if (ichar(line(itab:itab))<32 .or. ichar(line(itab:itab))>126) then ! this is anything not in standard 01143 ! alphanumeric 01144 strippedline(itab:itab) = ' ' 01145 else 01146 strippedline(itab:itab) = line(itab:itab) 01147 endif 01148 enddo 01149 01150 end function 01151 end module readkey_module
1.7.6.1
