SUBROUTINE ARRAYINIT(iarray,nstart,nend)
C ARRAYINIT INITIALIZES ALL ELEMENTS IN A ONE DIMENSIONAL
C INTEGER ARRAY TO ZERO
dimension iarray(nstart:nend)
do 50 n=nstart,nend
50 iarray(n)=0
return
end
SUBROUTINE CHECK_MISSING(nvartype,cvar,nspvar,
* intvar,dvar,xvar,cfill,ifill,xfill,dfill,
* ihasfill,nspfill,ismissing)
C CHECK_MISSING CHECKS FOR MISSING VALUE
c ismissing=1 when value is equal to fill (missing) value
character*(*) cvar
character*(*) cfill
double precision dvar,dfill
include 'netcdf.inc'
ismissing=0
if ( ihasfill .eq. 1 ) then
if ( nvartype .eq. NF_CHAR ) then
if ( nspvar .eq. nspmissing .and.
* cvar(1:nspvar) .eq. cfill(1:nspvar) )
* ismissing=1
elseif ( nvartype .eq. NF_INT ) then
if ( intvar .eq. ifill ) ismissing=1
elseif ( nvartype .eq. NF_DOUBLE ) then
xvar=dvar
xfill=dfill
call checkforfill(xvar,xfill,ismissing)
elseif ( nvartype .eq. NF_FLOAT ) then
call checkforfill(xvar,xfill,ismissing)
endif
endif
return
end
SUBROUTINE CHECKFORFILL(xval,fillval,isfill)
C CHECKS IF VALUE IS A FILL VALUE
C SETS ISFILL=1 IF VALUE IS A FILL VALUE
isfill=1
isnan=isitnan(xval)
if ( isnan .eq. 0 ) then
isnan=isitnan(fillval)
if (
* (isnan .ne. 0 )
* .or.
* (fillval .gt. 0. .and. xval .lt. fillval)
* .or.
* (fillval .lt. 0. .and. xval .gt. fillval)
* ) then
isfill=0
endif
endif
return
end
SUBROUTINE CLEARSTRING(c,nsize)
C CLEARSTRING INITIALIZES A CHARACTER STRING WITH
C BLANKS
character*(*) c
do 80 n=1,nsize
80 c(n:n)=' '
return
end
SUBROUTINE FINDLASTCHAR(nspace,carray,maxspace)
C FINDLASTCHAR FINDS THE LOCATION OF THE LAST NON-BLANK
C IN A CHARACTER STRING
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c Passed Variables:
c
c nspace - distance, in characters, from the beginning of
c the character string where the last non-blank
c character is found
c carray - character string to be examined
c maxspace - maximum number of characters in character array
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
character*(*) carray
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c Initialize nspace
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
nspace=-1
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c Look at each character in string. If a character is a blank
c set the value of nspace. If a nonblank character is found,
c nspace is set to zero.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
do 50 n=1,maxspace
c write(6,*) 'x50',n,'|',carray(n:n),'|'
c if ( carray(n:n) .eq. CHAR(0) ) then
i=isitreturn(carray(n:n))
if ( i .eq. 1 ) then
if ( nspace .eq. 0 ) then
nspace=n
endif
goto 4
endif
if ( carray(n:n) .eq. " " .and. nspace .eq. 0 ) nspace=n
if ( carray(n:n) .ne. " ") nspace=0
50 continue
4 continue
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c If a blank is not found, set nspace to maxspace.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
if ( nspace.eq.0 ) nspace=maxspace+1
if ( nspace .eq. -1 ) nspace=1
nspace=nspace-1
return
end
SUBROUTINE GETMEASUREDPOSRAGGED(maxvar,ivarpos,ncastnow,ncid,
* ivarposnow,nlevels,identifyvar,identifytype,nvar_loc,
* ivar_loc,npi_loc,nplank_loc,nvarsp,npiposnow,
* npipos,nplankposnow,nplankpos)
C GETMEASUREDPOSRAGGED RETRIEVES POSITION IN NETCDF FILE
C FOR EACH VARIABLE TO BE READ IN (RAGGED ARRAY)
dimension identifytype(maxvar),identifyvar(maxvar)
dimension ivarposnow(maxvar),ivarpos(maxvar)
dimension ivar_loc(maxvar)
dimension index(1)
include 'netcdf.inc'
nlevels=0
nvar_loc=0
npi_loc=0
nplank_loc=0
index(1)=ncastnow
do 55 n=1,nvarsp
c row_size 7 or 8
if ( identifytype(n) .eq. 7 .or.
* identifytype(n) .eq. 8 ) then
instat=nf_get_var1_int(ncid,n,index,intval)
ii=identifyvar(n)
if ( instat .ne. 0 ) then
write(6,*) 'Problem reading in rowsize:',ii,instat
endif
if ( intval .gt. 0 ) then
if ( ii .ge. 0 ) then
ivarposnow(ii)=ivarpos(ii)
ivarpos(ii)=ivarpos(ii)+intval
elseif ( ii .eq. -1 ) then
npiposnow=npipos
npipos=npipos+intval
elseif ( ii .eq. -2 ) then
nplankposnow=nplankpos
nplankpos=nplankpos+intval
endif
if ( ii .gt. 0 ) then
nvar_loc=nvar_loc+1
ivar_loc(nvar_loc)=ii
elseif ( ii .eq. 0 ) then
nlevels=intval
elseif ( ii .eq. -1 ) then
npi_loc=intval
elseif ( ii .eq. -2 ) then
nplank_loc=intval
endif
else
ivarposnow(ii)=-1
endif
endif
55 continue
return
end
SUBROUTINE GETNCATTS(maxcatt,natttype,ncid,
* lencatt,cattributeval,iattval,xattval,dattval,
* maxattval,cfill, maxcfill,ifill,xfill,dfill,ihasfill,
* lencfill,cvarfullname,nvarsp,maxcvar,maxlencunit,
* lencvarfull,lencunit,cattname,maxvar,cunitname,iyear0,
* maxatt,identifytype,identifyvar,nvaratt,bmiss,lencattval,
* iquod)
C GETNCATTS GETS ATTRIBUTES AND SETS UP NEEDED ATTRIBUTES
C IN APPROPRIATE ARRAYS
parameter (neededatt=4,maxglobal=500)
character*4 time_variable
character*5 depth_variable
character*20 catttype(neededatt)
character*240 cinput
character*(maxglobal) cglobal
c maxcfill characters
character*(*) cfill(maxvar)
c maxlencunit characters
character*(*) cunitname(maxvar)
c maxattval characters
character*(*) cattributeval(maxvar,maxatt)
c maxcvar characters
character*(*) cvarfullname(maxvar)
c maxcatt characters
character*(*) cattname(0:maxvar,maxatt)
dimension nspatttype(neededatt)
dimension nvaratt(0:maxvar)
dimension natttype(0:maxvar,maxatt)
dimension lencatt(0:maxvar,maxatt)
dimension lencattval(maxvar,maxatt)
dimension lencfill(maxvar),lencvarfull(maxvar)
dimension iattval(maxvar,maxatt),xattval(maxvar,maxatt)
dimension dattval(maxvar,maxatt),dfill(maxvar)
dimension ifill(maxvar),ihasfill(maxvar)
dimension xfill(maxvar),lencunit(maxvar)
dimension identifytype(maxvar),identifyvar(maxvar)
double precision dattval,dfill
c Necessary attributes
data catttype /'units','_FillValue','standard_name',
* 'long_name'/
data nspatttype /5,10,13,9/
c Special variable - get base year from units attribute
data time_variable /'time'/
data nsptime_variable /4/
c Special variable - levels always set by 'depth' variable
data depth_variable /'depth'/
data lendepth_variable /5/
include 'netcdf.inc'
itimevariable=0
idepthvariable=0
c Check global attributes 'title' to see if this
c is IQuOD or WOD type file
do 30 na=1,nvaratt(0)
c Get attributes for each variable
nsp=lencatt(0,na)
cinput(1:nsp)=cattname(0,na)(1:nsp)
if ( nsp .eq. 5 .and.
* cinput(1:nsp) .eq. 'title' ) then
call clearstring(cglobal,maxglobal)
instat=nf_get_att_text(ncid,0,cinput(1:nsp),
* cglobal)
if ( cglobal(1:5) .eq. 'IQuOD' ) then
iquod=1
endif
endif
30 continue
do 40 n=1,nvarsp
c Initialize needed attributes
call clearstring(cvarfullname(n),maxcvar)
lencvarfull(n)=0
call clearstring(cunitname(n),maxlencunit)
lencunit(n)=0
call clearstring(cfill(n),maxcfill)
lencfill(n)=0
ifill(n)=0
xfill(n)=bmiss
dfill(n)=bmiss
ihasfill(n)=0
do 45 na=1,nvaratt(n)
nsp=lencatt(n,na)
cinput(1:nsp)=cattname(n,na)(1:nsp)
iattribute=-1
do 75 n2=1,neededatt
if ( nsp .eq. nspatttype(n2) .and. cinput(1:nsp) .eq.
* catttype(n2)(1:nsp) ) then
iattribute=n2
endif
75 continue
if ( natttype(n,na) .eq. NF_CHAR ) then
call clearstring(cattributeval(n,na),maxattval)
instat=nf_get_att_text(ncid,n,cinput(1:nsp),
* cattributeval(n,na))
elseif ( natttype(n,na) .eq. NF_SHORT .or.
* natttype(n,na) .eq. NF_INT ) then
instat=nf_get_att_int(ncid,n,cinput(1:nsp),
* iattval(n,na))
elseif ( natttype(n,na) .eq. NF_FLOAT ) then
instat=nf_get_att_real(ncid,n,cinput(1:nsp),
* xattval(n,na))
elseif ( natttype(n,na) .eq. NF_DOUBLE ) then
instat=nf_get_att_double(ncid,n,cinput(1:nsp),
* dattval(n,na))
endif
if ( instat .eq. 0 ) then
if ( natttype(n,na) .eq. NF_CHAR ) then
call findlastchar(lencattval(n,na),cattributeval(n,na),
* maxattval)
elseif ( natttype(n,na) .eq. NF_DOUBLE ) then
xattval(n,na)=dattval(n,na)
endif
else
write(6,*) 'Attribute reading problem:',instat,
* n,cinput(1:nsp)
endif
if ( iattribute .eq. 1 ) then
cunitname(n)(1:lencattval(n,na))=
* cattributeval(n,na)(1:lencattval(n,na))
lencunit(n)=lencattval(n,na)
elseif ( iattribute .eq. 2 ) then
c _Fill Value
if ( natttype(n,na) .eq. NF_CHAR ) then
cfill(n)(1:lencattval(n,na))=
* cattributeval(n,na)(1:lencattval(n,na))
lencfill(n)=lencattval(n,na)
elseif ( natttype(n,na) .eq. NF_SHORT .or.
* natttype(n,na) .eq. NF_INT ) then
ifill(n)=iattval(n,na)
elseif ( natttype(n,na) .eq. NF_FLOAT ) then
xfill(n)=xattval(n,na)
elseif ( natttype(n,na) .eq. NF_DOUBLE ) then
dfill(n)=dattval(n,na)
xfill(n)=dattval(n,na)
endif
ihasfill(n)=1
elseif ( iattribute .eq. 3 ) then
cvarfullname(n)(1:lencattval(n,na))=
* cattributeval(n,na)(1:lencattval(n,na))
lencvarfull(n)=lencattval(n,na)
c Check for time variable
if ( lencvarfull(n) .eq. nsptime_variable .and.
* cvarfullname(n)(1:lencvarfull(n)) .eq.
* time_variable(1:nsptime_variable) ) then
itimevariable=n
c Check for depth variable
elseif ( lencvarfull(n) .eq. lendepth_variable .and.
* cvarfullname(n)(1:lencvarfull(n)) .eq.
* depth_variable(1:lendepth_variable) ) then
idepthvariable=n
endif
elseif ( iattribute .eq. 4 .and. lencvarfull(n) .eq. 0 ) then
cvarfullname(n)(1:lencattval(n,na))=
* cattributeval(n,na)(1:lencattval(n,na))
lencvarfull(n)=lencattval(n,na)
endif
45 continue
40 continue
c Get base year
if ( itimevariable .gt. 0 ) then
read(cunitname(itimevariable)(12:15),*) iyear0
endif
c Depth variable is variable zero (0) the variable to which
c all other profile variables are co-measured. Reset all
c other variables codes accordingly (subtract 1 from all
c variable sequence encountered after depth variable).
if ( idepthvariable .gt. 0 ) then
identifyvar(idepthvariable)=0
do 50 nn=1,nvarsp
if ( identifytype(nn) .ge. 0 .and.
* identifytype(nn) .le. 9 ) then
if ( identifyvar(nn) .gt. identifyvar(idepthvariable) )
* identifyvar(nn)=identifyvar(nn)-1
endif
50 continue
endif
return
end
SUBROUTINE GETNCINFO(ncid,nvarsp,nvaratt,nunlimdim,
* maxdim,maxvar,maxatt,ndimval,lencdim,nvartype,nvardims,
* nvardimid,lencvar,natttype,nattlen,lencatt,cattname,
* cdimname,cvarname,maxcdim,maxcvar,maxcatt,ndimsp)
C GETNCINFO EXTRACTS INFORMATION ON DIMENSIONS
C AND VARIABLES FROM NETCDF FILE
parameter (maxdim_loc=50)
character*(*) cdimname(maxdim)
character*(*) cvarname(maxvar)
character*(*) cattname(0:maxvar,maxatt)
character*500 cdum
dimension ndimval(maxdim),lencdim(maxdim)
dimension nvaratt(0:maxvar)
dimension nvartype(maxvar),nvardims(maxvar)
dimension nvardimidT(maxdim_loc)
dimension nvardimid(maxvar,maxdim)
dimension lencvar(maxvar)
dimension natttype(0:maxvar,maxatt)
dimension nattlen(0:maxvar,maxatt)
dimension lencatt(0:maxvar,maxatt)
include 'netcdf.inc'
c get number of dimensions, variables, global attributes
instat=nf_inq(ncid,ndimsp,nvarsp,nvaratt(0),nunlimdim)
if ( instat .ne. 0 ) then
write(6,*) 'problem with nf_inq:',instat
endif
if ( nvarsp .gt. maxvar ) then
write(6,*) 'number of variables > maxvar:',nvarsp
stop
endif
if ( ndimsp .gt. maxdim ) then
write(6,*) 'number of dimensions > maxdim:',ndimsp
stop
endif
c write(6,*) 'number of dimensions:',ndimsp
c write(6,*) 'number of variables:',nvarsp
c write(6,*) 'number of global attributes:',nvaratt(0)
c get dimension names, values
do 30 n=1,ndimsp
call clearstring(cdimname(n),maxcdim)
instat=nf_inq_dim(ncid,n,cdimname(n),ndimval(n))
if ( instat .ne. 0 ) then
write(6,*) 'problem with dimension:',n,instat
else
call findlastchar(lencdim(n),cdimname(n),maxcdim)
endif
c write(6,*) 'dimension name #',n,lencdim(n),
c * cdimname(n)(1:lencdim(n)),maxcdim
30 continue
c get variable names, values, dimensions
c write(6,*) 'NFVALUES',NF_CHAR,NF_SHORT,NF_INT,NF_FLOAT,
c * NF_DOUBLE
do 40 n=1,nvarsp
call clearstring(cvarname(n),maxcvar)
instat=nf_inq_var(ncid,n,cvarname(n),nvartype(n),
* nvardims(n), nvardimidT,nvaratt(n))
if ( instat .ne. 0 ) then
write(6,*) 'problem with variable inq:',n,instat
else
do 45 nn=1,nvardims(n)
45 nvardimid(n,nn)=nvardimidT(nn)
call findlastchar(lencvar(n),cvarname(n),maxcvar)
endif
40 continue
c get attribute names
do 50 n=0,nvarsp
if ( n .ne. 0 ) then
nx=n
else
nx=NF_GLOBAL
endif
do 55 n2=1,nvaratt(n)
call clearstring(cattname(n,n2),maxcatt)
instat=nf_inq_attname(ncid,nx,n2,cattname(n,n2))
if ( instat .ne. 0 ) then
write(6,*) 'problem with variable inq:',n,n2,instat
else
call findlastchar(lencatt(n,n2),cattname(n,n2),maxcatt)
endif
instat=nf_inq_att(ncid,nx,cattname(n,n2)(1:lencatt(n,n2)),
* natttype(n,n2),nattlen(n,n2))
if ( instat .ne. 0 ) then
write(6,*) 'problem with variable inq:',n,n2,
* cattname(n,n2)(1:lencatt(n,n2)),instat
endif
c write(6,*) 'attribute #',n,n2,lencatt(n,n2),
c * cattname(n,n2)(1:lencatt(n,n2)),maxcatt,natttype(n,n2),
c * nattlen(n,n2)
55 continue
50 continue
return
end
SUBROUTINE GETNCVARS(nvarsp,nvarobs,identifyvar,identifytype,
* nvardims,nvardimid,lencdim,cdimname,lencvar,cvarname,
* cvarobsname,nspvarobs,maxdim,maxvar)
C GETNCVARS GETS VARIABLE CODE AND SORTS INTO CATEGORIES IN
C ORDER TO BEST REPRESENT PROFILE DATA
parameter (ncategory=6,nprimehead=8)
parameter (notherdims=3,nrowsize=3)
character*8 cplanktonsample
character*15 crowsize(nrowsize)
character*20 cotherdim(notherdims)
character*20 ccategory(ncategory)
character*20 cpiname
character*30 cprimehead(nprimehead)
character*(*) cvarobsname(maxvar)
character*(*) cdimname(maxdim)
character*(*) cvarname(maxvar)
dimension nspcategory(ncategory)
dimension nspprimehead(nprimehead)
dimension nspotherdim(notherdims)
dimension nsprowsize(nrowsize)
dimension identifytype(maxvar),identifyvar(maxvar)
dimension lencdim(maxdim)
dimension nvardims(maxvar)
dimension nvardimid(maxvar,maxdim)
dimension lencvar(maxvar),nspvarobs(maxvar)
c Categories:
c 1 [profile variable] (has dimension [variable_name]_obs)
c attribute units
c attribute _FillValue
c attribute standard_name
c attribute long_name
c 2 _sigfigs
c 3 _WODflag
c 4 _IQUODflag
c 5 _origflag
c 6 _uncertainty
data ccategory /'_obs','_sigfigs','_WODflag','_IQUODflag',
* '_origflag','_uncertainty'/
data nspcategory /4,8,8,10,9,12/
c Row size representations
c 7 _row_size
c 8 _rowsize (_row_size for primary investigators)
c Other single value profile variable dependent variable
c 9 _WODprofileflag
data crowsize /'_row_size','_rowsize','_WODprofileflag'/
data nsprowsize /9,8,15/
data cotherdim /'casts','biosets','numberofpis'/
data nspotherdim /5,7,11/
c Primary header variables (category 10)
c 1 - time (year,month,day, GMT time)
c 2 - WOD_cruise_identifier
c 3 - lat
c 4 - lon
c 5 - wod_unique_cast
c 6 - country
c 7 - originators_cruise_identifier
c 8 - originators_station_identifier
c
data cprimehead /'time','WOD_cruise_identifier','lat','lon',
* 'wod_unique_cast','country','originators_cruise_identifier',
* 'originators_station_identifier'/
data nspprimehead /4,21,3,3,15,7,29,30/
c Primary investigator variables (variable (-1) )
data cpiname /'Primary_Investigator'/
data nspipiname /20/
c Plankton variables (variable (-2) )
data cplanktonsample /'plankton'/
data nspplankton /8/
c Number of profile variables (including depth)
nvarobs=0
do 75 n=1,nvarsp
c Initialize variable identifier and variable category
c Categories are
c profile variable or variable descriptor (1-9)
c primary header (10)
c primary investigator or descriptor (11)X
c plankton tow or descriptor (12)X
c cast secondary header (13)
c variable specific second header (14)
identifyvar(n)=0
identifytype(n)=0
c Dimension of profile variable will be [variable_name]_obs
ivarcheck=0
len1v=0
ivarfound=0
if ( nvardims(n) .eq. 1 ) then
c dimension [variable_name]_obs
len2=lencdim(nvardimid(n,1))
len1=len2-3
if ( cdimname(nvardimid(n,1))(len1:len2) .eq.
* ccategory(1)(1:nspcategory(1)) ) then
c Assume this is the variable itself
ivarcheck=1
len1v=lencvar(n)
c Check if this is a variable descriptor
do 35 nn=2,ncategory
if ( ivarcheck .eq. 1 ) then
len2=lencvar(n)
len1=(len2-nspcategory(nn))+1
if ( len1 .gt. 0 .and. cvarname(n)(len1:len2) .eq.
* ccategory(nn)(1:nspcategory(nn)) ) then
ivarcheck=nn
len1v=len1-1
endif
endif
35 continue
endif
c or row_size/profile flag
if ( ivarcheck .eq. 0 ) then
do 36 nn=1,nrowsize
if ( ivarcheck .eq. 0 ) then
len2=lencvar(n)
len1=(len2-nsprowsize(nn))+1
if ( len1 .gt. 0 .and. cvarname(n)(len1:len2) .eq.
* crowsize(nn)(1:nsprowsize(nn)) ) then
ivarcheck=ncategory+nn
len1v=len1-1
endif
endif
36 continue
endif
c See if profile variable has been encountered before
if ( ivarcheck .gt. 0 ) then
do 80 nn=1,nvarobs
80 if ( nspvarobs(nn) .eq. len1v .and.
* cvarobsname(nn)(1:nspvarobs(nn)) .eq.
* cvarname(n)(1:len1v) ) ivarfound=nn
c Set profile variable information for reading in
if ( ivarfound .eq. 0 ) then
nvarobs=nvarobs+1
ivarfound=nvarobs
cvarobsname(ivarfound)(1:len1v)=cvarname(n)(1:len1v)
nspvarobs(ivarfound)=len1v
endif
identifytype(n)=ivarcheck
identifyvar(n)=ivarfound
c Check if this is one of two special variables (primary investigator
c or plankton tow. These variables do not have
c [variablename]_obs dimensions, but they do have _row_size
c primary investigator is variable -1
c plankton is variable -2
if ( len1v .eq. nspipiname
* .and. cvarname(n)(1:len1v) .eq. cpiname(1:nspipiname) ) then
identifyvar(n)=-1
elseif ( len1v .eq. nspplankton .and. cvarname(n)(1:len1v) .eq.
* cplanktonsample(1:nspplankton) ) then
identifyvar(n)=-2
endif
endif
endif
c If not a profile variable, check if this is a primary header
c primary header (category 10)
if ( ivarfound .eq. 0 ) then
do 85 nn=1,nprimehead
if ( lencvar(n) .eq. nspprimehead(nn) .and.
* cvarname(n)(1:lencvar(n)) .eq.
* cprimehead(nn)(1:nspprimehead(nn)) ) then
ivarfound=nn
identifytype(n)=10
identifyvar(n)=ivarfound
endif
85 continue
endif
75 continue
c Check unidentified variables to see if they are
c second headers, variable specific second headers, primary
c investigator/descriptors, plankton
do 40 n=1,nvarsp
if ( identifytype(n) .eq. 0 .and. nvardims(n) .gt. 0 ) then
ivarfound=0
c See if first part of name is a known variable
do 60 nz=1,nvarobs
60 if ( nspvarobs(nz) .le. lencvar(n) .and.
* cvarobsname(nz)(1:nspvarobs(nz)) .eq.
* cvarname(n)(1:nspvarobs(nz)) ) ivarfound=nz
c Determine category by dimension name
do 45 nn=1,nvardims(n)
lend=lencdim(nvardimid(n,nn))
do 55 n3=1,notherdims
if ( lend .eq. nspotherdim(n3) .and.
* cdimname(nvardimid(n,nn))(1:lend) .eq.
* cotherdim(n3)(1:nspotherdim(n3)) ) then
c With dimension 'casts' is second header, check if
c variable specific (first part of name known variable)
if ( n3 .eq. 1 ) then
identifytype(n)=13
nspx=nspvarobs(ivarfound)
if ( ivarfound .gt. 0 .and. lencvar(n) .gt. nspx
* .and. cvarname(n)(nspx:nspx) .eq. '_' ) then
identifytype(n)=14
identifyvar(n)=ivarfound
endif
c check if plankton variable
elseif ( n3 .eq. 2 ) then
identifytype(n)=12
identifyvar(n)=-2
c check if primary investigator or primary investigator descriptor
c there is only one primary investigator descriptor (VAR, given
c category 2)
elseif ( n3 .eq. 3 ) then
identifytype(n)=11
if ( ivarfound .gt. 0 .and. lencvar(n) .eq.
* nspipiname ) then
identifyvar(n)=1
else
identifyvar(n)=2
endif
endif
endif
55 continue
45 continue
endif
40 continue
return
end
SUBROUTINE INITIALIZE_CAST_VARS(nsec_loc,nsp_origc,
* nsp_origs,iuniq,rlat,rlon,iyear,month,iday,time,
* ccruise,origs,origc,npi_loc,nplank_loc,nlevels,
* maxorigc,maxorigs,maxcountry,maxccruise,nvar_loc,
* ipi_loc,inplank_loc,country,nsp_country)
parameter (rlatmiss=-99.999,rlonmiss=-999.999)
parameter (iyearmiss=0,monthmiss=0,idaymiss=0)
parameter (timemiss=-99.999)
dimension ipi_loc(2)
character*(*) ccruise
character*(*) origc
character*(*) origs
character*(*) country
nsec_loc=0
nsp_origc=0
nsp_origs=0
nsp_country=0
iuniq=0
rlat=rlatmiss
rlon=rlonmiss
iyear=iyearmiss
month=monthmiss
iday=idaymiss
time=timemiss
call clearstring(ccruise,maxccruise)
call clearstring(origc,maxorigc)
call clearstring(origs,maxorigs)
nvar_loc=0
npi_loc=0
nplank_loc=0
nlevels=0
call clearstring(country,maxcountry)
ipi_loc(1)=0
ipi_loc(2)=0
inplank_loc=0
return
end
SUBROUTINE INITXUNC(xunc,maxlevel,maxcalc,nvarobs,bmiss)
C INITXUNC INITIALIZES UNCERTAINTY ARRAY
dimension xunc(maxlevel,0:maxcalc)
do 50 nn=0,nvarobs
do 55 n2=1,maxlevel
xunc(n2,nn)=bmiss
55 continue
50 continue
return
end
SUBROUTINE INSERTNUM(crep,nrep0,chars,maxchar)
C INSERTNUM REPLACES A GIVEN CHARACTER WITH THE
C CORRESPONDING NUMBER
c***************************************************
c
c Passed Variables:
c
c crep - character to be replaced
c nrep0 - number to replace character
c chars - character string in which replacement will occur
c maxchar - maximum number of characters in chars
c
c****************************************************
character*1 crep
character*4 cform
character*(*) chars
data cform /'(iX)'/
inegative=0
nrep=nrep0
if ( nrep .lt. 0 ) then
nrep=-nrep
inegative=1
endif
c****************************************************
c
c Locate first occurance of character to be changed
c
c****************************************************
do 50 nn=1,maxchar
if ( chars(nn:nn) .eq. crep ) then
c****************************************************
c
c Locate last occurance of character to be changed
c
c****************************************************
do 51 n2=nn+1,maxchar
51 if ( chars(n2:n2) .ne. crep ) goto 52
52 n2=n2-1
nchar=(n2-nn)+1
nten=10**(nchar-inegative)
c******************************************************
c
c Check that there is sufficient room to write given
c number
c
c******************************************************
if ( nten+inegative .le. nrep ) then
write(6,800) 'Given number (',nrep0,
* ') is larger than space to be',
* ' written to'
write(6,*) 'nrep,nten,inegative ',nrep,nten,inegative
800 format(a14,i10,a28,a11)
return
endif
nadd=0
if ( inegative .eq. 1 ) then
chars(nn:nn)='-'
inegative=0
nadd=1
endif
c*****************************************************
c
c Enter necessary trailing zeros
c
c****************************************************
do 60 n3=2,nchar
nten=nten/10
if ( nrep .lt. nten ) then
chars(nn+nadd:nn+nadd)='0'
nadd=nadd+1
endif
60 continue
c*****************************************************
c
c Enter number
c
c*****************************************************
write(cform(3:3),'(i1)') nchar-nadd
write(chars(nn+nadd:nn+nchar-1),cform) nrep
return
endif
50 continue
return
end
SUBROUTINE NAILUJt(iyear0,iyear,month,iday,time,xjulian)
C COMPUTES CALENDAR DAY FROM JULIAN DAY, INCLUDING TIME, WITH RESPECTS
C TO MIDNIGHT JANUARY 1 OF THE BASE YEAR
C ADAPTED FROM ORIGINAL SUBROUTINE CREATED BY LINDA STATHOPOLIS
c*************************************************************
c
c Passed variables
c
c iyear0 - base year for calculating julian day
c iyear - present year
c month,iday - present month,day
c time - present time
c xjulian - output julian day
c
c************************************************************
parameter (bmiss=-1E10,zdays=365.,tmiss=99.99)
dimension yrnorm(13)
data yrnorm/0,31,59,90,120,151,181,212,243,273,304,334,365/
if ( xjulian .le. bmiss ) then
iyear=-9999
month=-99
iday=-99
return
endif
xadd=0.
iyearadd=0
xjulian0=xjulian
iyear=0
month=0
iday=0
if ( (iyear0/4)*4 .eq. iyear0 ) xadd=1.
if ( (iyear0/100)*100 .eq. iyear0 .and.
* (iyear0/400)*400 .ne. iyear0 ) xadd=0.
xj0=xjulian
ineg=0
if ( xjulian .lt. 0 ) then
ineg=1
xj0=-xj0
endif
if ( xj0 .ge. zdays+xadd ) then
call reducejulian(iyear0,xjulian0,iyearadd)
elseif (xjulian .lt. 0 ) then
iyearadd=-1
endif
c Set year
xadd=0.
iyear=iyear0+iyearadd
if ( (iyear/4)*4 .eq. iyear ) xadd=1.
if ( (iyear/100)*100 .eq. iyear .and.
* (iyear/400)*400 .ne. iyear ) xadd=0.
c Set month
xj0=xjulian0
if ( ineg .eq. 1 ) xj0=xjulian0+yrnorm(13)+xadd
x1=0.
do 30 mm=2,13
if ( mm .eq. 3 ) x1=xadd
if ( xj0 .lt. yrnorm(mm)+x1 ) then
month=mm-1
goto 31
endif
30 continue
31 continue
c Set day
iday=xj0-yrnorm(month)+1.
if ( month .ge. 3 .and. xadd .gt. 0. ) iday=iday-1
c Set time
ijulian=xj0
xjuliant=ijulian
time=(xj0-xjuliant)*24.
return
end
SUBROUTINE PUTINPIARRAY_RAGGED(ipi_loc,maxpi,
* cpi_loc,maxcpi,cpivar_loc,nsp_cpi,nsp_cpivar,
* cvar,nspvar,identifyvar)
character*(*) cpi_loc(maxpi)
character*(*) cpivar_loc(maxpi)
character*(*) cvar
dimension nsp_cpi(maxpi),nsp_cpivar(maxpi)
dimension ipi_loc(2)
ipi_loc(identifyvar)=ipi_loc(identifyvar)+1
ipi=ipi_loc(identifyvar)
c PI name
if ( identifyvar .eq. 1 ) then
cpi_loc(ipi)(1:nspvar)=cvar(1:nspvar)
nsp_cpi(ipi)=nspvar
elseif ( identifyvar .eq. 2 ) then
cpivar_loc(ipi)(1:nspvar)=cvar(1:nspvar)
nsp_cpivar(ipi)=nspvar
endif
return
end
SUBROUTINE PUTINHEADER_RAGGED(identifyvar,ismissing,iuniq,
* rlat,rlon,iyear,month,iday,origc,origs,ccruise,country,
* nsp_origc, nsp_origs,nsp_country,nsp_ccruise,cvar,nspvar,
* intvar,xvar,dvar,iyear0,time)
c Primary header variables (category 10)
c 1 - time (year,month,day, GMT time)
c 2 - WOD_cruise_identifier
c 3 - lat
c 4 - lon
c 5 - wod_unique_cast
c 6 - country
c 7 - originators_cruise_identifier
c 8 - originators_station_identifier
double precision dvar
character*(*) origc
character*(*) origs
character*(*) ccruise
character*(*) country
character*(*) cvar
if ( ismissing .eq. 0 ) then
if ( identifyvar .eq. 1 ) then
call nailujt(iyear0,iyear,month,iday,time,xvar)
elseif ( identifyvar .eq. 2 ) then
ccruise(1:nspvar)=cvar(1:nspvar)
nsp_ccruise=nspvar
elseif ( identifyvar .eq. 3 ) then
rlat=xvar
elseif ( identifyvar .eq. 4 ) then
rlon=xvar
elseif ( identifyvar .eq. 5 ) then
iuniq=intvar
elseif ( identifyvar .eq. 6 ) then
country(1:nspvar)=cvar(1:nspvar)
nsp_country=nspvar
elseif ( identifyvar .eq. 7 ) then
origc(1:nspvar)=cvar(1:nspvar)
nsp_origc=nspvar
elseif ( identifyvar .eq. 8 ) then
origs(1:nspvar)=cvar(1:nspvar)
nsp_origs=nspvar
endif
endif
return
end
SUBROUTINE PUTINPROFARRAY_RAGGED(identifyvar,
* nlevels,bmiss,identifytype,depth,temp,iderror,
* iorigflag,xunc,msig,ismissing,xvar,intvar,
* maxlevel,maxcalc,ierror)
dimension msig(maxlevel,0:maxcalc),depth(maxlevel)
dimension temp(maxlevel,maxcalc),iderror(maxlevel,0:maxcalc)
dimension iorigflag(maxlevel,0:maxcalc)
dimension xunc(maxlevel,0:maxcalc)
dimension ierror(maxlevel)
c profile variable
if ( identifyvar .lt. 0 ) return
if ( identifytype .eq. 1 ) then
if ( ismissing .eq. 0 ) then
if ( identifyvar .gt. 0 ) then
temp(nlevels,identifyvar)=xvar
else
depth(nlevels)=xvar
endif
else
if ( identifyvar .gt. 0 ) then
temp(nlevels,identifyvar)=bmiss
else
depth(nlevels)=bmiss
endif
endif
c significant figure
elseif ( identifytype .eq. 2 ) then
if ( ismissing .eq. 0 ) then
msig(nlevels,identifyvar)=intvar
else
msig(nlevels,identifyvar)=0
endif
c qc flag
elseif ( identifytype .eq. 3 .or.
* identifytype .eq. 4 ) then
if ( ismissing .eq. 0 ) then
iderror(nlevels,identifyvar)=intvar
else
iderror(nlevels,identifyvar)=0
endif
c originators qc flag
elseif ( identifytype .eq. 5 ) then
if ( ismissing .eq. 0 ) then
iorigflag(nlevels,identifyvar)=intvar
else
iorigflag(nlevels,identifyvar)=0
endif
c uncertainty
elseif ( identifytype .eq. 6 ) then
if ( ismissing .eq. 0 ) then
xunc(nlevels,identifyvar)=xvar
else
xunc(nlevels,identifyvar)=bmiss
endif
elseif ( identifytype .eq. 9 ) then
if ( ismissing .eq. 0 ) then
ierror(identifyvar)=intvar
else
ierror(identifyvar)=0
endif
endif
return
end
SUBROUTINE PUTINSECHEADER(identifyvar,ismissing,
* nsec_loc,ivarsec_loc,ivalsec_loc,xvalsec_loc,
* cvalsec_loc,isectype_loc,cvar,nspvar,intvar,xvar,
* nvartype,nspsec_loc,maxsec_loc,maxlensec,norder,
* isecorder_loc)
character*(*) cvalsec_loc(maxsec_loc)
character*(*) cvar
dimension ivarsec_loc(maxsec_loc),ivalsec_loc(maxsec_loc)
dimension xvalsec_loc(maxsec_loc),isectype_loc(maxsec_loc)
dimension nspsec_loc(maxsec_loc),isecorder_loc(maxsec_loc)
include 'netcdf.inc'
if ( nvartype .eq. NF_CHAR .and.
* nspvar .eq. 0 ) ismissing=1
if ( ismissing .eq. 0) then
nsec_loc=nsec_loc+1
ivarsec_loc(nsec_loc)=identifyvar
isectype_loc(nsec_loc)=nvartype
isecorder_loc(nsec_loc)=norder
if ( nvartype .eq. NF_CHAR ) then
call clearstring(cvalsec_loc(nsec_loc),maxlensec)
cvalsec_loc(nsec_loc)(1:nspvar)=cvar(1:nspvar)
nspsec_loc(nsec_loc)=nspvar
elseif ( nvartype .eq. NF_INT .or.
* nvartype .eq. NF_SHORT .or.
* nvartype .eq. NF_BYTE ) then
ivalsec_loc(nsec_loc)=intvar
else
xvalsec_loc(nsec_loc)=xvar
endif
endif
return
end
SUBROUTINE READNCVAR(nvartype,cvar,nspvar,maxcvar,
* ncid,ivarid,index,nindex,indexcount,nindexcount,
* intvar,dvar, xvar,instat,imiss,bmiss)
C READNCVAR READS IN NETCDF VARIABLE BASED
C ON INPUT PARAMETERS
character*(*) cvar
dimension index(nindex),indexcount(nindexcount)
double precision dvar
include 'netcdf.inc'
xvar=bmiss
dvar=bmiss
intvar=imiss
c write(6,*) 'nvartu[',nvartype
if ( nvartype .eq. NF_CHAR ) then
call clearstring(cvar,maxcvar)
instat= nf_get_vara_text(ncid,ivarid,index,
* indexcount,cvar)
call findlastchar(nspvar,cvar,maxcvar)
elseif ( nvartype .eq. NF_INT ) then
instat=
* nf_get_var1_int(ncid,ivarid,index,intvar)
elseif ( nvartype .eq. NF_SHORT ) then
instat=
* nf_get_var1_int(ncid,ivarid,index,intvar)
elseif ( nvartype .eq. NF_BYTE ) then
instat=
* nf_get_var1_int(ncid,ivarid,index,intvar)
elseif ( nvartype .eq. NF_DOUBLE ) then
instat=
* nf_get_var1_double(ncid,ivarid,index,dvar)
xvar=dvar
elseif ( nvartype .eq. NF_FLOAT ) then
instat=
* nf_get_var1_real(ncid,ivarid,index,xvar)
c write(6,*) 'var1',ivarid,index(1),xvar
else
write(6,*) 'Unknown var type:',ivarid,nvartype
endif
return
end
SUBROUTINE REDUCEJULIAN(iyear,rjul,iyearadd)
C REDUCEJULIAN REDUCES A MULTIYEAR JULIAN DATE TO
C YEAR AND SINGLE YEAR JULIAN DATE
parameter (xdays=366.)
iyearx=iyear
ineg=0
if ( rjul .lt. 0. ) then
ineg=1
iyearx=iyearx-1
endif
do 500 nz=1,300
xsub=1.
if ( (iyearx/4)*4 .eq. iyearx) xsub=0.
if ( (iyearx/100)*100 .eq. iyearx .and.
* (iyearx/400)*400 .ne. iyearx ) xsub=1.
if ( ineg .eq. 0 ) then
if ( rjul .ge. xdays-xsub ) then
iyearx=iyearx+1
rjul=rjul-(xdays-xsub)
else
goto 450
endif
else
if ( -rjul .ge. xdays-xsub ) then
iyearx=iyearx-1
rjul=rjul+(xdays-xsub)
else
goto 450
endif
endif
500 continue
450 continue
iyearadd=iyearx-iyear
return
end
PROGRAM WOD_nc
c This program prints out to the screen data from WOD ragged array
c netCDF file to the screen.
c
c Comments and suggestions for improving this program would be appreciated.
c Updates to the World Ocean Data data and to this program will be posted
c in the NCEI/WOD web site at http://www.nodc.noaa.gov
c***********************************************************
c
c Parameters (constants):
c
c maxlevel - maximum number of depth levels in a single cast
c maxcalc - maximum number of measured and calculated
c depth dependent variables
c maxpi - maximum number of primary investigators
c associated with a single cast
c bmiss, imiss - real and integer default missing value markers
c maxsec_loc - maximum number of secondary headers in a
c single cast
c maxcpi,maxcountry,maxorigc,maxorigs,maxxcruise,
c maxcdim,maxcvar,maxcatt,maxlensec - maximum character
c lengths for respective character arrays
c maxdim - maximum number of dimensions in netcdf file
c maxvar - maximum number of variables in netcdf file
c maxatt - maximum number of attributes for a single
c variable in netcdf file
c
c******************************************************************
parameter (maxlevel=30000, maxcalc=100)
parameter (bmiss=-1.E10,imiss=-99999)
parameter (maxlencunit=100)
parameter (maxpi=25,maxcpi=240)
parameter (maxsec_loc=400)
parameter (maxcountry=240,maxorigc=17,maxorigs=17)
parameter (maxccruise=10)
parameter (maxdim=50,maxvar=300,maxatt=100)
parameter (maxcdim=200,maxcvar=300,maxcatt=200)
parameter (maxcfill=300,maxattval=500)
parameter (maxlensec=200)
c******************************************************************
c
c Character Arrays:
c
c filename - input netcdf file name
c cdimname - name for each netcdf dimension
c cvarname - name for each netcdf variable
c cvarobsname - specific oceanograpic variable portion of
c netcdf variable names (e.g. 'Temperature'
c in 'Temperature_sigfigs')
c cattname - name for each netcdf attribute
c cvar - individual character variable read from netcdf file
c cfill - fill value for each netcdf character variable
c cattributeval - character value for netcdf attributes
c country - country of origin of oceanographic cast
c origc - originators cruise identifier
c origs - originators station identifier
c ccruise - WOD cruise identifier
c cpi_loc - primary investigator (PI) name(s) for individual cast
c cpivar_loc - variable(s) for which PI was responsible
c cunitname - units for each netcdf variable
c cvalsec_loc - secondary header character values for individual cast
c
c*****************************************************************
character*240 filename
character*(maxcdim) cdimname(maxdim)
character*(maxcvar) cvarname(maxvar),cvar,cvarobsname(maxvar)
character*(maxcfill) cfill(maxvar)
character*(maxcatt) cattname(0:maxvar,maxatt)
character*(maxcvar) cvarfullname(maxvar)
character*(maxattval) cattributeval(maxvar,maxatt)
character*(maxcountry) country
character*(maxorigc) origc
character*(maxorigs) origs
character*(maxccruise) ccruise
character*(maxcpi) cpi_loc(maxpi),cpivar_loc(maxpi)
character*(maxlencunit) cunitname(maxvar)
character*(maxlensec) cvalsec_loc(maxsec_loc)
c******************************************************************
c
c Arrays:
c
c ierror() - whole profile error codes for each variable
c
c ipi_loc() - individual cast counts of primary investigators information
c 1. primary investigator names
c 2. variables for which PI was responsible
c
c depth() - depth of each measurement
c
c msig() - number of significant figures in each measured variable at
c each level of measurement
c
c temp() - variable data at each depth level
c iderror() - error flags for each variable at each depth level
c xunc() - uncertainties for each measurement
c iorigflag()- originators flags for each variable and depth
c
c ndimval() - value of each netcdf dimension
c lencdim() - length of character string for each netcdf dimension
c (associated with cdimname)
c nvaratt() - number of attributes for each netcdf variable
c nvartype() - type (character, integer, real, double) of
c each netcdf variable
c nvardims() - number of dimensions in each netcdf variable
c nvardimid() - netcdf identifier for each dimension within
c each netcdf variable
c lencvar() - character length of each netcdf character variable
c (associated with cvarname)
c natttype() - type (character, integer, real, double) of
c each netcdf attribute
c nattlen() - character length of each netcdf attribute value
c (associated with cattval - note that this
c array is filled in getncinfo. It appears to
c contain duplicate information to lencattval,
c which is filled in getncatts by counting
c characters. One of these, probably lencattval
c should be replaced.)
c lencatt() - character length for each netcdf attribute name
c (associated with cattname)
c lencattval() - (see nattlen note above)
c lencunit() - length of character string for unit value for
c each netcdf variable
c
c
c*******************************************************************
dimension ierror(maxlevel)
dimension depth(maxlevel)
dimension msig(maxlevel,0:maxcalc)
dimension temp(maxlevel,maxcalc),iderror(maxlevel,0:maxcalc)
dimension xunc(maxlevel,0:maxcalc)
dimension iorigflag(maxlevel,0:maxcalc)
dimension ndimval(maxdim),lencdim(maxdim)
dimension nvaratt(0:maxvar)
dimension nvartype(maxvar),nvardims(maxvar)
dimension nvardimid(maxvar,maxdim)
dimension lencvar(maxvar),lencvarfull(maxvar)
dimension natttype(0:maxvar,maxatt)
dimension nattlen(0:maxvar,maxatt)
dimension lencatt(0:maxvar,maxatt)
dimension lencattval(maxvar,maxatt)
dimension lencunit(maxvar)
c lencfill() - length of character fill value for netcdf variables
c iattval() - integer value for netcdf attributes
c xattval() - real value for netcdf attributes
c dattval() - double precision value for netcdf attributes (no
c known values in WOD)
c dfill() - fill value for double precision netcdf variables
c (only 'time' variable in WOD, which has no missing values)
c identifytype() - category for each netcdf variable
c 1 [profile variable] (has dimension [variable_name]_obs)
c attribute units
c attribute _FillValue
c attribute standard_name
c attribute long_name
c 2 _sigfigs
c 3 _WODflag
c 4 _IQUODflag
c 5 _origflag
c 6 _uncertainty
c 7 _row_size
c 8 _rowsize (_row_size for primary investigators)
c Other single value profile variable dependent variable
c 9 _WODprofileflag
c 10 primary header
c 11 primary investigators
c 12 plankton information
c 13 secondary header
c 14 variable specific secondary header
c
c identifyvar() - sequential order of profile measured
c variables as listed in netcdf file
c nspvarobs - character length of each short variable name
c (name of oceanographic profile variable in netcdf
c variable name - 'Temperature' in 'Temperature_row_size'
c associated with cvarobsname)
c ivar_loc() - sequential order number of oceanographic profile
c variables (see identifyvar()) in an individual cast
c ivarpos() - position of oceanographic variable information
c for the present cast within the netcdf variable
c array (0 if no measurements of particular variable
c in the present cast).
c ivarposnow() - cumulative position of oceanographic variable information
c for last measurement of last cast with measurements of the
c particular oceanographic variable in the netcdf variable array
c (holder of cumulative information, even when present cast has
c zero row size - no measurements for cast).
c index(),indexcount() - indices for reading in netcdf values from
c given variable
c ifill() - integer fill value for each netcdf variable
c xfill() - real fill value for each netcdf variable
c nsp_cpi() - character length for primary investigator names
c (associated with cpi_loc)
c nsp_cpivar() - character length for variables for which primary
c investigator is responsible (associated with cpivar_loc)
c ihasfill() - set to 1 if the netcdf variable has a fill (missing)
c value
c ipi_loc - local counter of number of primary investigators and
c number of variables responsible for read in for
c current cast
c ivarsec_loc - sequential variable associated with each secondary
c header (zero if not variable specific)
c ivalsec_loc - secondary header integer value
c xvalsec_loc - secondary header real value
c isectype_loc() - type (character, integer, real) for each
c secondary header value
c nspsec_loc() - character length for each secondary header
c character value (associated with cvarsec_loc)
dimension lencfill(maxvar)
dimension iattval(maxvar,maxatt),xattval(maxvar,maxatt)
dimension dattval(maxvar,maxatt),dfill(maxvar)
dimension identifytype(maxvar),identifyvar(maxvar)
dimension nspvarobs(maxvar)
dimension ivar_loc(maxvar),ivarpos(maxvar),ivarposnow(maxvar)
dimension index(2),indexcount(2)
dimension ifill(maxvar),xfill(maxvar)
dimension ihasfill(maxvar)
dimension nsp_cpi(maxpi), nsp_cpivar(maxpi)
dimension ipi_loc(2)
dimension ivarsec_loc(maxsec_loc),ivalsec_loc(maxsec_loc)
dimension xvalsec_loc(maxsec_loc),isectype_loc(maxsec_loc)
dimension nspsec_loc(maxsec_loc),isecorder_loc(maxsec_loc)
double precision dattval,dfill
include 'netcdf.inc'
iquod=0
c*************************************************************
c
c Initialize variables which keep track of positions within
c variable arrays for current cast (npipos for primary
c investigators, nplankpos for plankton tow sets).
c
c*************************************************************
npiposnow=0
npipos=0
nplankposnow=0
nplankpos=0
call arrayinit(ivarpos,1,maxvar)
call arrayinit(ivarposnow,1,maxvar)
c**************************************************************
c
c Get user input file name from which casts will be
c taken. Open this file.
c
c**************************************************************
c User can modify the next section to read from a text file listing
c different input data files as a do-loop, for example, as opposed
c a single data input file.
write(6,*)' '
write(6,*)'Input File Name:'
read(5,'(a80)') filename
write(6,*)' '
write(6,*)' '
instat=nf_open(filename,NF_NOWRITE,ncid)
c Extract all dimension, variable, and attribute information
c from netcdf file.
c nvarsp - number of netcdf variables in file
c nvaratt - number of attributes for each netcdf variable in file
c nunlimdim - number of unlimited dimensions in netcdf file
c (none for WOD)
c ndimsp - number of dimensions in netcdf file
call getncinfo(ncid,nvarsp,nvaratt,nunlimdim,
* maxdim,maxvar,maxatt,ndimval,lencdim,nvartype,nvardims,
* nvardimid,lencvar,natttype,nattlen,lencatt,cattname,
* cdimname,cvarname,maxcdim,maxcvar,maxcatt,ndimsp)
c Sort netcdf variable information into categories:
c 1 profile variable (has dimension [variable_name]_obs)
c 2 significant figures
c 3 WOD qc flag
c 4 IQuOD qc flag
c 5 originators qc flag
c 6 uncertainty (IQuOD)
c 7 row size
c 8 row size (primary investigators)
c 9 WOD profile qc flag
c 10 primary header
c 11 primary investigator information
c 12 plankton tow information
c 13 secondary header
c 14 variable specific secondary header
c
c nvarobs - number of ocean profile variables in file
call getncvars(nvarsp,nvarobs,identifyvar,identifytype,
* nvardims,nvardimid,lencdim,cdimname,lencvar,cvarname,
* cvarobsname,nspvarobs,maxdim,maxvar)
c Get attribute information
c Main attributes:
c attribute units
c attribute _FillValue
c attribute standard_name
c attribute long_name
c
c Also look to global attributes to see if this is an
c IQuOD (1) or WOD (0) file (iquod variable)
c
c Also find the 'depth' standard name. This variable
c is the variable to which all oceanographic profile
c variables are associated.
call getncatts(maxcatt,natttype,ncid,
* lencatt,cattributeval,iattval,xattval,dattval,
* maxattval,cfill, maxcfill,ifill,xfill,dfill,ihasfill,
* lencfill,cvarfullname,nvarsp,maxcvar,maxlencunit,
* lencvarfull,lencunit,cattname,maxvar,cunitname,iyear0,
* maxatt,identifytype,identifyvar,nvaratt,bmiss,
* lencattval,iquod)
c initialize uncertainty for iquod. Not all variables will have
c uncertainties attached (only temperature, salinity, depth/press)
call initxunc(xunc,maxlevel,maxcalc,nvarobs,bmiss)
c Get number of casts dimensions
do 25 nd=1,ndimsp
25 if ( lencdim(nd) .eq. 5 .and. cdimname(nd)(1:lencdim(nd))
* .eq. 'casts' ) ncasts=ndimval(nd)
c Write out relevant whole file information:
c Variable sequential order (write out of each cast will
c refer to this sequential order when writing out
c variables measured in that cast), variable full
c name (either standard or long), short name (name consistent
c in array naming) and units.
call writewodfileinfo(iquod,nvarsp,identifytype,
* identifyvar,lencvarfull,cvarfullname,lencvar,
* cvarname,lencunit,cunitname,maxvar,ncasts)
write(6,*)
* 'Enter number of casts to view (0=view entire file)'
read(5,*) numcasts
if ( numcasts .eq. 0 ) numcasts=ncasts
do 50 ncastnow=1,numcasts !- MAIN CAST LOOP
c Initialize all necessary variables for next cast
c nsec_loc - number of secondary headers in this cast
c nsp_origc - character length for originators cruise
c identifier (origc, zero if not available for cast)
c iuniq - WOD unique cast number
c rlat,rlon - position of cast
c iyear,month,iday,time - derived from netcdf 'time'
c variable
c ccruise - WOD cruise identifier
c npi_loc - number of primary investigators for cast
c nplank_loc - number of plankton groups for cast
c nlevels - number of depth levels for cast. Each
c present oceanographic variable will have the same
c number of levels as depth (or 0 if not measured
c in this cast.
c maxorigc,maxorgs,maxcountry,maxccruise - maximum
c character lengths for character variables (used
c to initialize character variables
c nvar_loc - number of variables in the present cast
c ipi_loc - number of primary investigators and
c variables responsible for in this cast
c inplank_loc - number of plankton sets read in for
c this cast
c nsp_country - character length for country
call initialize_cast_vars(nsec_loc,nsp_origc,
* nsp_origs,iuniq,rlat,rlon,iyear,month,iday,time,
* ccruise,origs,origc,npi_loc,nplank_loc,nlevels,
* maxorigc,maxorigs,maxcountry,maxccruise,nvar_loc,
* ipi_loc,inplank_loc,country,nsp_country)
c Get position in arrays for this cast for each profile
c variable (+primary investigator, plankton)
c ivarpos will either be zero (variable not measured in
c this cast or the cumulative row sizes for all casts
c sequentially before the present cast in the netcdf file.
call getmeasuredposragged(maxvar,ivarpos,ncastnow,ncid,
* ivarposnow,nlevels,identifyvar,identifytype,nvar_loc,
* ivar_loc,npi_loc,nplank_loc,nvarsp,npiposnow,
* npipos,nplankposnow,nplankpos)
c Read in each variable for this cast
do 55 nx=1,nvarsp
c For profile variables (+ primary investigators, plantkon)
c read multiple levels per cast, otherwise one
nlend=1
if ( identifytype(nx) .ge. 1 .and.
* identifytype(nx) .le. 6 ) then
nlend=nlevels
elseif ( identifytype(nx) .eq. 11 ) then
nlend=npi_loc
elseif ( identifytype(nx) .eq. 12 ) then
nlend=nplank_loc
endif
ivarx=identifyvar(nx)
do 60 nl=1,nlend
c row size has already been used (in measuredposragged)
c dont read again
if ( identifytype(nx) .eq. 7 .or.
* identifytype(nx) .eq. 8 ) goto 60
c Set index values to read in netcdf variable instance
c based on variable category
index(1)=ncastnow
indexcount(1)=1
nindex=1
nindexcount=1
if ( identifytype(nx) .gt. 0 .and.
* identifytype(nx) .le. 6 ) then
index(1)=ivarposnow(ivarx)+nl
nindex=1
nindexcount=1
elseif ( identifytype(nx) .eq. 11 .or.
* identifytype(nx) .eq. 12 ) then
if ( identifytype(nx) .eq. 11 ) then
index(2)=npiposnow+nl
else
index(2)=nplankposnow+nl
endif
index(1)=1
indexcount(2)=1
indexcount(1)=ndimval(nvardimid(nx,1))
nindexcount=2
nindex=2
elseif ( nvartype(nx) .eq. NF_CHAR ) then
index(2)=ncastnow
index(1)=1
indexcount(2)=1
indexcount(1)=ndimval(nvardimid(nx,1))
nindexcount=2
nindex=2
endif
c Read in netcdf variable. Depending on type (nvartype)
c variable will be read in to cvar (character, with nspvar
c as character length), intvar (integer), xvar (real) or
c dvar (double precision, also read in to xvar)
call readncvar(nvartype(nx),cvar,nspvar,maxcvar,
* ncid,nx,index,nindex,indexcount,nindexcount,intvar,
* dvar,xvar,instat,imiss,bmiss)
c Check if the value read in is a missing value (ismissing=1)
call check_missing(nvartype(nx),cvar,nspvar,
* intvar,dvar,xvar,cfill(nx),ifill(nx),xfill(nx),dfill(nx),
* ihasfill(nx),lencfill(nx),ismissing)
c Put profile variable/associated fields in proper array
if ( identifytype(nx) .gt. 0 .and.
* identifytype(nx) .le. 9 ) then
call putinprofarray_ragged(identifyvar(nx),
* nl,bmiss,identifytype(nx),depth,temp,iderror,
* iorigflag,xunc,msig,ismissing,xvar,intvar,
* maxlevel,maxcalc,ierror)
c Put primary investigators information in local variables
elseif ( identifytype(nx) .eq. 11 ) then
call putinPIarray_ragged(ipi_loc,maxpi,cpi_loc,
* maxcpi,cpivar_loc,nsp_cpi,nsp_cpivar,cvar,
* nspvar,identifyvar(nx))
c Put plankton tow information in local variables
elseif ( identifytype(nx) .eq. 12 ) then
c call putinplankarray_ragged()
c Put header information in local variables
elseif ( identifytype(nx) .eq. 10 ) then
call putinheader_ragged(identifyvar(nx),ismissing,iuniq,
* rlat,rlon,iyear,month,iday,origc,origs,ccruise,country,
* nsp_origc,nsp_origs,nsp_country,nsp_ccruise,cvar,nspvar,
* intvar,xvar,dvar,iyear0,time)
c Put secondary headers in local variables
elseif ( identifytype(nx) .eq. 13 .or.
* identifytype(nx) .eq. 14 ) then
call putinsecheader(identifyvar(nx),ismissing,
* nsec_loc,ivarsec_loc,ivalsec_loc,xvalsec_loc,
* cvalsec_loc,isectype_loc,cvar,nspvar,intvar,xvar,
* nvartype(nx),nspsec_loc,maxsec_loc,maxlensec,nx,
* isecorder_loc)
endif
60 continue
55 continue
c Write out all cast information to screen
c Note rlonunc and rlatunc are planned for iquod, but
c not presently available so their values are set to missing.
rlatunc=bmiss
rlonunc=bmiss
call writewodtoscreen(ncastnow,iquod,nlevels,ccruise,rlat,
* rlatunc,rlon,rlonunc,iyear,month,iday,time,iuniq,nvar_loc,
* origc,origs,nsp_origc,nsp_origs,npi_loc,depth,iderror,
* iorigflag,temp,msig,xunc,ierror,isecorder_loc,
* isectype_loc,cvarname,lencvar,cvalsec_loc,nspsec_loc,
* ivalsec_loc,xvalsec_loc,maxsec_loc,maxvar,
* ivar_loc,maxlevel,maxcalc,nsec_loc,cpi_loc,cpivar_loc,
* nsp_cpi,nsp_cpivar,maxpi)
50 continue !- End of MAIN LOOP
4 continue !- EXIT
stop
end
SUBROUTINE WRITEWODFILEINFO(iquod,nvarsp,identifytype,
* identifyvar,lencvarfull,cvarfullname,lencvar,
* cvarname,lencunit,cunitname,maxvar,ncasts)
C WRITEWODFILEINFO WRITES TO SCREEN INFORMATION ABOUT WHAT
C VARIABLES ARE FOUND IN THE CHOSEN FILE
character*(*) cvarfullname(maxvar)
character*(*) cunitname(maxvar)
character*(*) cvarname(maxvar)
dimension lencunit(maxvar)
dimension lencvar(maxvar)
dimension lencvarfull(maxvar)
dimension identifytype(maxvar)
dimension identifyvar(maxvar)
if ( iquod .eq. 0 ) then
write(6,*) 'World Ocean Database (WOD) file'
else
write(6,*) 'International Quality Controlled',
* ' Oceanographic Database (IQuOD) file'
endif
write(6,*) ' '
write(6,*) 'Number of casts in file:',ncasts
write(6,*) ' '
write(6,*) 'Variables in file:'
do 50 n=1,nvarsp
if ( identifytype(n) .eq. 1 ) then
write(6,*) 'Variable #',identifyvar(n)
write(6,*) 'Name:',cvarfullname(n)(1:lencvarfull(n))
write(6,*) 'Short name:',cvarname(n)(1:lencvar(n))
if ( lencunit(n) .gt. 0 ) then
write(6,*) 'Units:',cunitname(n)(1:lencunit(n))
endif
write(6,*) ' '
endif
50 continue
return
end
SUBROUTINE WRITEWODTOSCREEN(ncastnow,iquod,nlevels,ccruise,rlat,
* rlatunc,rlon,rlonunc,iyear,month,iday,time,iuniq,nvar_loc,
* origc,origs,nsp_origc,nsp_origs,npi_loc,depth,iderror,
* iorigflag,temp,msig,xunc,ierror,isecorder_loc,
* isectype_loc,cvarname,lencvar,cvalsec_loc,nspsec_loc,
* ivalsec_loc,xvalsec_loc,maxsec_loc,maxvar,
* ivar_loc,maxlevel,maxcalc,nsec_loc,cpi_loc,cpivar_loc,
* nsp_cpi,nsp_cpivar,maxpi)
character*(*) ccruise
character*(*) origc
character*(*) origs
character*(*) cvarname(maxvar)
character*(*) cvalsec_loc(maxsec_loc)
character*(*) cpi_loc(maxpi)
character*(*) cpivar_loc(maxpi)
character*14 cform803
character*16 cform903
character*16 cform1003
character*26 cform8031
character*28 cform9031
character*28 cform10031
character*28 cformout
dimension isecorder_loc(maxsec_loc),isectype_loc(maxsec_loc)
dimension nspsec_loc(maxsec_loc)
dimension ivalsec_loc(maxsec_loc)
dimension xvalsec_loc(maxsec_loc)
dimension lencvar(maxvar)
dimension ierror(maxlevel)
dimension depth(maxlevel)
dimension msig(maxlevel,0:maxcalc)
dimension temp(maxlevel,maxcalc),iderror(maxlevel,0:maxcalc)
dimension xunc(maxlevel,0:maxcalc)
dimension iorigflag(maxlevel,0:maxcalc)
dimension ivar_loc(maxvar)
dimension nsp_cpi(maxpi),nsp_cpivar(maxpi)
include 'netcdf.inc'
cform803='(aXXX,": ",i8)'
cform903='(aXXX,": ",f8.3)'
cform1003='(aXXX,": ",aYYY)'
c**************************************************************
c
c WRITE HEADER INFORMATION TO THE SCREEN
c --------------------------------------
c
c cruise_ID - country code (2 bytes)+WOD cruise identifier (i8)
c rlat - latitude (f7.3)
c rlon - longitude (f8.3)
c iyear - year (i4)
c month - month (i2)
c iday - day (i2)
c time - time (GMT) (f7.2)
c ij - WOD cast identifier (i8)
c levels - number of depth levels measured (i6)
c
c**************************************************************
800 format(1x,a10,1x,f7.3,1x,f8.3,1x,i4,1x,i2,1x,i2,
& 1x,f7.2,1x,i8,1x,i6)
8000 format(1x,a10,1x,f7.3,1x,f6.3,1x,f8.3,1x,f6.3,1x,
& i4,1x,i2,1x,i2,1x,f7.2,1x,i8,1x,i6)
write(6,*)
&'----------------------------------------------------------'
write(6,*) 'Output from netCDF ragged array file, cast# ',
& ncastnow
write(6,*)
&'----------------------------------------------------------'
write(6,*)' '
if ( iquod .eq. 0 ) then
write(6,*)
& 'Cruise_ID Latitde Longitde YYYY MM DD Time'//
& ' Cast #levels'
write(6,800) ccruise,rlat,rlon,iyear,month,iday,
& time,iuniq,nlevels
else
write(6,*)
&'Cruise_ID Latitde latunc Longitd longunc YYYY MM DD'//
&' Time Cast #levels'
write(6,8000) ccruise,rlat,rlatunc,rlon,rlonunc,
& iyear,month,iday,time,iuniq,nlevels
endif
write(6,*) ' '
write(6,*) 'Number of variables in this cast: ',nvar_loc
write(6,*) ' '
c**************************************************************
c
c WRITE CHARACTER DATA TO THE SCREEN
c ----------------------------------
c
c chars(1) - Originators cruise identifier
c chars(2) - Originators station identifier
c
c**************************************************************
if ( nsp_origc .gt. 0 ) then
write(6,'(a)') 'Originators Cruise Code: ',origc(1:nsp_origc)
endif
if ( nsp_origs .gt. 0 ) then
write(6,'(a)') 'Originators Station Code: ',origs(1:nsp_origs)
endif
write(6,*) ' '
c***************************************************************
c
c WRITE PRIMARY INVESTIGATOR INFORMATION TO THE SCREEN
c ----------------------------------------------------
c
c npi = number of primary investigator entries
c ipi(1..npi,1) - PI code
c ipi(1..npi,2) - variable for which PI was responsible
c
c***************************************************************
do 505 n=1,npi_loc
write(6,'(a)') 'Primary Investigator: ',
* cpi_loc(n)(1:nsp_cpi(n))
write(6,'(a)') ' for variable: ',
* cpivar_loc(n)(1:nsp_cpivar(n))
505 continue
if ( npi_loc .gt. 0 ) write(6,*) ' '
c**************************************************************
c
c WRITE VARIABLE-CODE (column headings) TO THE SCREEN
c ----------------------------------------------------
c
c nvar - number of variables (1...nvar)
c code will be defined after profile
c
c Note: If "nvar = 0", biology only cast.
c
c**************************************************************
c format(5x,1a,5x,10(3x,i2,11x))
801 format(5x,"z fo",4x,10(i2,8x,"fo",3x))
851 format(5x,"z U",5x,"fo",4x,10(i2,7x,"U",10x,"fo",3x))
if (nvar .gt. 0) then
if ( iquod .eq. 0 ) then
write(6,801) (ivar_loc(n),n=1,nvar_loc)
else
write(6,851) (ivar_loc(n),n=1,nvar_loc)
endif
write(6,*)' '
c**************************************************************
c
c WRITE DEPTH-DEPENDENT VARIABLE DATA TO THE SCREEN
c --------------------------------------------------
c
c Print depth (depth(n)), error flags for depth (iderror(n,0)),
c each variable (temp(n,1..nvar_loc)), and error flags for each
c variables (iderror(n,1..nvar_loc))
c
c**************************************************************
802 format(f7.1,1x,i1,i1,14(f9.3,' (',i1,') ',i1,i1))
852 format(f7.1,1x,'[',f6.3,']',1x,i1,i1,14(f9.3,
* ' [',f6.3,'] ',' (',i1,') ',i1,i1))
do 80 n=1,nlevels
if ( iquod .eq. 0 ) then
write(6,802) depth(n),iderror(n,0),iorigflag(n,0),
& (temp(n,ivar_loc(j)),msig(n,ivar_loc(j)),
& iderror(n,ivar_loc(j)),iorigflag(n,ivar_loc(j)),
& j=1,nvar_loc)
else
write(6,852) depth(n),xunc(n,0),iderror(n,0),
& iorigflag(n,0),
& (temp(n,ivar_loc(j)),xunc(n,ivar_loc(j)),
& msig(n,ivar_loc(j)),iderror(n,ivar_loc(j)),
& iorigflag(n,ivar_loc(j)),j=1,nvar_loc)
endif
80 continue
write(6,*) ' '
c***************************************************************
c
c PRINT ENTIRE-PROFILE ERROR FLAGS
c ------------------------------------
c
c***************************************************************
8021 format('VarFlag: ',11x,11(i1,14x))
write(6,8021)(ierror(ivar_loc(j)),j=1,nvar_loc)
write(6,*) ' '
endif !- "if (nvar_loc .gt. 0) then"
c***************************************************************
c
c PRINT SECONDARY HEADERS
c -----------------------
c
c***************************************************************
do 85 n=1,nsec_loc
call clearstring(cformout,28)
nx=isecorder_loc(n)
if (isectype_loc(n) .eq. NF_CHAR ) then
cformout=cform1003
call insertnum('X',lencvar(nx),cformout,28)
call insertnum('Y',nspsec_loc(n),cformout,28)
write(6,cformout) cvarname(nx)(1:lencvar(nx)),
* cvalsec_loc(n)(1:nspsec_loc(n))
elseif ( isectype_loc(n) .eq. NF_INT .or.
* isectype_loc(n) .eq. NF_SHORT .or.
* isectype_loc(n) .eq. NF_BYTE ) then
cformout=cform803
call insertnum('X',lencvar(nx),cformout,28)
write(6,cformout) cvarname(nx)(1:lencvar(nx)),
* ivalsec_loc(n)
else
cformout=cform903
call insertnum('X',lencvar(nx),cformout,28)
write(6,cformout) cvarname(nx)(1:lencvar(nx)),
* xvalsec_loc(n)
endif
85 continue
return
end