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)//'\0',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)//'\0',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-------------------------------------------------------------