module param 21,30
!@sum param does all the bookkeeping for input parameters
!@auth I. Aleinov
!@ver 1.0
!@usage This module has the following public subroutines. Most of them
!@+ are Fortramn 90 interfaces, i.e. they recognize the type of the
!@+ variables implicitly and call corresponding subroutine.
!@+
!@+ Simple copy routines to copy parameters to/from database:
!@+ set_param( name, value, dim, opt ) - put a parameter with the
!@+ name <name> and the value <value> to the database
!@+ get_param( name, value, dim ) - copy the value of the parameter
!@+ <name> from the database to the variable <value>
!@+
!@+ Query logical function:
!@+ is_set_param( name ) - returns .true. if parameter <name> is
!@+ present in the database, .false. otherwise
!@+ sync_param( name, value, dim ) - puts parameter <name> into the
!@+ database if it is not yet there, otherwise gets it
!@+
!@+ Subroutines to work with pointers:
!@+ alloc_param( name, pvalue, initval, dim ) - allocates space in
!@+ the database for the parameter <name>, fills it with data
!@+ provided in <initval> and returns pointer to it in <pvalue>
!@+ get_pparam( name, pvalue, dim ) - returns pointer <pvalue> to
!@+ the parameter data of the parameter <name> in the database
!@+
!@+ Reading/writing subroutines:
!@+ read_param( kunit, ovrwrt ) - reads the parameter database from
!@+ the unit <kunit>
!@+ write_param( kunit ) - writes the parameter database to the unit
!@+ <kunit>
!@+
!@+ Other useful subroutines:
!@+ print_param( kunit ) - does formatted output to the unit <kunit>
!@+ in a way similar to namelist
!@+ query_param( n, name, dim, ptype ) - returns information about
!@+ the parameter by its number in the database <n>. It returns
!@+ 'EMPTY' in the <name> if no parameter with such an <n> exists
!@+ (i.e. if <n> is bigger than the number of parameters)
!@+
!@+ The formal arguments in the subroutines are:
!@+ name - character*(*) - the name of the parameter which is a
!@+ character string no longer than 32 bytes
!@+ value - a scalar variable or a linear array of type: integer,
!@+ real*8,character*1 to character*128
!@+ dim - integer - dimension of an array; omit 'dim' for scalars
!@+ opt - character*1 - an optional "option" (opt='o' means
!@+ "overwrite")
!@+ kunut - integer - unit number for reading/writing
!@+ ptype - character*1, intent(out) - returns the type of the
!@+ parameter: 'i' for integer, 'r' for real*8, 'c' for character
!@+ ovrwrt - logical - if .true. then reading overwrites those
!@+ parameters that are already in the database. If .false. then
!@+ those parameters which are already in the database are left
!@+ unchanged and only new parameters are added.
!@+
!@+ Read FAQ's for the full description.
!@+
!@+ CHANGE LOG:
!@+ 04/18/02 added 3 bytes to ParamStr so that its size is
!@+ divisible by 4 (needed for portability SGI,LINUX <-> IBM,COMPAQ).
!@+ Header renamed to "PARAM02 "
implicit none
save
private
public set_param, get_param, get_pparam, read_param, write_param
public is_set_param, alloc_param, sync_param, print_param
public query_param
integer, parameter :: MAX_PARAMS = 256
integer, parameter :: MAX_RPARAMS = 128
integer, parameter :: MAX_IPARAMS = 256
integer, parameter :: MAX_CPARAMS = 64
integer, parameter :: MAX_NAME_LEN = 32
integer, parameter :: MAX_CHAR_LEN = 128
character*80 :: MODULE_HEADER='PARAM02 '
type ParamStr
character(MAX_NAME_LEN) name ! parameter name
integer indx ! storage for its value
integer dim ! number of elements
character(1) attrib ! type: real ('r') or int ('i')
character(1) reserved(3)
end type ParamStr
type (ParamStr), target :: Params(MAX_PARAMS)
real*8, target :: Rdata(MAX_RPARAMS)
integer, target :: Idata(MAX_IPARAMS)
character*(MAX_CHAR_LEN), target :: Cdata(MAX_CPARAMS)
integer :: num_param = 0
integer :: num_rparam = 0
integer :: num_iparam = 0
integer :: num_cparam = 0
interface set_param
module procedure set_iparam
, set_rparam, set_cparam
module procedure set_aiparam, set_arparam, set_acparam
end interface
interface get_param
module procedure get_iparam, get_rparam, get_cparam
module procedure get_aiparam, get_arparam, get_acparam
end interface
interface get_pparam
module procedure get_piparam, get_prparam, get_pcparam
module procedure get_paiparam, get_parparam, get_pacparam
end interface
interface alloc_param
module procedure alloc_iparam, alloc_rparam, alloc_cparam
module procedure alloc_aiparam, alloc_arparam, alloc_acparam
end interface
interface sync_param
module procedure sync_iparam, sync_rparam, sync_cparam
module procedure sync_aiparam, sync_arparam, sync_acparam
end interface
contains
function is_set_param( name_in ) 18,1
implicit none
character*(*), intent(in) :: name_in
logical is_set_param
integer n
character*(MAX_NAME_LEN) name
name = name_in
call lowcase( name )
do n=1,num_param
if ( Params(n)%name == name ) exit
enddo
if ( n > num_param ) then
is_set_param = .false.
else
is_set_param = .true.
endif
return
end function is_set_param
subroutine set_pstr( name_in, dim, attrib, PStr, flag ) 3,8
implicit none
character*(*), intent(in) :: name_in
integer, intent(in) :: dim
character*1, intent(in) :: attrib
type (ParamStr), pointer :: PStr
logical, intent(in) :: flag
character*(MAX_NAME_LEN) name
if ( len(name_in) > MAX_NAME_LEN ) then
print *, 'PARAM: parameter name too long: ', name_in
print *, 'PARAM: maximal length allowed: ', MAX_NAME_LEN
call stop_model('PARAM: parameter name too long: ',255)
endif
name = name_in
call lowcase( name )
call get_pstr( name, dim, attrib, PStr )
if ( associated( PStr ) ) then
if ( .not. flag ) then
print *, 'PARAM: attempt to set param which is already set'
print *, 'name: ', name
call stop_model(
& 'PARAM: attempt to set param which is already set',255)
else
return ! return PStr found by get_pstr
endif
endif
if ( num_param >= MAX_PARAMS ) then
print *, 'PARAM: Maximal number of parameters exceeded'
print *, 'PARAM: Please recompile param with bigger MAX_PARAMS'
call stop_model(
& 'PARAM: Maximal number of parameters exceeded',255)
endif
num_param = num_param + 1
PStr => Params(num_param)
PStr%name = name
PStr%attrib = attrib
PStr%dim = dim
PStr%reserved(1:3) = (/ ' ', ' ', ' ' /)
select case (attrib)
case ('i')
if ( num_iparam+dim >= MAX_IPARAMS ) then
print *, 'PARAM: Maximal number of int parameters exceeded'
print *, 'PARAM: Recompile param with bigger MAX_IPARAMS'
call stop_model(
& 'PARAM: Maximal number of int parameters exceeded',255)
endif
PStr%indx = num_iparam + 1
num_iparam = num_iparam + dim
case ('r')
if ( num_rparam+dim >= MAX_RPARAMS ) then
print *, 'PARAM: Maximal number of real parameters exceeded'
print *, 'PARAM: Recompile param with bigger MAX_RPARAMS'
call stop_model(
& 'PARAM: Maximal number of real parameters exceeded',255)
endif
PStr%indx = num_rparam + 1
num_rparam = num_rparam + dim
case ('c')
if ( num_cparam+dim >= MAX_CPARAMS ) then
print *, 'PARAM: Maximal number of char parameters exceeded'
print *, 'PARAM: Recompile param with bigger MAX_CPARAMS'
call stop_model(
& 'PARAM: Maximal number of char parameters exceeded',255)
endif
PStr%indx = num_cparam + 1
num_cparam = num_cparam + dim
end select
return
end subroutine set_pstr
subroutine get_pstr( name_in, dim, attrib, PStr ) 10,2
implicit none
character*(*), intent(in) :: name_in
integer, intent(in) :: dim
character*1, intent(in) :: attrib
type (ParamStr), pointer :: PStr
integer n
character*(MAX_NAME_LEN) name
name = name_in
call lowcase( name )
nullify( PStr )
do n=1,num_param
if ( Params(n)%name == name ) exit
enddo
if ( n > num_param ) return ! not found - return NULL
if ( Params(n)%attrib /= attrib .or. Params(n)%dim /= dim ) then
print *, 'PARAM: wrong type or dim of parameter: ', name
print *, 'ATT: set: ', Params(n)%attrib, ' called: ', attrib
print *, 'DIM: set: ', Params(n)%dim, ' called: ', dim
call stop_model('PARAM: wrong type or dim of parameter',255)
endif
PStr => Params(n)
return
end subroutine get_pstr
!***** integers ******!
subroutine set_iparam( name, value, opt ) 1,1
implicit none
character*(*), intent(in) :: name
integer, intent(in) :: value
character*1, optional, intent(in) :: opt
integer v(1)
v(1) = value
call set_aiparam( name, v, 1, opt )
return
end subroutine set_iparam
subroutine set_aiparam( name, value, np, opt ) 4,1
implicit none
character*(*), intent(in) :: name
integer, intent(in) :: np
integer, intent(in) :: value(np)
character*1, optional, intent(in) :: opt
type (ParamStr), pointer :: PStr
logical flag
flag = .false.
if ( present(opt) ) then
if ( opt=='o' ) flag = .true.
endif
call set_pstr( name, np, 'i', PStr, flag )
Idata( PStr%indx : PStr%indx+np-1 ) = value(1:np)
return
end subroutine set_aiparam
subroutine get_iparam( name, value ) 1,1
implicit none
character*(*), intent(in) :: name
integer, intent(out) :: value
integer v(1)
call get_aiparam( name, v, 1 )
value = v(1)
return
end subroutine get_iparam
subroutine get_aiparam( name, value, np ) 2,2
implicit none
character*(*), intent(in) :: name
integer, intent (in) :: np
integer, intent(out) :: value(np)
type (ParamStr), pointer :: PStr
call get_pstr( name, np, 'i', PStr )
if ( .not. associated( PStr) ) then
print *, 'PARAM: Can''t get - not in database : ', name
call stop_model(
& 'PARAM: Can''t get parameter - not in database',255)
endif
value(1:np) = Idata( PStr%indx : PStr%indx+np-1 )
return
end subroutine get_aiparam
subroutine get_piparam( name, pvalue ) 1,2
implicit none
character*(*), intent(in) :: name
integer, pointer :: pvalue
type (ParamStr), pointer :: PStr
call get_pstr( name, 1, 'i', PStr )
if ( .not. associated( PStr) ) then
print *, 'PARAM: Can''t get - not in database : ', name
call stop_model(
& 'PARAM: Can''t get parameter - not in database',255)
endif
pvalue => Idata( PStr%indx )
return
end subroutine get_piparam
subroutine get_paiparam( name, pvalue, np ) 1,2
implicit none
character*(*), intent(in) :: name
integer, pointer :: pvalue(:)
integer, intent(in) :: np
type (ParamStr), pointer :: PStr
call get_pstr( name, np, 'i', PStr )
if ( .not. associated( PStr) ) then
print *, 'PARAM: Can''t get - not in database : ', name
call stop_model(
& 'PARAM: Can''t get parameter - not in database',255)
endif
pvalue => Idata( PStr%indx:PStr%indx+np-1 )
return
end subroutine get_paiparam
!***** reals ******!
subroutine set_rparam( name, value, opt ) 1,1
implicit none
character*(*), intent(in) :: name
real*8, intent(in) :: value
character*1, optional, intent(in) :: opt
real*8 v(1)
v(1) = value
call set_arparam( name, v, 1, opt )
return
end subroutine set_rparam
subroutine set_arparam( name, value, np, opt ) 4,1
implicit none
character*(*), intent(in) :: name
integer, intent(in) :: np
real*8, intent(in) :: value(np)
character*1, optional, intent(in) :: opt
type (ParamStr), pointer :: PStr
logical flag
flag = .false.
if ( present(opt) ) then
if ( opt=='o' ) flag = .true.
endif
call set_pstr( name, np, 'r', PStr, flag )
Rdata( PStr%indx : PStr%indx+np-1 ) = value(1:np)
return
end subroutine set_arparam
subroutine get_rparam( name, value ) 1,1
implicit none
character*(*), intent(in) :: name
real*8, intent(out) :: value
real*8 v(1)
call get_arparam( name, v, 1 )
value = v(1)
return
end subroutine get_rparam
subroutine get_arparam( name, value, np ) 2,2
implicit none
character*(*), intent(in) :: name
integer, intent (in) :: np
real*8, intent(out) :: value(np)
type (ParamStr), pointer :: PStr
call get_pstr( name, np, 'r', PStr )
if ( .not. associated( PStr) ) then
print *, 'PARAM: Can''t get - not in database : ', name
call stop_model(
& 'PARAM: Can''t get parameter - not in database',255)
endif
value(1:np) = Rdata( PStr%indx : PStr%indx+np-1 )
return
end subroutine get_arparam
subroutine get_prparam( name, pvalue ) 1,2
implicit none
character*(*), intent(in) :: name
real*8, pointer :: pvalue
type (ParamStr), pointer :: PStr
call get_pstr( name, 1, 'r', PStr )
if ( .not. associated( PStr) ) then
print *, 'PARAM: Can''t get - not in database : ', name
call stop_model(
& 'PARAM: Can''t get parameter - not in database',255)
endif
pvalue => Rdata( PStr%indx )
return
end subroutine get_prparam
subroutine get_parparam( name, pvalue, np ) 1,2
implicit none
character*(*), intent(in) :: name
real*8, pointer :: pvalue(:)
integer, intent(in) :: np
type (ParamStr), pointer :: PStr
call get_pstr( name, np, 'r', PStr )
if ( .not. associated( PStr) ) then
print *, 'PARAM: Can''t get - not in database : ', name
call stop_model(
& 'PARAM: Can''t get parameter - not in database',255)
endif
pvalue => Rdata( PStr%indx:PStr%indx+np-1 )
return
end subroutine get_parparam
!***** Chars ******!
subroutine set_cparam( name, value, opt ) 1,2
implicit none
character*(*), intent(in) :: name
character*(*), intent(in) :: value
character*1, optional, intent(in) :: opt
character*(MAX_CHAR_LEN) v(1)
if ( len(value) > MAX_CHAR_LEN ) then
print *, 'PARAM: Char string too long. MAX = ', MAX_CHAR_LEN
call stop_model('PARAM: Char string too long',255)
endif
v(1) = value
call set_acparam( name, v, 1, opt )
return
end subroutine set_cparam
subroutine set_acparam( name, value, np, opt ) 4,2
implicit none
character*(*), intent(in) :: name
integer, intent(in) :: np
character*(*), intent(in) :: value(np)
character*1, optional, intent(in) :: opt
type (ParamStr), pointer :: PStr
integer n
logical flag
flag = .false.
if ( present(opt) ) then
if ( opt=='o' ) flag = .true.
endif
do n=1,np
if ( len(value(n)) > MAX_CHAR_LEN ) then
print *, 'PARAM: Char string too long. MAX = ', MAX_CHAR_LEN
print *, 'You submitted LEN = ', len(value(n))
call stop_model('PARAM: Char string too long',255)
endif
enddo
call set_pstr( name, np, 'c', PStr, flag )
Cdata( PStr%indx : PStr%indx+np-1 ) = value(1:np)
return
end subroutine set_acparam
subroutine get_cparam( name, value ) 1,1
implicit none
character*(*), intent(in) :: name
character*(*), intent(out) :: value
character*(MAX_CHAR_LEN) v(1)
call get_acparam( name, v, 1 )
value = v(1)
return
end subroutine get_cparam
subroutine get_acparam( name, value, np ) 2,2
implicit none
character*(*), intent(in) :: name
integer, intent (in) :: np
character*(*), intent(out) :: value(np)
type (ParamStr), pointer :: PStr
call get_pstr( name, np, 'c', PStr )
if ( .not. associated( PStr) ) then
print *, 'PARAM: Can''t get - not in database : ', name
call stop_model(
& 'PARAM: Can''t get parameter - not in database',255)
endif
value(1:np) = Cdata( PStr%indx : PStr%indx+np-1 )
return
end subroutine get_acparam
subroutine get_pcparam( name, pvalue ) 1,2
implicit none
character*(*), intent(in) :: name
character*(*), pointer :: pvalue
type (ParamStr), pointer :: PStr
call get_pstr( name, 1, 'c', PStr )
if ( .not. associated( PStr) ) then
print *, 'PARAM: Can''t get - not in database : ', name
call stop_model(
& 'PARAM: Can''t get parameter - not in database',255)
endif
pvalue => Cdata( PStr%indx )
return
end subroutine get_pcparam
subroutine get_pacparam( name, pvalue, np ) 1,2
implicit none
character*(*), intent(in) :: name
character*(*), pointer :: pvalue(:)
integer, intent(in) :: np
type (ParamStr), pointer :: PStr
call get_pstr( name, np, 'c', PStr )
if ( .not. associated( PStr) ) then
print *, 'PARAM: Can''t get - not in database : ', name
call stop_model(
& 'PARAM: Can''t get parameter - not in database',255)
endif
pvalue => Cdata( PStr%indx:PStr%indx+np-1 )
return
end subroutine get_pacparam
!***** alloc fuctions ******
subroutine alloc_iparam( name, pvalue, initval ) 1
implicit none
character*(*), intent(in) :: name
integer, pointer :: pvalue
integer, intent(in) :: initval
call set_param( name, initval )
call get_pparam( name, pvalue )
end subroutine alloc_iparam
subroutine alloc_aiparam( name, pvalue, initval, dim ) 1
implicit none
character*(*), intent(in) :: name
integer, pointer :: pvalue(:)
integer, intent(in) :: initval(:)
integer, intent(in) :: dim
call set_param( name, initval, dim )
call get_pparam( name, pvalue, dim )
end subroutine alloc_aiparam
subroutine alloc_rparam( name, pvalue, initval ) 1
implicit none
character*(*), intent(in) :: name
real*8, pointer :: pvalue
real*8, intent(in) :: initval
call set_param( name, initval )
call get_pparam( name, pvalue )
end subroutine alloc_rparam
subroutine alloc_arparam( name, pvalue, initval, dim ) 1
implicit none
character*(*), intent(in) :: name
real*8, pointer :: pvalue(:)
real*8, intent(in) :: initval(:)
integer, intent(in) :: dim
call set_param( name, initval, dim )
call get_pparam( name, pvalue, dim )
end subroutine alloc_arparam
subroutine alloc_cparam( name, pvalue, initval ) 1
implicit none
character*(*), intent(in) :: name
character*(*), pointer :: pvalue
character*(*), intent(in) :: initval
call set_param( name, initval )
call get_pparam( name, pvalue )
end subroutine alloc_cparam
subroutine alloc_acparam( name, pvalue, initval, dim ) 1
implicit none
character*(*), intent(in) :: name
character*(*), pointer :: pvalue(:)
character*(*), intent(in) :: initval(:)
integer, intent(in) :: dim
call set_param( name, initval, dim )
call get_pparam( name, pvalue, dim )
end subroutine alloc_acparam
!***** sync functions ******!
subroutine sync_iparam( name, value ) 1,1
implicit none
character*(*), intent(in) :: name
integer, intent(inout) :: value
if ( is_set_param( name ) ) then
call get_param( name, value )
else
call set_param( name, value )
endif
end subroutine sync_iparam
subroutine sync_aiparam( name, value, np ) 1,1
implicit none
character*(*), intent(in) :: name
integer, intent(in) :: np
integer, intent(inout) :: value(np)
if ( is_set_param( name ) ) then
call get_param( name, value, np )
else
call set_param( name, value, np )
endif
end subroutine sync_aiparam
subroutine sync_rparam( name, value ) 1,1
implicit none
character*(*), intent(in) :: name
real*8, intent(inout) :: value
if ( is_set_param( name ) ) then
call get_param( name, value )
else
call set_param( name, value )
endif
end subroutine sync_rparam
subroutine sync_arparam( name, value, np ) 1,1
implicit none
character*(*), intent(in) :: name
integer, intent(in) :: np
real*8, intent(inout) :: value(np)
if ( is_set_param( name ) ) then
call get_param( name, value, np )
else
call set_param( name, value, np )
endif
end subroutine sync_arparam
subroutine sync_cparam( name, value ) 1,1
implicit none
character*(*), intent(in) :: name
character*(*), intent(inout) :: value
if ( is_set_param( name ) ) then
call get_param( name, value )
else
call set_param( name, value )
endif
end subroutine sync_cparam
subroutine sync_acparam( name, value, np ) 1,1
implicit none
character*(*), intent(in) :: name
integer, intent(in) :: np
character*(*), intent(inout) :: value(np)
if ( is_set_param( name ) ) then
call get_param( name, value, np )
else
call set_param( name, value, np )
endif
end subroutine sync_acparam
!***** input / output ******!
subroutine read_param( kunit, ovrwrt ) 3,8
implicit none
integer, intent(in) :: kunit
logical, intent(in) :: ovrwrt
integer n
type (ParamStr), save :: LParams(MAX_PARAMS)
real*8, save :: LRdata(MAX_RPARAMS)
integer, save :: LIdata(MAX_IPARAMS)
character*(MAX_CHAR_LEN), save :: LCdata(MAX_CPARAMS)
integer lnum_param, lnum_rparam, lnum_iparam, lnum_cparam
character*80 HEADER
read( kunit, err=10 ) HEADER
backspace kunit
if (HEADER(1:8).ne.MODULE_HEADER(1:8)) then
if (HEADER(1:8).eq.'PARAM01 ') then
print *, 'WARNING: PARAM: Old format of parameter data.'
call read_param_comp01( kunit, ovrwrt )
return
else
print * , 'PARAM: No parameter header in input data'
call stop_model(
& 'PARAM: No parameter header in input data',255)
endif
endif
read( kunit, err=10 ) HEADER,
* lnum_param, lnum_rparam, lnum_iparam, lnum_cparam,
* ( LParams(n), n=1,min(lnum_param,MAX_PARAMS) ),
* ( LRdata(n), n=1,min(lnum_rparam,MAX_RPARAMS) ),
* ( LIdata(n), n=1,min(lnum_iparam,MAX_IPARAMS) ),
* ( LCdata(n), n=1,min(lnum_cparam,MAX_CPARAMS) )
if ( lnum_param > MAX_PARAMS
* .or. lnum_rparam > MAX_RPARAMS
* .or. lnum_iparam > MAX_IPARAMS
* .or. lnum_cparam > MAX_CPARAMS
* ) then
print *, 'PARAM: parameter list in input file too long'
print *, 'PARAM: please recompile param with bigger MAX_?PARAMS'
print *, 'PARAM: ',num_param,num_rparam,num_iparam,num_cparam
call stop_model(
& 'PARAM: parameter list in input file too long',255)
endif
if ( lnum_param < 1 ) return ! no parameters in the records
! checking big/little endian format, just in case
if ( LParams(1)%dim > 65536 .or. LParams(1)%dim < 0 ) then
print *, 'PARAM: wrong big/little endian format in LParams.'
call stop_model(
& 'PARAM: wrong big/little endian format in LParams',255)
endif
! now merge the data just read with existing database
do n=1,lnum_param
if ( select case( LParams(n)%attrib )
case ('i')
call set_aiparam( LParams(n)%name, LIdata(LParams(n)%indx),
* LParams(n)%dim, 'o' )
case ('r')
call set_arparam( LParams(n)%name, LRdata(LParams(n)%indx),
* LParams(n)%dim, 'o' )
case ('c')
call set_acparam( LParams(n)%name, LCdata(LParams(n)%indx),
* LParams(n)%dim, 'o' )
end select
endif
enddo
return
10 print *, 'PARAM: Error reading, unit = ', kunit
call stop_model('PARAM: Error reading',255)
end subroutine read_param
subroutine write_param( kunit ) 1,1
implicit none
integer, intent(in) :: kunit
integer n
write (MODULE_HEADER(9:80),'(i10,a)')
* num_param,' is the current number of parameters in database DB'
write( kunit, err=20 ) MODULE_HEADER,
* num_param, num_rparam, num_iparam, num_cparam,
* ( Params(n), n=1,min(num_param,MAX_PARAMS) ),
* ( Rdata(n), n=1,min(num_rparam,MAX_RPARAMS) ),
* ( Idata(n), n=1,min(num_iparam,MAX_IPARAMS) ),
* ( Cdata(n), n=1,min(num_cparam,MAX_CPARAMS) )
return
20 print *, 'PARAM: Error writing, unit = ', kunit
call stop_model('PARAM: Error writing',255)
end subroutine write_param
subroutine print_param1( kunit )
implicit none
integer, intent(in) :: kunit
integer, parameter :: nf = 7
integer n, i
write( kunit, * ) '&&PARAMETERS'
do n=1, num_param
select case( Params(n)%attrib )
case ('i')
write( kunit, '(1x,a16,a3,8i16)' )
$ Params(n)%name, ' = ',
$ ( Idata(Params(n)%indx+i), i=0,min(Params(n)%dim,nf)-1 )
if ( Params(n)%dim > nf )
$ write( kunit, '(20x,8i16)' )
$ ( Idata(Params(n)%indx+i), i=0,Params(n)%dim-nf-1 )
case ('r')
write( kunit, '(1x,a16,a3,8g16.6)' )
$ Params(n)%name, ' = ',
$ ( Rdata(Params(n)%indx+i), i=0,min(Params(n)%dim,nf)-1 )
if ( Params(n)%dim > nf )
$ write( kunit, '(20x,8g16.6)' )
$ ( Rdata(Params(n)%indx+i), i=0,Params(n)%dim-nf-1 )
case ('c')
write( kunit, '(1x,a16,a3,8a128)' )
$ Params(n)%name, ' = ',
$ ( Cdata(Params(n)%indx+i), i=0,min(Params(n)%dim,nf)-1 )
if ( Params(n)%dim > nf )
$ write( kunit, '(20x,8a128)' )
$ ( Cdata(Params(n)%indx+i), i=0,Params(n)%dim-nf-1 )
end select
enddo
write( kunit, * ) '&&END_PARAMETERS'
end subroutine print_param1
subroutine print_param( kunit ) 2
implicit none
integer, intent(in) :: kunit
integer, parameter :: nf = 7
integer n, i
write( kunit, * ) '&&PARAMETERS'
do n=1, num_param
select case( Params(n)%attrib )
case ('i')
write( kunit, * )
$ trim(Params(n)%name), ' = ',
$ ( Idata(Params(n)%indx+i), i=0,Params(n)%dim-1 )
case ('r')
write( kunit, * )
$ trim(Params(n)%name), ' = ',
$ ( Rdata(Params(n)%indx+i), i=0,Params(n)%dim-1 )
case ('c')
write( kunit, * )
$ trim(Params(n)%name), ' = ',
$ ( Cdata(Params(n)%indx+i), i=0,Params(n)%dim-1 )
end select
enddo
write( kunit, * ) '&&END_PARAMETERS'
end subroutine print_param
subroutine query_param( n, name, dim, ptype )
integer, intent(in) :: n
character*(*), intent(out) :: name
integer, intent(out) :: dim
character*1, intent(out) :: ptype
if ( n>0 .and. n<=num_param ) then
name = Params(n)%name
dim = Params(n)%dim
ptype = Params(n)%attrib
else
name = 'EMPTY'
dim = 0
ptype = 'U'
endif
end subroutine query_param
subroutine lowcase( str ) 3
! converts string str to lower case
implicit none
character*(*) str
integer n, i
integer A, Z, shift, c
A = iachar( 'A' )
Z = iachar( 'Z' )
shift = iachar( 'a' ) - iachar( 'A' )
n = len_trim(str)
do i=1,n
c = iachar( str(i:i) )
if ( c>=A .and. c<=Z ) str(i:i) = achar( c + shift )
enddo
end subroutine lowcase
!**** the code below is included for compatibility with older ****
!**** versions; it may be removed later when not needed any more ****
subroutine read_param_comp01( kunit, ovrwrt ) 1,6
implicit none
type ParamStr_comp01
character(MAX_NAME_LEN) name ! parameter name
integer indx ! storage for its value
integer dim ! number of elements
character*1 attrib ! type: real ('r') or int ('i')
end type ParamStr_comp01
integer, intent(in) :: kunit
logical, intent(in) :: ovrwrt
integer n
type (ParamStr_comp01), save :: LParams(MAX_PARAMS)
real*8, save :: LRdata(MAX_RPARAMS)
integer, save :: LIdata(MAX_IPARAMS)
character*(MAX_CHAR_LEN), save :: LCdata(MAX_CPARAMS)
integer lnum_param, lnum_rparam, lnum_iparam, lnum_cparam
character*80 HEADER
read( kunit, err=10 ) HEADER
backspace kunit
if (HEADER(1:8).ne.'PARAM01 ') then
print *, 'PARAM: No parameter header in input data'
call stop_model('PARAM: No parameter header in input data',255)
endif
read( kunit, err=10 ) HEADER,
* lnum_param, lnum_rparam, lnum_iparam, lnum_cparam,
* ( LParams(n), n=1,min(lnum_param,MAX_PARAMS) ),
* ( LRdata(n), n=1,min(lnum_rparam,MAX_RPARAMS) ),
* ( LIdata(n), n=1,min(lnum_iparam,MAX_IPARAMS) ),
* ( LCdata(n), n=1,min(lnum_cparam,MAX_CPARAMS) )
if ( lnum_param > MAX_PARAMS
* .or. lnum_rparam > MAX_RPARAMS
* .or. lnum_iparam > MAX_IPARAMS
* .or. lnum_cparam > MAX_CPARAMS
* ) then
print *, 'PARAM: parameter list in input file too long'
print *, 'PARAM: please recompile param with bigger MAX_?PARAMS'
print *, 'PARAM: ',num_param,num_rparam,num_iparam,num_cparam
call stop_model(
& 'PARAM: parameter list in input file too long',255)
endif
! now merge the data just read with existing database
do n=1,lnum_param
if ( select case( LParams(n)%attrib )
case ('i')
call set_aiparam( LParams(n)%name, LIdata(LParams(n)%indx),
* LParams(n)%dim, 'o' )
case ('r')
call set_arparam( LParams(n)%name, LRdata(LParams(n)%indx),
* LParams(n)%dim, 'o' )
case ('c')
call set_acparam( LParams(n)%name, LCdata(LParams(n)%indx),
* LParams(n)%dim, 'o' )
end select
endif
enddo
return
10 print *, 'PARAM: Error reading, unit = ', kunit
call stop_model('PARAM: Error reading',255)
end subroutine read_param_comp01
end module param
!**** this should be put somewhere else, but since it is used only ****
!**** in this module I put it here for a while ... ****
subroutine swap_bytes_4( c, ndim )
integer n,ndim
character*1 c(4,ndim),temp
!@sum does conversion big<->little - endian for 4 byte data
!@auth I. Aleinov
!@ver 1.0
do n=1,ndim
temp = c(1,n)
c(1,n) = c(4,n)
c(4,n) = temp
temp = c(2,n)
c(2,n) = c(3,n)
c(3,n) = temp
end do
end subroutine swap_bytes_4