PROGRAM wodSURF
c This program reads in the WOD01 and WOD05 SURF (surface) file format
c and writes it to a file in comma-separated-values (CSV) format.
c Because many commercial spreadsheets have about 65,000 row limit,
c and the entire SUR file will generate 1,800,000 rows, this
c program splits the files into up to 30 separate files, each
c with < 65,000 rows, with the names "output01.csv, output02.csv, ..."
c Program last modified on: Tue Mar 21 15:27:40 EST 2006
c
c VERSION-SPECIFIC COMMENTS:
c-------------------------------------------------------------------------------------
c * This version currently only writes out Temperature, Salinity,
c and chlorophyll.
c * Only "WOD Unique Cast, Cruise ID and "ship" are printed out.
c The original WOD file format contains much more metadata,
c on the methods and institution and PI and such. This format
c can be expanded to include these if desired.
parameter (rVERSION = 1.4)
c------------------------------------------------------------------------------------------------
c VERSION: 1.4 - Added "variable extraction control" for T, S, Chl, and combinations
c
c VERSION: 1.3 - Missing Value set to "-999." vs "-999.99" which prints as -999.9989999
c . - If julian date missing, will not print out that observation
c . - Added year-search capability.
c
c VERSION: 1.2 - Cleaned up and first "WOD01 web released" version
c VERSION: 1.1 - Clearing T,S,CHL arrays via "bmiss" after each load.
c VERSION: 1.0 - Original to Murray Brown
c------------------------------------------------------------------------------------------------
c-------------------------------------------------------------------------------------
c ATTENTION: This is a heavily modified version of the
c --------- "wodASC.for" program included with WOD05.
c Some of the comments below may apply to code
c which was removed during this modification.
c It is intended that WODread provide an example of how
c to extract the data and variables from the ASCII format,
c whereas wodSUR provides an example of how these data can
c be made accessible/workable as a series of arrays.
c***********************************************************
c
c Parameters (constants):
c
c maxlevel - maximum number of depth levels, also maximum
c number of all types of variables
c maxcalc - maximum number of measured and calculated
c depth dependent variables
c kdim - number of standard depth levels
c bmiss - binary missing value marker
c maxtcode - maximum number of different taxa variable codes
c maxtax - maximum number of taxon sets
c
c******************************************************************
parameter (maxlevel=30000, maxcalc=100)
parameter (kdim=40, bmiss=-999.99)
parameter (maxtcode=25, maxtax=2000)
c******************************************************************
c
c Character Arrays:
c
c cc - NODC country code
c chars - WOD character data: 1. originators cruise code,
c 2. originators station code
c filename - file name
c
c*****************************************************************
character*2 cc, cchoice
character*15 chars(2)
character*80 filename,csvfile
c******************************************************************
c
c Arrays:
c
c isig() - number of significant figures in (1) latitude, (2) longitude
c and (3) time
c iprec() - precision of (1) latitude, (2) longitude, (3) time
c
c ip2() - variable codes for variables in cast
c ierror() - whole profile error codes for each variable
c
c jsig2() - number of significant figures in each second header variable
c jprec2() - precision of each second header variable
c jtot2() - number of figures in each second header variable
c sechead() - second header variables
c
c jsigb() - number of significant figures in each biological variables
c jprecb() - precision of each biological variables
c jtotb() - number of figures in each biological variables
c bio() - biological data
c
c depth() - depth of each measurement
c msig() - number of significant figures in each measured variable at
c each level of measurement
c mprec() - precision of each measured variable at each
c level of measurement
c mtot() - number of figures in each measured variable at
c each level of measurement
c temp() - variable data at each level
c iderror() - error flags for each variable at each depth level
c isec() - variable codes for second header data
c ibio() - variable codes for biological data
c itaxnum() - different taxonomic and integrated variable
c codes found in data
c vtax() - value of taxonomic variables and integrated variables
c jsigtax() - number of significant figures in taxon values and
c integrated variables
c jprectax()- precision of taxon values and integrated variables
c jtottax() - number of figures in taxon values and integrated
c variables
c itaxerr() - error codes for taxon data
c nbothtot()- total number of taxa and integrated variables
c ipi() - primary investigators information
c 1. primary investigators
c 2. for which variable
c
c*******************************************************************
dimension isig(3),iprec(3),ip2(0:maxlevel),ierror(maxlevel)
dimension ipi(maxlevel,2)
dimension jsig2(maxlevel),jprec2(maxlevel),sechead(maxlevel)
dimension jsigb(maxlevel),jprecb(maxlevel),bio(maxlevel)
dimension depth(maxlevel)
dimension jtot2(maxlevel),jtotb(maxlevel)
dimension msig(maxlevel,maxcalc), mprec(maxlevel,maxcalc)
dimension mtot(maxlevel,maxcalc)
dimension temp(maxlevel,maxcalc),iderror(maxlevel,0:maxcalc)
dimension isec(maxlevel),ibio(maxlevel)
dimension itaxnum(maxtcode,maxtax),vtax(0:maxtcode,maxtax)
dimension jsigtax(maxtcode,maxtax),jprectax(maxtcode,maxtax)
dimension jtottax(maxtcode,maxtax),itaxerr(maxtcode,maxtax)
dimension itaxorigerr(maxtcode,maxtax)
common /thedata/ depth,temp
common /flags/ ierror,iderror
common /significant/ msig
common /precision/ mprec
common /totfigs/ mtot
common /second/ jsig2,jprec2,jtot2,isec,sechead
common /biology/ jsigb,jprecb,jtotb,ibio,bio
common /taxon/ jsigtax,jprectax,jtottax,itaxerr,
* vtax,itaxnum,nbothtot,itaxorigerr
c**************************************************************
c
c nf is the input file indentification number
c
c**************************************************************
data nf/11/
c**************************************************************
c
c Get user input file name from which casts will be
c taken. Open this file.
c
c**************************************************************
write(6,*)'------------------------------------------- '
write(6,*)' '
write(6,*)' w o d S U R F '
write(6,*)' '
write(6,'(17x,"version",1x,f3.1)')rVERSION
write(6,*)' '
write(6,*)' ... WOD05 "SURF" file to CSV convertor ...'
write(6,*)' '
write(6,*)'------------------------------------------- '
write(6,*)' '
write(6,*)' '
write(6,*)'Input File Name (*no* quotes please)'
read(5,'(a80)') filename
iYRbeg = 1900
iYRend = 2010
iVARpick = 0
3131 write(6,*)' '
write(6,*)'-------------------------'
write(6,*)' EXTRACTION CONTROL: '
write(6,*)'-------------------------'
write(6,*)' '
write(6,'(" (1) Desired Years = [ ",i4," to ",i4," ]")')
* iYRbeg,iYRend
write(6,*)
* ' (Example: to select data only from 1995-2000)'
write(6,*)' '
if (iVARpick .eq. 0) then
write(6,'(" (2) Desired Variables = [ any/all ]")')
else
write(6,'(" (2) Desired Variables = [ Option = ",i1," ]")')
* iVARpick
endif
write(6,*)
* ' (Example: to extract only if chlorophyll present)'
write(6,*)' '
write(6,*)' '
write(6,*)
* 'Enter control to change (1-2, "0" to continue): '
read(5,'(a2)')cchoice
c SET YEAR CONTROL
if (cchoice(1:1) .eq. '1') then
write(6,*)' '
write(6,*)'Extraction Year Control: '
write(6,*)' '
write(6,*)
* ' Enter a new starting and ending year (yyyy yyyy): '
read(5,*)iYRbeg,iYRend
endif
c SET VARIABLE CONTROL
if (cchoice(1:1) .eq. '2') then
4141 write(6,*)' '
write(6,*)'Extraction Variable Control: '
write(6,*)' '
write(6,*)' Option 1: TEMPERATURE (T) must be present '
write(6,*)' Option 2: SALINITY (S) must be present '
write(6,*)' Option 3: Both (T) & (S) must be present'
write(6,*)' '
write(6,*)' Option 4: CHLOROPHYLL (Chl) must be present '
write(6,*)' Option 5: (T) & (Chl) must be present '
write(6,*)' Option 6: (T) & (S) & (Chl) must be present '
write(6,*)' '
write(6,*)'Pick an Option (0 = any/all)'
read(5,*)iVARpick
if (iVARpick .lt. 0) iVARpick = 0
if (iVARpick .gt. 6) goto 4141
endif
if (cchoice(1:1) .ne. '0') goto 3131
write(6,*)' '
write(6,*)' '
write(6,*)'STARTING THE SURF DATA EXTRACTION ... '
write(6,*)' '
write(6,*)' '
write(6,*)
* ' Initial Clean-Up: Removing any old "output##.csv" files.'
write(6,*)' '
call system("rm -f output??.csv") !- UNIX VERSION
c call system("del output??.csv") !- DOS VERSION
csvfile = 'output01.csv'
open(22,file=csvfile(1:12),status='unknown')
open(nf,file=filename,status='old')
c**************************************************************
c
c SUBROUTINE "WODread": READS IN A SINGLE PROFILE FROM THE ASCII
c FILE AND STORES THE DATA INTO ARRAYS
c -------------------------------------------------------------------
c
c Passed Variables:
c
c nf - file identification number for input file
c jj - WOD cast number
c cc - NODC country code
c icruise - NODC cruise number
c iyear - year of cast
c month - month of cast
c iday - day of cast
c time - time of cast
c rlat - latitude of cast
c rlon - longitude of cast
c levels - number of depth levels of data
c istdlev - observed (0) or standard (1) levels
c nparm - number of variables recorded in cast
c ip2(i) - variable codes of variables in cast
c nsecond - number of second header variables
c nbio - number of biological variables
c isig() - number of significant figures in (1) latitude, (2) longitude
c and (3) time
c iprec() - precision of (1) latitude, (2) longitude, (3) time
c ieof - set to one if end of file has been encountered
c bmiss - missing value marker
c
c Common/Shared Variables and Arrays (see COMMON area of program):
c
c depth(x) - depth in meters (x = depth level)
c temp(x,y) - variable data (x = depth level, y = variable ID = ip2(i))
c ... see also nparm, ip2, istdlev, levels above ...
c sechead(i) - second header data (i = second header ID = isec(j))
c isec(j) - second header ID (j = #sequence (1st, 2nd, 3rd))
c ... see also nsecond above ...
c bio(i) - biology header data (i = biol-header ID = ibio(j))
c ibio(j) - biology header ID (j = #sequence (1st, 2nd, 3rd))
c ... see also nbio above ...
c nbothtot - number of taxa set / integrated variable
c vtax(i,j) - taxonomic/integrated array, where j = (1..nbothtot)
c For each entry (j=1..nbothtot), there are vtax(0,j)
c sub-entries. [Note: The number of sub-entries is
c variable for each main entry.] vtax also holds the
c value of the sub-entries.
c itaxnum(i,j)- taxonomic code or sub-code
c
c***************************************************************
iVERSflag = 0
write(6,*)' '
write(6,*)' ... Processing ...'
write(6,*)' '
iCSVfctr = 1 !- current CSV file (01, 02, 03, ...)
iCSVlines = 1 !- count of rows in current CSV file
write(6,*)' '
write(6,*)'current output file = "output01.csv" '
write(6,*)' '
write(22,3030) !- write header to "output.txt" file
c CLEAR arrays before first cast loads
do iCLR = 1,maxlevel
temp(iCLR,1) = -999. !- Temperature
temp(iCLR,2) = -999. !- Salinity
temp(iCLR,11)= -999. !- Chlorophyll
enddo
ije = 0
ijelast = -1
3012 format(i7,": Rows Extracted [",
* i7,"] CSV-file-row-ctr = [",i6,"]")
do 50 ij=1,10000000 !- MAIN LOOP
c STATUS TRACKING
if (mod(ij,1000) .eq. 0) write(6,3012)ij,ije,iCSVlines
chars(1)= ' '
chars(2)= ' '
if(iVERSflag .eq. 0 .or. iVERSflag .eq. 2)then
ieof=0
call WODread200X(nf,jj,cc,icruise,iyear,month,iday,
* time,rlat,rlon,levels,istdlev,nparm,ip2,nsecond,nbio,
* isig,iprec,bmiss,ieof,chars,ipi,npi,iVERSflag)
c ONLY happens if format rejected (rewind and try as WOD98)
if(iVERSflag .eq. 1)then
print*,
* 'This data file in not in WOD-2005 format.',
* ' Trying WOD-1998 format. '
print*, ' '
rewind(nf)
endif
endif
if(IVERSflag .eq. 1)then
c
c Read in as WOD-1998 format
ieof=0
call WODread1998(nf,jj,cc,icruise,iyear,month,iday,
* time,rlat,rlon,levels,istdlev,nparm,ip2,nsecond,nbio,
* isig,iprec,bmiss,ieof,chars,ipi,npi)
endif
if ( ieof.gt.0 ) then
print *,'... EOF reached ...'
goto 4 !- Exit
endif
c Perform YEAR CONTROL
if (iyear .lt. iYRbeg) goto 50 !- skip
if (iyear .gt. iYRend) goto 50 !- skip
c Extract the ship code Secondary Header # 4
c . isec(#) = Secondary Header code
c . sechead(#) = value for the header
c
iSHIPcode = 0
do iSHIPlp = 1,5
if (isec(iSHIPlp) .eq. 4) iSHIPcode = sechead(iSHIPlp)
enddo
c write data to file in column format
c HAMSTER
if ( iCSVlines .gt. 50000 ) then
close(22)
iCSVfctr = iCSVfctr + 1
csvfile = 'output00.csv'
c Translate the 10's digit to a character
if (iCSVfctr .gt. 9) then
iFval = iCSVFctr / 10
csvfile(7:7) = char(48+iFval)
endif
c Translate the 1's digit to a character
iFval = mod(iCSVFctr,10)
csvfile(8:8) = char(48+iFval) !- 'output#0.csv'
write(6,*)' '
write(6,*)'current output file = "',csvfile(1:12),'"'
write(6,*)' '
open(22,file=csvfile(1:12),status='unknown')
write(22,3030) !- write header to "output.txt" file
iCSVlines = 1
endif
3030 format(
* "UniqStat,",
* " cc,",
* "WOD_cruise,",
* " ship,",
* " year,",
* " mm,",
* " dd,",
* " time,",
* " Latitude,D,F,",
* " Longitude,D,F,",
* " Temperature,D,F,",
* " Salinity,D,F,",
* " Chlorophyll,D,F,",
* ","
* )
3535 format(
* i8,",", !- uniqstat
* 1x,a2,",", !- cc
* i10,",", !- cruise
* i5,",", !- ship
* i5,",", !- year
* i3,",", !- month
* i3,",", !- day
* f6.2,",",
* 5(f12.6,",",i1,",",i1,","),
* a1)
iyear0 = iyear
do ilp = 1,levels
iOKAY = 0
if (iVARpick .eq. 0) iOKAY = 1 !- no variable selection
if (temp(ilp,1) .gt. -50 .and. iVARpick .eq. 1) iOKAY = 1 !- Temperature Present
if (temp(ilp,2) .gt. -50 .and. iVARpick .eq. 2) iOKAY = 1 !- Salinity Present
if (temp(ilp,2) .gt. -50 .and. temp(ilp,1) .gt. -50
* .and. iVARpick .eq. 3) iOKAY = 1 !- Temp & Salinity Present
if (temp(ilp,11) .gt. -50 .and. iVARpick .eq. 4) iOKAY = 1 !- Chlorophyll Present
if (temp(ilp,1) .gt. -50 .and. temp(ilp,11) .gt. -50
* .and. iVARpick .eq. 5) iOKAY = 1 !- Temp & Chl present
if (temp(ilp,1) .gt. -50 .and. temp(ilp,2) .gt. -50
* .and. temp(ilp,11) .gt. -50
* .and. iVARpick .eq. 6) iOKAY = 1 !- Temp & Salinity & Chl present
if (temp(ilp,32) .lt. 1.) iOKAY = 0 !- no JULIAN day
if (iOKAY .gt. 0.) then !- OKAY TO PRINT OUT
ije = ije + 1 !- records extracted counter
iCSVlines = iCSVlines + 1
c Convert Julian to Year/Month/Day/Time
call NAILUJ(iyear0,iyear,month,iday,time,
* temp(ilp,32),jsig)
write(22,3535) !- write (using format 3535) to file #22 ("output.txt")
* jj, !- WOD unique cast identifier
* cc, !- country code
* icruise, !- WOD cruise identifier
* iSHIPcode, !- ship code
* iyear, month, iday, !- DATE
* time, !- TIME
* temp(ilp,30),mprec(ilp,30),iderror(ilp,30), !- latitude
* temp(ilp,31),mprec(ilp,31),iderror(ilp,31), !- longitude
* temp(ilp,1),mprec(ilp,1),iderror(ilp,1), !- Temperature
* temp(ilp,2),mprec(ilp,2),iderror(ilp,2), !- Salinity
* temp(ilp,11),mprec(ilp,11),iderror(ilp,11), !- Chlorophyll
* ","
c CLEAR VALUES NOW (so won't bleed into next cast)
temp(ilp,1) = -999. !- temperature
temp(ilp,2) = -999. !- salinity
temp(ilp,11)= -999. !- chlorophyll
endif !- Julian date present?
enddo !- ilp
50 continue !- End of MAIN LOOP
4 continue !- EXIT
stop
end
C---------------------------------------------------------------
SUBROUTINE WODREAD200X(nf,jj,cc,icruise,iyear,month,iday,
* time,rlat,rlon,levels,isoor,nvar,ip2,nsecond,nbio,
* isig,iprec,bmiss,ieof,chars,ipi,npi,iVERSflag)
c This subroutine reads in the WOD ASCII format and loads it
c into arrays which are common/shared with the calling program.
c*****************************************************************
c
c Passed Variables:
c
c nf - file identification number for input file
c jj - WOD cast number
c cc - NODC country code
c icruise - NODC cruise number
c iyear - year of cast
c month - month of cast
c iday - day of cast
c time - time of cast
c rlat - latitude of cast
c rlon - longitude of cast
c levels - number of depth levels of data
c isoor - observed (0) or standard (1) levels
c nvar - number of variables recorded in cast
c ip2 - variable codes of variables in cast
c nsecond - number of secondary header variables
c nbio - number of biological variables
c isig - number of significant figures in (1) latitude, (2) longitude,
c and (3) time
c iprec - precision of (1) latitude, (2) longitude, (3) time
c itotfig - number of digits in (1) latitude, (2) longitude, (3) time
c bmiss - missing value marker
c ieof - set to one if end of file has been encountered
c chars - character data: 1=originators cruise code,
c 2=originators station code
c npi - number of PI codes
c ipi - Primary Investigator information
c 1. primary investigator
c 2. variable investigated
c
c iVERSflag - set to "1" if data are in WOD-1998 format.
c (subroutine exits so 1998 subroutine can be run)
c
c Common/Shared Variables and Arrays (see COMMON area of program):
c
c depth(x) - depth in meters (x = depth level)
c temp(x,y) - variable data (x = depth level, y = variable ID = ip2(i))
c ... see also nvar, ip2, istdlev, levels above ...
c sechead(i) - secondary header data (i = secondary header ID = isec(j))
c isec(j) - secondary header ID (j = #sequence (1st, 2nd, 3rd))
c ... see also nsecond above ...
c bio(i) - biology header data (i = biol-header ID = ibio(j))
c ibio(j) - biology header ID (j = #sequence (1st, 2nd, 3rd))
c ... see also nbio above ...
c nbothtot - number of taxa set / biomass variables
c vtax(i,j) - taxonomic/biomass array, where j = (1..nbothtot)
c For each entry (j=1..nbothtot), there are vtax(0,j)
c sub-entries. [Note: The number of sub-entries is
c variable for each main entry.] vtax also holds the
c value of the sub-entries.
c itaxnum(i,j)- taxonomic code or sub-code
c parminf(i,j)- variable specific information
c origflag(i,j)- originators data flags
c
c***************************************************************
c******************************************************************
c
c Parameters (constants):
c
c maxlevel - maximum number of depth levels, also maximum
c number of all types of variables
c maxcalc - maximum number of measured and calculated
c depth dependent variables
c maxtcode - maximum number of different taxa variable codes
c maxtax - maximum number of taxa sets
c maxpinf - number of distinct variable specific information
c variables
c
c******************************************************************
parameter (maxlevel=30000, maxcalc=100)
parameter (maxtcode=25, maxtax=2000, maxpinf=25)
c******************************************************************
c
c Character Variables:
c
c cc - NODC country code
c xchar - dummy character array for reading in each 80
c character record
c aout - format specifier (used for FORTRAN I/O)
c ichar - cast character array
c
c******************************************************************
character*2 cc
character*4 aout
character*15 chars(2)
character*80 xchar
character*1500000 ichar
data aout /'(iX)'/
c******************************************************************
c
c Arrays:
c
c isig - number of significant figures in (1) latitude, (2) longitude,
c and (3) time
c iprec - precision of (1) latitude, (2) longitude, (3) time
c itotfig - number of digits in (1) latitude, (2) longitude, (3) time
c ip2 - variable codes for variables in cast
c ierror - whole profile error codes for each variable
c jsig2 - number of significant figures in each secondary header variable
c jprec2 - precision of each secondary header variable
c jtot2 - number of digits in each secondary header variable
c sechead - secondary header variables
c jsigb - number of significant figures in each biological variable
c jprecb - precision of each biological variable
c jtotb - number of digits in each biological variable
c bio - biological data
c idsig - number of significant figures in each depth measurement
c idprec - precision of each depth measurement
c idtot - number of digits in each depth measurement
c depth - depth of each measurement
c msig - number of significant figures in each measured variable at
c each level of measurement
c mprec - precision of each measured variable at each
c level of measurement
c mtot - number of digits in each measured variable at
c each level of measurement
c temp - variable data at each level
c iderror - error flags for each variable at each depth level
c iorigflag- originators flags for each variable and depth
c isec - variable codes for secondary header data
c ibio - variable codes for biological data
c parminf - variable specific information
c jprecp - precision for variable specific information
c jsigp - number of significant figures for variable specific
c information
c jtotp - number of digits in for variable specific information
c itaxnum - different taxonomic and biomass variable
c codes found in data
c vtax - value of taxonomic variables and biomass variables
c jsigtax - number of significant figures in taxon values and
c biomass variables
c jprectax - precision of taxon values and biomass variables
c jtottax - number of digits in taxon values and biomass
c variables
c itaxerr - taxon variable error code
c itaxorigerr - taxon originators variable error code
c nbothtot - total number of taxa and biomass variables
c ipi - Primary investigator informationc
c 1. primary investigator
c 2. variable investigated
c
c*******************************************************************
dimension isig(3), iprec(3), ip2(0:maxlevel), ierror(maxlevel)
dimension itotfig(3),ipi(maxlevel,2)
dimension jsig2(maxlevel), jprec2(maxlevel), sechead(maxlevel)
dimension jsigb(maxlevel), jprecb(maxlevel), bio(maxlevel)
dimension idsig(maxlevel),idprec(maxlevel), depth(maxlevel)
dimension jtot2(maxlevel),jtotb(maxlevel),idtot(maxlevel)
dimension msig(maxlevel,maxcalc), mprec(maxlevel,maxcalc)
dimension mtot(maxlevel,maxcalc)
dimension temp(maxlevel,maxcalc),iderror(maxlevel,0:maxcalc)
dimension isec(maxlevel),ibio(maxlevel)
dimension parminf(maxpinf,0:maxcalc),jsigp(maxpinf,0:maxcalc)
dimension jprecp(maxpinf,0:maxcalc),jtotp(maxpinf,0:maxcalc)
dimension iorigflag(maxlevel,0:maxcalc)
dimension itaxnum(maxtcode,maxtax),vtax(0:maxtcode,maxtax)
dimension jsigtax(maxtcode,maxtax),jprectax(maxtcode,maxtax)
dimension jtottax(maxtcode,maxtax),itaxerr(maxtcode,maxtax)
dimension itaxorigerr(maxtcode,maxtax)
c*******************************************************************
c
c Common Arrays and Variables:
c
c*******************************************************************
common /thedata/ depth,temp
common /flags/ ierror,iderror
common /oflags/ iorigflag
common /significant/ msig
common /precision/ mprec
common /totfigs/ mtot
common /second/ jsig2,jprec2,jtot2,isec,sechead
common /parminfo/ jsigp,jprecp,jtotp,parminf
common /biology/ jsigb,jprecb,jtotb,ibio,bio
common /taxon/ jsigtax,jprectax,jtottax,itaxerr,
* vtax,itaxnum,nbothtot,itaxorigerr
c******************************************************************
c
c Read in the first line of a cast into dummy character
c variable xchar
c
c
c WOD-2005 First byte of each "cast record" is char "A".
c
c WOD-1998 First byte of each "cast recond" is a number.
c
c******************************************************************
read(nf,'(a80)',end=500) xchar
if ( xchar(1:1) .ne. 'B' .and. xchar(1:1) .ne. 'A'
* .and. xchar(1:1) .ne. 'C' ) then
iVERSflag = 1 !- not WOD-2005 format, must be WOD-1998
return
else
if ( xchar(1:1) .eq. 'C' ) then
iVERSflag = 2 !- WOD-2013 format
else
iVERSflag = 0 !- WOD-2005 format
endif
endif
c******************************************************************
c
c The first seven characters of a cast contain the
c number of characters which make up the entire cast. Read
c this number into nchar
c
c******************************************************************
read(xchar(2:2),'(i1)') inc
write(aout(3:3),'(i1)') inc
read(xchar(3:inc+2),aout) nchar
c******************************************************************
c
c Place the first line of the cast into the cast holder
c character array (ichar)
c
c******************************************************************
ichar(1:80) = xchar
c******************************************************************
c
c Calculate the number of full (all 80 characters contain information)
c lines in this cast. Subtract one since the first line was
c already read in.
c
c******************************************************************
nlines = nchar/80
c*****************************************************************
c
c Read each line into the dummy variable
c
c*****************************************************************
do 49 n0 = 2,nlines
read(nf,'(a80)') xchar
c*****************************************************************
c
c Place the line into the whole cast array
c
c*****************************************************************
n = 80*(n0-1)+1
ichar(n:n+79)=xchar
49 continue
c*****************************************************************
c
c If there is a last line with partial information, read in
c this last line and place it into the whole cast array
c
c*****************************************************************
if ( nlines*80 .lt. nchar .and. nlines .gt. 0) then
read(nf,'(a80)') xchar
n = 80*nlines+1
ichar(n:nchar) = xchar
endif
c*****************************************************************
c
c Extract header information from the cast array
c
c jj - WOD cast number
c cc - NODC country code
c icruise - NODC cruise number
c iyear - year of cast
c month - month of cast
c iday - day of cast
c
c*****************************************************************
istartc=inc+3
read(ichar(istartc:istartc),'(i1)') inc
write(aout(3:3),'(i1)') inc
read(ichar(istartc+1:istartc+inc),aout) jj
istartc=istartc+inc+1
cc = ichar(istartc:istartc+1)
istartc=istartc+2
read(ichar(istartc:istartc),'(i1)') inc
write(aout(3:3),'(i1)') inc
read(ichar(istartc+1:istartc+inc),aout) icruise
istartc=istartc+inc+1
read(ichar(istartc:istartc+3),'(i4)') iyear
istartc=istartc+4
read(ichar(istartc:istartc+1),'(i2)') month
istartc=istartc+2
read(ichar(istartc:istartc+1),'(i2)') iday
istartc=istartc+2
c*****************************************************************
c
c SUBROUTINE "charout": READS IN AN WOD ASCII FLOATING-POINT
c VALUE SEQUENCE (i.e. # sig-figs,
c # total figs, precision, value itself).
c * THIS WILL BE CALLED TO EXTRACT MOST
c Examples: FLOATING POINT VALUES IN THE WOD ASCII.
c
c VALUE Precision WOD ASCII
c ----- --------- ---------
c 5.35 2 332535
c 5. 0 1105
c 15.357 3 55315357
c (missing) -
c
c ---------------------------------------------------------------
c
c Read in time of cast (time) using CHAROUT subroutine:
c
c istartc - position in character array to begin to read
c in data
c isig - number of digits in data value
c iprec - precision of data value
c ichar - character array from which to read data
c time - data value
c bmiss - missing value marker
c
c*****************************************************************
call charout(istartc,isig(3),iprec(3),itotfig(3),ichar,time,bmiss)
c*****************************************************************
c
c Read in latitude (rlat) and longitude (rlon) using CHAROUT:
c
c Negative latitude is south.
c Negative longitude is west.
c
c*****************************************************************
call charout(istartc,isig(1),iprec(1),itotfig(1),ichar,rlat,bmiss)
call charout(istartc,isig(2),iprec(2),itotfig(2),ichar,rlon,bmiss)
c*****************************************************************
c
c Read in the number of depth levels (levels) using CHAROUT:
c
c*****************************************************************
read(ichar(istartc:istartc),'(i1)') inc
write(aout(3:3),'(i1)') inc
read(ichar(istartc+1:istartc+inc),aout) levels
istartc=istartc+inc+1
c*****************************************************************
c
c Read in whether data is on observed levels (isoor=0) or
c standard levels (isoor=1)
c
c*****************************************************************
read(ichar(istartc:istartc),'(i1)') isoor
istartc=istartc+1
c*****************************************************************
c
c Read in number of variables in cast
c
c*****************************************************************
read(ichar(istartc:istartc+1),'(i2)') nvar
istartc=istartc+2
c*****************************************************************
c
c Read in the variable codes (ip2()), the whole cast
c error flags (ierror(ip2())), and variable specific
c information (iorigflag(,ip2()))
c
c*****************************************************************
do 30 n = 1,nvar
read(ichar(istartc:istartc),'(i1)') inc
write(aout(3:3),'(i1)') inc
read(ichar(istartc+1:istartc+inc),aout) ip2(n)
istartc=istartc+inc+1
read(ichar(istartc:istartc),'(i1)') ierror(ip2(n))
istartc=istartc+1
read(ichar(istartc:istartc),'(i1)') inc
write(aout(3:3),'(i1)') inc
read(ichar(istartc+1:istartc+inc),aout) npinf
istartc=istartc+inc+1
do 305 n2=1,npinf
read(ichar(istartc:istartc),'(i1)') inc
write(aout(3:3),'(i1)') inc
read(ichar(istartc+1:istartc+inc),aout) nn
istartc=istartc+inc+1
call charout(istartc,jsigp(nn,ip2(n)),jprecp(nn,ip2(n)),
* jtotp(nn,ip2(n)),ichar, parminf(nn,ip2(n)),bmiss)
305 continue
30 continue
c****************************************************************
c
c Read in number of bytes in character data
c
c****************************************************************
read(ichar(istartc:istartc),'(i1)') inc
istartc=istartc+1
if ( inc .gt. 0 ) then
write(aout(3:3),'(i1)') inc
read(ichar(istartc+1:istartc+inc),aout) inchad
istartc=istartc+inc
c****************************************************************
c
c Read in number of character and primary investigator arrays
c
c****************************************************************
npi=0
chars(1)(1:4)='NONE'
chars(2)(1:4)='NONE'
read(ichar(istartc:istartc),'(i1)') ica
istartc=istartc+1
c****************************************************************
c
c Read in character and primary investigator data
c 1 - originators cruise code
c 2 - originators station code
c 3 - primary investigators information
c
c****************************************************************
do 45 nn=1,ica
read(ichar(istartc:istartc),'(i1)') icn
istartc=istartc+1
if ( icn .lt. 3 ) then
read(ichar(istartc:istartc+1),'(i2)') ns
istartc=istartc+2
chars(icn)= ' '
chars(icn)= ichar(istartc:istartc+ns-1)
istartc= istartc+ns
else
read(ichar(istartc:istartc+1),'(i2)') npi
istartc=istartc+2
do 505 n=1,npi
read(ichar(istartc:istartc),'(i1)') inc
write(aout(3:3),'(i1)') inc
read(ichar(istartc+1:istartc+inc),aout) ipi(n,2)
istartc=istartc+inc+1
read(ichar(istartc:istartc),'(i1)') inc
write(aout(3:3),'(i1)') inc
read(ichar(istartc+1:istartc+inc),aout) ipi(n,1)
istartc=istartc+inc+1
505 continue
endif
45 continue
endif
c****************************************************************
c
c Read in number of bytes in secondary header variables
c
c****************************************************************
read(ichar(istartc:istartc),'(i1)') inc
istartc=istartc+1
if ( inc .gt. 0 ) then
write(aout(3:3),'(i1)') inc
read(ichar(istartc+1:istartc+inc),aout) insec
istartc=istartc+inc
c****************************************************************
c
c Read in number of secondary header variables (nsecond)
c
c****************************************************************
read(ichar(istartc:istartc),'(i1)') inc
write(aout(3:3),'(i1)') inc
read(ichar(istartc+1:istartc+inc),aout) nsecond
istartc=istartc+inc+1
c****************************************************************
c
c Read in secondary header variables (sechead())
c
c****************************************************************
do 35 n = 1,nsecond
read(ichar(istartc:istartc),'(i1)') inc
write(aout(3:3),'(i1)') inc
read(ichar(istartc+1:istartc+inc),aout) nn
istartc=istartc+inc+1
call charout(istartc,jsig2(nn),jprec2(nn),jtot2(nn),ichar,
* sechead(nn),bmiss)
isec(n) = nn
35 continue
endif
c****************************************************************
c
c Read in number of bytes in biology variables
c
c****************************************************************
read(ichar(istartc:istartc),'(i1)') inc
istartc=istartc+1
if ( inc .gt. 0 ) then
write(aout(3:3),'(i1)') inc
read(ichar(istartc+1:istartc+inc),aout) inbio
istartc=istartc+inc
c****************************************************************
c
c Read in number of biological variables (nbio)
c
c****************************************************************
read(ichar(istartc:istartc),'(i1)') inc
write(aout(3:3),'(i1)') inc
read(ichar(istartc+1:istartc+inc),aout) nbio
istartc=istartc+inc+1
c****************************************************************
c
c Read in biological variables (bio())
c
c****************************************************************
do 40 n = 1,nbio
read(ichar(istartc:istartc),'(i1)') inc
write(aout(3:3),'(i1)') inc
read(ichar(istartc+1:istartc+inc),aout) nn
istartc=istartc+inc+1
call charout(istartc,jsigb(nn),jprecb(nn),jtotb(nn),ichar,
* bio(nn),bmiss)
ibio(n) = nn
40 continue
c****************************************************************
c
c Read in biomass and taxonomic variables
c
c****************************************************************
read(ichar(istartc:istartc),'(i1)') inc
write(aout(3:3),'(i1)') inc
read(ichar(istartc+1:istartc+inc),aout) nbothtot
istartc=istartc+inc+1
do 41 n = 1,nbothtot
itaxtot=0
read(ichar(istartc:istartc),'(i1)') inc
write(aout(3:3),'(i1)') inc
read(ichar(istartc+1:istartc+inc),aout) nn
istartc=istartc+inc+1
vtax(0,n)=nn
do 42 n2 =1,nn
itaxtot=itaxtot+1
read(ichar(istartc:istartc),'(i1)') inc
write(aout(3:3),'(i1)') inc
read(ichar(istartc+1:istartc+inc),aout) itaxnum(itaxtot,n)
istartc=istartc+inc+1
call charout(istartc,jsigtax(itaxtot,n),jprectax(itaxtot,n),
* jtottax(itaxtot,n),ichar,vtax(itaxtot,n),bmiss)
read(ichar(istartc:istartc),'(i1)') itaxerr(itaxtot,n)
istartc=istartc+1
read(ichar(istartc:istartc),'(i1)') itaxorigerr(itaxtot,n)
istartc=istartc+1
42 continue
41 continue
endif
c****************************************************************
c
c Read in measured and calculated depth dependent variables
c along with their individual reading flags
c
c****************************************************************
do 50 n = 1,levels
if ( isoor.eq.0 .or. iVERSflag .eq. 2 ) then
call charout(istartc,idsig(n),idprec(n),idtot(n),ichar,
* depth(n),bmiss)
read(ichar(istartc:istartc),'(i1)') iderror(n,0)
istartc=istartc+1
read(ichar(istartc:istartc),'(i1)') iorigflag(n,0)
istartc=istartc+1
endif
do 55 i = 1,nvar
call charout(istartc,msig(n,ip2(i)),mprec(n,ip2(i)),
* mtot(n,ip2(i)),ichar,temp(n,ip2(i)),bmiss)
if ( temp(n,ip2(i)) .gt. bmiss ) then
read(ichar(istartc:istartc),'(i1)') iderror(n,ip2(i))
istartc=istartc+1
read(ichar(istartc:istartc),'(i1)') iorigflag(n,ip2(i))
istartc=istartc+1
else
iderror(n,ip2(i))=0
iorigflag(n,ip2(i))=0
msig(n,ip2(i))=0
mprec(n,ip2(i))=0
mtot(n,ip2(i))=0
endif
55 continue
50 continue
return
500 ieof = 1
return
end
C---------------------------------------------------------------
SUBROUTINE WODREAD1998(nf,jj,cc,icruise,iyear,month,iday,
* time,rlat,rlon,levels,isoor,nvar,ip2,nsecond,nbio,
* isig,iprec,bmiss,ieof,chars,ipi,npi)
c This subroutine reads in the WOD ASCII format and loads it
c into arrays which are common/shared with the calling program.
c*****************************************************************
c
c Passed Variables:
c
c nf - file identification number for input file
c jj - WOD cast number
c cc - NODC country code
c icruise - NODC cruise number
c iyear - year of cast
c month - month of cast
c iday - day of cast
c time - time of cast
c rlat - latitude of cast
c rlon - longitude of cast
c levels - number of depth levels of data
c isoor - observed (0) or standard (1) levels
c nvar - number of variables recorded in cast
c ip2 - variable codes of variables in cast
c nsecond - number of secondary header variables
c nbio - number of biological variables
c isig - number of significant figures in (1) latitude, (2) longitude,
c and (3) time
c iprec - precision of (1) latitude, (2) longitude, (3) time
c itotfig - number of digits in (1) latitude, (2) longitude, (3) time
c bmiss - missing value marker
c ieof - set to one if end of file has been encountered
c chars - character data: 1=originators cruise code,
c 2=originators station code
c npi - number of PI codes
c ipi - Primary Investigator information
c 1. primary investigator
c 2. variable investigated
c
c Common/Shared Variables and Arrays (see COMMON area of program):
c
c depth(x) - depth in meters (x = depth level)
c temp(x,y) - variable data (x = depth level, y = variable ID = ip2(i))
c ... see also nvar, ip2, istdlev, levels above ...
c sechead(i) - secondary header data (i = secondary header ID = isec(j))
c isec(j) - secondary header ID (j = #sequence (1st, 2nd, 3rd))
c ... see also nsecond above ...
c bio(i) - biology header data (i = biol-header ID = ibio(j))
c ibio(j) - biology header ID (j = #sequence (1st, 2nd, 3rd))
c ... see also nbio above ...
c nbothtot - number of taxa set / biomass variables
c vtax(i,j) - taxonomic/biomass array, where j = (1..nbothtot)
c For each entry (j=1..nbothtot), there are vtax(0,j)
c sub-entries. [Note: The number of sub-entries is
c variable for each main entry.] vtax also holds the
c value of the sub-entries.
c itaxnum(i,j)- taxonomic code or sub-code
c
c***************************************************************
c******************************************************************
c
c Parameters (constants):
c
c maxlevel - maximum number of depth levels, also maximum
c number of all types of variables
c maxcalc - maximum number of measured and calculated
c depth dependent variables
c maxtcode - maximum number of different taxa variable codes
c maxtax - maximum number of taxa sets
c
c******************************************************************
parameter (maxlevel=30000, maxcalc=100)
parameter (maxtcode=25, maxtax=2000)
c******************************************************************
c
c Character Variables:
c
c cc - NODC country code
c xchar - dummy character array for reading in each 80
c character record
c aout - format specifier (used for FORTRAN I/O)
c ichar - cast character array
c
c******************************************************************
character*2 cc
character*4 aout
character*15 chars(2)
character*80 xchar
character*300000 ichar
data aout /'(iX)'/
c******************************************************************
c
c Arrays:
c
c isig - number of significant figures in (1) latitude, (2) longitude,
c and (3) time
c iprec - precision of (1) latitude, (2) longitude, (3) time
c itotfig - number of digits in (1) latitude, (2) longitude, (3) time
c ip2 - variable codes for variables in cast
c ierror - whole profile error codes for each variable
c jsig2 - number of significant figures in each secondary header variable
c jprec2 - precision of each secondary header variable
c jtot2 - number of digits in each secondary header variable
c sechead - secondary header variables
c jsigb - number of significant figures in each biological variable
c jprecb - precision of each biological variable
c jtotb - number of digits in each biological variable
c bio - biological data
c idsig - number of significant figures in each depth measurement
c idprec - precision of each depth measurement
c idtot - number of digits in each depth measurement
c depth - depth of each measurement
c msig - number of significant figures in each measured variable at
c each level of measurement
c mprec - precision of each measured variable at each
c level of measurement
c mtot - number of digits in each measured variable at
c each level of measurement
c temp - variable data at each level
c iderror - error flags for each variable at each depth level
c isec - variable codes for secondary header data
c ibio - variable codes for biological data
c itaxnum - different taxonomic and biomass variable
c codes found in data
c vtax - value of taxonomic variables and biomass variables
c jsigtax - number of significant figures in taxon values and
c biomass variables
c jprectax - precision of taxon values and biomass variables
c jtottax - number of digits in taxon values and biomass
c variables
c itaxerr - taxon variable error code
c nbothtot - total number of taxa and biomass variables
c ipi - Primary investigator informationc
c 1. primary investigator
c 2. variable investigated
c
c*******************************************************************
dimension isig(3), iprec(3), ip2(0:maxlevel), ierror(maxlevel)
dimension itotfig(3),ipi(maxlevel,2)
dimension jsig2(maxlevel), jprec2(maxlevel), sechead(maxlevel)
dimension jsigb(maxlevel), jprecb(maxlevel), bio(maxlevel)
dimension idsig(maxlevel),idprec(maxlevel), depth(maxlevel)
dimension jtot2(maxlevel),jtotb(maxlevel),idtot(maxlevel)
dimension msig(maxlevel,maxcalc), mprec(maxlevel,maxcalc)
dimension mtot(maxlevel,maxcalc)
dimension temp(maxlevel,maxcalc),iderror(maxlevel,0:maxcalc)
dimension isec(maxlevel),ibio(maxlevel)
dimension itaxnum(maxtcode,maxtax),vtax(0:maxtcode,maxtax)
dimension jsigtax(maxtcode,maxtax),jprectax(maxtcode,maxtax)
dimension jtottax(maxtcode,maxtax),itaxerr(maxtcode,maxtax)
dimension itaxorigerr(maxtcode,maxtax)
c*******************************************************************
c
c Common Arrays and Variables:
c
c*******************************************************************
common /thedata/ depth,temp
common /flags/ ierror,iderror
common /significant/ msig
common /precision/ mprec
common /totfigs/ mtot
common /second/ jsig2,jprec2,jtot2,isec,sechead
common /biology/ jsigb,jprecb,jtotb,ibio,bio
common /taxon/ jsigtax,jprectax,jtottax,itaxerr,
* vtax,itaxnum,nbothtot,itaxorigerr
c******************************************************************
c
c Read in the first line of a cast into dummy character
c variable xchar
c
c******************************************************************
read(nf,'(a80)',end=500) xchar
c******************************************************************
c
c The first seven characters of a cast contain the
c number of characters which make up the entire cast. Read
c this number into nchar
c
c******************************************************************
read(xchar(1:1),'(i1)') inc
write(aout(3:3),'(i1)') inc
read(xchar(2:inc+1),aout) nchar
c******************************************************************
c
c Place the first line of the cast into the cast holder
c character array (ichar)
c
c******************************************************************
ichar(1:80) = xchar
c******************************************************************
c
c Calculate the number of full (all 80 characters contain information)
c lines in this cast. Subtract one since the first line was
c already read in.
c
c******************************************************************
nlines = nchar/80
c*****************************************************************
c
c Read each line into the dummy variable
c
c*****************************************************************
do 49 n0 = 2,nlines
read(nf,'(a80)') xchar
c*****************************************************************
c
c Place the line into the whole cast array
c
c*****************************************************************
n = 80*(n0-1)+1
ichar(n:n+79)=xchar
49 continue
c*****************************************************************
c
c If there is a last line with partial information, read in
c this last line and place it into the whole cast array
c
c*****************************************************************
if ( nlines*80 .lt. nchar .and. nlines .gt. 0) then
read(nf,'(a80)') xchar
n = 80*nlines+1
ichar(n:nchar) = xchar
endif
c*****************************************************************
c
c Extract header information from the cast array
c
c jj - WOD cast number
c cc - NODC country code
c icruise - NODC cruise number
c iyear - year of cast
c month - month of cast
c iday - day of cast
c
c*****************************************************************
istartc=inc+2
read(ichar(istartc:istartc),'(i1)') inc
write(aout(3:3),'(i1)') inc
read(ichar(istartc+1:istartc+inc),aout) jj
istartc=istartc+inc+1
cc = ichar(istartc:istartc+1)
istartc=istartc+2
read(ichar(istartc:istartc),'(i1)') inc
write(aout(3:3),'(i1)') inc
read(ichar(istartc+1:istartc+inc),aout) icruise
istartc=istartc+inc+1
read(ichar(istartc:istartc+3),'(i4)') iyear
istartc=istartc+4
read(ichar(istartc:istartc+1),'(i2)') month
istartc=istartc+2
read(ichar(istartc:istartc+1),'(i2)') iday
istartc=istartc+2
c*****************************************************************
c
c SUBROUTINE "charout": READS IN AN WOD ASCII FLOATING-POINT
c VALUE SEQUENCE (i.e. # sig-figs,
c # total figs, precision, value itself).
c * THIS WILL BE CALLED TO EXTRACT MOST
c Examples: FLOATING POINT VALUES IN THE WOD ASCII.
c
c VALUE Precision WOD ASCII
c ----- --------- ---------
c 5.35 2 332535
c 5. 0 1105
c 15.357 3 55315357
c (missing) -
c
c ---------------------------------------------------------------
c
c Read in time of cast (time) using CHAROUT subroutine:
c
c istartc - position in character array to begin to read
c in data
c isig - number of digits in data value
c iprec - precision of data value
c ichar - character array from which to read data
c time - data value
c bmiss - missing value marker
c
c*****************************************************************
call charout(istartc,isig(3),iprec(3),itotfig(3),ichar,time,bmiss)
c*****************************************************************
c
c Read in latitude (rlat) and longitude (rlon) using CHAROUT:
c
c Negative latitude is south.
c Negative longitude is west.
c
c*****************************************************************
call charout(istartc,isig(1),iprec(1),itotfig(3),ichar,rlat,bmiss)
call charout(istartc,isig(2),iprec(2),itotfig(3),ichar,rlon,bmiss)
c*****************************************************************
c
c Read in the number of depth levels (levels) using CHAROUT:
c
c*****************************************************************
read(ichar(istartc:istartc),'(i1)') inc
write(aout(3:3),'(i1)') inc
read(ichar(istartc+1:istartc+inc),aout) levels
istartc=istartc+inc+1
c*****************************************************************
c
c Read in whether data is on observed levels (isoor=0) or
c standard levels (isoor=1)
c
c*****************************************************************
read(ichar(istartc:istartc),'(i1)') isoor
istartc=istartc+1
c*****************************************************************
c
c Read in number of variables in cast
c
c*****************************************************************
read(ichar(istartc:istartc+1),'(i2)') nvar
istartc=istartc+2
c*****************************************************************
c
c Read in the variable codes (ip2()) and the whole cast
c error flags (ierror(ip2()))
c
c*****************************************************************
do 30 n = 1,nvar
read(ichar(istartc:istartc),'(i1)') inc
write(aout(3:3),'(i1)') inc
read(ichar(istartc+1:istartc+inc),aout) ip2(n)
istartc=istartc+inc+1
read(ichar(istartc:istartc),'(i1)') ierror(ip2(n))
istartc=istartc+1
30 continue
c****************************************************************
c
c Read in number of bytes in character data
c
c****************************************************************
read(ichar(istartc:istartc),'(i1)') inc
istartc=istartc+1
if ( inc .gt. 0 ) then
write(aout(3:3),'(i1)') inc
read(ichar(istartc+1:istartc+inc),aout) inchad
istartc=istartc+inc
c****************************************************************
c
c Read in number of character and primary investigator arrays
c
c****************************************************************
npi=0
chars(1)(1:4)='NONE'
chars(2)(1:4)='NONE'
read(ichar(istartc:istartc),'(i1)') ica
istartc=istartc+1
c****************************************************************
c
c Read in character and primary investigator data
c 1 - originators cruise code
c 2 - originators station code
c 3 - primary investigators information
c
c****************************************************************
do 45 nn=1,ica
read(ichar(istartc:istartc),'(i1)') icn
istartc=istartc+1
if ( icn .lt. 3 ) then
read(ichar(istartc:istartc+1),'(i2)') ns
istartc=istartc+2
chars(icn)= ' '
chars(icn)= ichar(istartc:istartc+ns-1)
istartc= istartc+ns
else
read(ichar(istartc:istartc+1),'(i2)') npi
istartc=istartc+2
do 505 n=1,npi
read(ichar(istartc:istartc),'(i1)') inc
write(aout(3:3),'(i1)') inc
read(ichar(istartc+1:istartc+inc),aout) ipi(n,2)
istartc=istartc+inc+1
read(ichar(istartc:istartc),'(i1)') inc
write(aout(3:3),'(i1)') inc
read(ichar(istartc+1:istartc+inc),aout) ipi(n,1)
istartc=istartc+inc+1
505 continue
endif
45 continue
endif
c****************************************************************
c
c Read in number of bytes in secondary header variables
c
c****************************************************************
read(ichar(istartc:istartc),'(i1)') inc
istartc=istartc+1
if ( inc .gt. 0 ) then
write(aout(3:3),'(i1)') inc
read(ichar(istartc+1:istartc+inc),aout) insec
istartc=istartc+inc
c****************************************************************
c
c Read in number of secondary header variables (nsecond)
c
c****************************************************************
read(ichar(istartc:istartc),'(i1)') inc
write(aout(3:3),'(i1)') inc
read(ichar(istartc+1:istartc+inc),aout) nsecond
istartc=istartc+inc+1
c****************************************************************
c
c Read in secondary header variables (sechead())
c
c****************************************************************
do 35 n = 1,nsecond
read(ichar(istartc:istartc),'(i1)') inc
write(aout(3:3),'(i1)') inc
read(ichar(istartc+1:istartc+inc),aout) nn
istartc=istartc+inc+1
call charout(istartc,jsig2(nn),jprec2(nn),jtot2(nn),ichar,
* sechead(nn),bmiss)
isec(n) = nn
35 continue
endif
c****************************************************************
c
c Read in number of bytes in biology variables
c
c****************************************************************
read(ichar(istartc:istartc),'(i1)') inc
istartc=istartc+1
if ( inc .gt. 0 ) then
write(aout(3:3),'(i1)') inc
read(ichar(istartc+1:istartc+inc),aout) inbio
istartc=istartc+inc
c****************************************************************
c
c Read in number of biological variables (nbio)
c
c****************************************************************
read(ichar(istartc:istartc),'(i1)') inc
write(aout(3:3),'(i1)') inc
read(ichar(istartc+1:istartc+inc),aout) nbio
istartc=istartc+inc+1
c****************************************************************
c
c Read in biological variables (bio())
c
c****************************************************************
do 40 n = 1,nbio
read(ichar(istartc:istartc),'(i1)') inc
write(aout(3:3),'(i1)') inc
read(ichar(istartc+1:istartc+inc),aout) nn
istartc=istartc+inc+1
call charout(istartc,jsigb(nn),jprecb(nn),jtotb(nn),ichar,
* bio(nn),bmiss)
ibio(n) = nn
40 continue
c****************************************************************
c
c Read in biomass and taxonomic variables
c
c****************************************************************
read(ichar(istartc:istartc),'(i1)') inc
write(aout(3:3),'(i1)') inc
read(ichar(istartc+1:istartc+inc),aout) nbothtot
istartc=istartc+inc+1
do 41 n = 1,nbothtot
itaxtot=0
read(ichar(istartc:istartc),'(i1)') inc
write(aout(3:3),'(i1)') inc
read(ichar(istartc+1:istartc+inc),aout) nn
istartc=istartc+inc+1
vtax(0,n)=nn
do 42 n2 =1,nn
itaxtot=itaxtot+1
read(ichar(istartc:istartc),'(i1)') inc
write(aout(3:3),'(i1)') inc
read(ichar(istartc+1:istartc+inc),aout) itaxnum(itaxtot,n)
istartc=istartc+inc+1
call charout(istartc,jsigtax(itaxtot,n),jprectax(itaxtot,n),
* jtottax(itaxtot,n),ichar,vtax(itaxtot,n),bmiss)
read(ichar(istartc:istartc),'(i1)') itaxerr(itaxtot,n)
istartc=istartc+1
42 continue
41 continue
endif
c****************************************************************
c
c Read in measured and calculated depth dependent variables
c along with their individual reading flags
c
c****************************************************************
do 50 n = 1,levels
if ( isoor.eq.0 ) then
call charout(istartc,idsig(n),idprec(n),idtot(n),ichar,
* depth(n),bmiss)
read(ichar(istartc:istartc),'(i1)') iderror(n,0)
istartc=istartc+1
endif
do 55 i = 1,nvar
call charout(istartc,msig(n,ip2(i)),mprec(n,ip2(i)),
* mtot(n,ip2(i)),ichar,temp(n,ip2(i)),bmiss)
if ( temp(n,ip2(i)) .gt. bmiss ) then
read(ichar(istartc:istartc),'(i1)') iderror(n,ip2(i))
istartc=istartc+1
else
iderror(n,ip2(i))=0
endif
55 continue
50 continue
return
500 ieof = 1
return
end
C---------------------------------------------------------------
SUBROUTINE CHAROUT(istartc,jsig,jprec,jtot,ichar,value,bmiss)
c This subroutine reads a single real value from the
c WOD ASCII format. This value consists of four
c components: # significant figures, # total figures,
c precision, and the value.
c Examples:
c VALUE Precision WOD ASCII
c ----- --------- ---------
c 5.35 2 332535
c 5. 0 1105
c 15.357 3 55315357
c (missing) -
c******************************************************
c
c Passed Variables:
c
c istartc - starting point to read in data
c jsig - number of significant figures in data value
c jprec - precision of data value
c jtot - number of figures in data value
c ichar - character array from which to read data
c value - data value
c bmiss - missing value marker
c
c*****************************************************
c*****************************************************
c
c Character Array:
c
c cwriter - format statement (FORTRAN I/O)
c
c****************************************************
character*6 cwriter
character*(*) ichar
data cwriter /'(fX.X)'/
c****************************************************
c
c Check if this is a missing value (number of
c figures = '-')
c
c****************************************************
if ( ichar(istartc:istartc) .eq. '-' ) then
istartc = istartc+1
value = bmiss
return
endif
c****************************************************
c
c Read in number of significant figure, total
c figures and precision of value
c
c****************************************************
read(ichar(istartc:istartc),'(i1)') jsig
read(ichar(istartc+1:istartc+1),'(i1)') jtot
read(ichar(istartc+2:istartc+2),'(i1)') jprec
istartc=istartc+3
c****************************************************
c
c Write these values into a FORTRAN format statement
c
c e.g. "553" --> '(f5.3)'
c "332" --> '(f3.2)'
c
c****************************************************
write(cwriter(3:3),'(i1)') jtot
write(cwriter(5:5),'(i1)') jprec
c****************************************************
c
c Read in the data value using thhe FORTRAN
c format statement created above (cwriter).
c
c****************************************************
read(ichar(istartc:istartc+jtot-1),cwriter) value
c****************************************************
c
c Update the character array position (pointer)
c and send it back to the calling program.
c
c****************************************************
istartc=istartc+jtot
return
end
C---------------------------------------------------------------
SUBROUTINE NAILUJ(iyear0,iyear,month,iday,time,
* xjulian,jsig)
C COMPUTES CALENDAR DAY FROM JULIAN DAY, INCLUDING TIME, WITH RESPECTS
C TO MIDNIGHT JANUARY 1 OF THE BASE YEAR
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 jsig - output number of significant figures for 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/
xadd=0.
iyearadd=0
xjulian0=xjulian
if ( (iyear0/4)*4 .eq. iyear0 ) xadd=1.
if ( xjulian .ge. zdays+xadd )
* call reducejulian(iyear0,xjulian0,iyearadd)
c Set year
xadd=0.
iyear=iyear0+iyearadd
if ( (iyear/4)*4 .eq. iyear ) xadd=1.
c Set month
x1=0.
do 30 mm=2,13
if ( mm .eq. 3 ) x1=xadd
if ( xjulian0 .lt. yrnorm(mm)+x1 ) then
month=mm-1
goto 31
endif
30 continue
31 continue
c Set day
iday=xjulian0-yrnorm(month)+1.
if ( month .ge. 3 .and. xadd .gt. 0. ) iday=iday-1
c Set time
ijulian=xjulian0
xjuliant=ijulian
time=(xjulian0-xjuliant)*24.
return
end
C---------------------------------------------------------------
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
do 500 nz=1,100
xsub=1.
if ( (iyearx/4)*4 .eq. iyearx) xsub=0.
if ( rjul .ge. xdays-xsub ) then
iyearx=iyearx+1
rjul=rjul-(xdays-xsub)
else
goto 450
endif
500 continue
450 continue
iyearadd=iyearx-iyear
return
end
C-------------------------------------------------------------