PROGRAM OCLdemoQ c This program prints out to the screen data from WOD native format c ASCII file to the screen. This main program (OCLdemoQ) c calls the subroutine WODread (WODread200X if the data file are in WOD05 c or WOD01 format or the subroutine WODread1998 if the data are in WOD98 c format). These subroutines do the actual reading of the ASCII format, c and load the data into arrays which are passed back to the main program. c The main program then work with these data arrays to print out the c data on the screen. c c It is intended that the subroutine WODread provides an example of how c to extract the data and variables from the ASCII format, c whereas the main part of the wodFOR program provides an example of how c these data can be made accessible/workable as a series of arrays. c c Comments and suggestions for improving this program would be appreciated. c Updates to the World Ocean Data 2005 data and to this program will be posted c in the NODC/WOD web site at http://www.nodc.noaa.gov c*********************************************************** c c Missing values used in this dataset = bmiss = -999.99 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 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 taxa sets c maxpinf - maximum number of distinct measured variable c information codes c c****************************************************************** parameter (maxlevel=30000, maxcalc=100) parameter (kdim=40, bmiss=-999.99) parameter (maxtcode=25, maxtax=2000) parameter (maxpinf=25) 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 character*15 chars(2) character*80 filename 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 ip2() - variable codes for variables in cast c ierror() - whole profile error codes for each variable c c ipi() - primary investigators information c 1. primary investigators c 2. for which variable c c jsig2() - number of significant figures in each secondary header variable c jprec2() - precision of each secondary header variable c sechead() - secondary header variables c c jsigb() - number of significant figures in each biological variable c jprecb() - precision of each biological variable c bio() - biological data c c depth() - depth of each measurement c c jtot2() - number of bytes in each secondary header variable c jtotb() - number of bytes in each biological variable c 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 c mtot() - number of digits in each measured variable at c each level of measurement c c temp() - variable data at each level c iderror() - error flags for each variable at each depth level c dunc() - uncertainty for each depth c xunc() - uncertainties for each measurement c iorigflag()- originators flags for each variable and depth c 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 c itaxnum() - different taxonomic and biomass variable c codes found in data c vtax() - value of taxonomic variables and biomass variables c c jsigtax() - number of significant figures in taxon values and c biomass variables c jprectax()- precision of taxon values and biomass variables c c jtottax() - number of bytes in taxon values c itaxerr() - error codes for taxon data c itaxorigerr() - originators error codes for taxon data c c nbothtot()- total number of taxa variables c stdz(40) - standard depth levels c c******************************************************************* integer isig(3), iprec(3), ip2(0:maxlevel), ierror(maxlevel), & 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 xunc(maxlevel,maxcalc),dunc(maxlevel) 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) dimension stdz(kdim) common /thedata/ depth,temp common /flags/ ierror,iderror common /uncertain/ dunc,xunc common /posuncertain/ rlatunc,rlonunc 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 data stdz/ 0., 10., 20., 30., 50., 75., 100., 125., 150., & 200., 250., 300., 400., 500., 600., 700., 800., 900., & 1000., 1100., 1200., 1300., 1400., 1500., 1750., 2000., & 2500., 3000., 3500., 4000., 4500., 5000., 5500., 6000., & 6500., 7000., 7500., 8000., 8500., 9000./ 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************************************************************** c User can modify the next section to read from a text file listing c different input data files as a do-loop, for example, as opposed c a single data input file. write(6,*)' ' write(6,*)'Input File Name:' read(5,'(a80)') filename write(6,*)' ' write(6,*)' ' 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 nvar - number of variables recorded in cast c ip2(i) - 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 bmiss - missing value marker c ieof - set to one if end of file has been encountered 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 dunc(x) - uncertainty related to depth (IQuOD) c xunc(x) - uncertainty related to variables (IQuOD) 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 chars - WOD 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 = 0 !- default is "WOD-200X" ieof = 0 !- initialize end of file flag write(6,*) * 'Enter number of casts to view (0=view entire file)' read(5,*) numcasts if ( numcasts .eq. 0 ) numcasts=10000000 do 50 ij=1,numcasts !- MAIN CAST LOOP chars(1)= ' ' chars(2)= ' ' if (iVERSflag .eq. 0 .or. iVERSflag .eq. 2 .or. * iVERSflag .eq. 3 ) then c . Read in as "WOD-200X" format. c . WOD-2013 (iVERSflag=2) has a slight modification . c . WOD-IQUOD HAS IQUOD UNCERTAINTIES call WODread200X(nf,jj,cc,icruise,iyear,month,iday, & time,rlat,rlon,levels,istdlev,nvar,ip2,nsecond,nbio, & isig,iprec,bmiss,ieof,chars,ipi,npi,iVERSflag) c . ONLY happens if format rejected (rewind and try as WOD-1999) if (iVERSflag .eq. 1) then print *,' ' print *, & ' This data file is not in the WOD-2005 format.', & ' Trying it in the WOD-1998 format.' print *,' ' print *,' ' rewind(nf) !- rewind file endif endif if (iVERSflag .eq. 1) then c . Read in as "WOD-1998" format c . WODread200X rejected format. Must be WOD-1998 format. call WODread1998(nf,jj,cc,icruise,iyear,month,iday, & time,rlat,rlon,levels,istdlev,nvar,ip2,nsecond,nbio, & isig,iprec,bmiss,ieof,chars,ipi,npi) endif if ( ieof.gt.0 ) goto 4 !- Exit c*************************************************************** c c STANDARD LEVELS OR OBSERVED LEVELS c ---------------------------------- c c If this file is on standard levels (istdlev=1), program places the c standard depths in the depth() array (otherwise, observed depth values c were read in and stored above by subroutine WODreadxxxx; where xxxx is c 200X or 1998 depending on the data input format). c c This is only implemented for 'B' version of WOD format c c*************************************************************** if (istdlev .eq. 1 .and. ij .eq. 1 .and. * iVERSflag .ne. 2 ) then do 60 i=1,kdim depth(i)=stdz(i) 60 continue endif c************************************************************** c c WRITE HEADER INFORMATION TO THE SCREEN c -------------------------------------- c c cc - country code (a2) c icruise - WOD cruise identifier (i8) c rlat - latitude (f7.3) c rlon - longitude (f8.3) c iyear - year (i4) c month - month (i2) c iday - day (i2) c time - time (GMT) (f7.2) c jj - WOD cast identifier (i8) c levels - number of depth levels measured (i6) c c************************************************************** 800 format(1x,a2,i8,1x,f7.3,1x,f8.3,1x,i4,1x,i2,1x,i2, & 1x,f7.2,1x,i8,1x,i6) 8000 format(1x,a2,i8,1x,f7.3,1x,f6.3,1x,f8.3,1x,f6.3,1x, & i4,1x,i2,1x,i2,1x,f7.2,1x,i8,1x,i6) write(6,*) &'----------------------------------------------------------' write(6,*) 'Output from ASCII file, cast# ',ij write(6,*) &'----------------------------------------------------------' write(6,*)' ' if ( iVERSflag .ne. 3 ) then write(6,*) & 'CC cruise Latitde Longitde YYYY MM DD Time'// & ' Cast #levels' write(6,800) cc,icruise,rlat,rlon,iyear,month,iday, & time,jj,levels else write(6,*) &'CC cruise Latitde latunc Longitd longunc YYYY MM DD'// &' Time Cast #levels' write(6,8000) cc,icruise,rlat,rlatunc,rlon,rlonunc, & iyear,month,iday,time,jj,levels endif write(6,*) ' ' write(6,*) 'Number of variables in this cast: ',nvar write(6,*) ' ' c************************************************************** c c WRITE CHARACTER DATA TO THE SCREEN c ---------------------------------- c c chars(1) - Originators cruise identifier c chars(2) - Originators station identifier c c************************************************************** if ( ( chars(1)(1:1) .ne. ' ' ) .and. & ( chars(1)(1:4) .ne. 'NONE' )) then write(6,*) 'Originators Cruise Code: ',chars(1) endif if ( ( chars(2)(1:1) .ne. ' ' ) .and. & ( chars(2)(1:4) .ne. 'NONE' )) then write(6,*) 'Originators Station Code: ',chars(2) endif write(6,*) ' ' c*************************************************************** c c WRITE PRIMARY INVESTIGATOR INFORMATION TO THE SCREEN c ---------------------------------------------------- c c npi = number of primary investigator entries c ipi(1..npi,1) - PI code c ipi(1..npi,2) - variable for which PI was responsible c c*************************************************************** do 505 n=1,npi write(6,'(1x,a21,i5,1x,a20,i3)') & 'Primary Investigator:',ipi(n,1), & ' ... for variable #:',ipi(n,2) 505 continue if ( npi .gt. 0 ) write(6,*) ' ' c************************************************************** c c WRITE VARIABLE-CODE (column headings) TO THE SCREEN c ---------------------------------------------------- c c nvar - number of variables (1...nvar) c ip2(1..nvar) - variable code for each variable present c c Example: c For a cast with just Temperature[1], Oxygen[3], Pressure[25]: c c The variable sequence is ip2(1)=Temperature, ip2(2)=Oxygen, c ip2(3)=Pressure c c nvar = 3 c c ip2(1) = 1, ip2(2) = 3, ip3(3) = 25 c c c Note: If "nvar = 0", biology only cast. c c************************************************************** c format(5x,1a,5x,10(3x,i2,11x)) 801 format(5x,"z fo",4x,10(i2,8x,"fo",3x)) 851 format(5x,"z U",5x,"fo",4x,10(i2,7x,"U",10x,"fo",3x)) if (nvar .gt. 0) then if ( iVERSflag .ne. 3 ) then write(6,801) (ip2(n),n=1,nvar) else write(6,851) (ip2(n),n=1,nvar) endif write(6,*)' ' c************************************************************** c c WRITE DEPTH-DEPENDENT VARIABLE DATA TO THE SCREEN c -------------------------------------------------- c c Print depth (depth(n)), error flags for depth (iderror(n,0)), c each variable (temp(n,1..nvar)), and error flags for each c variables (iderror(n,1..nvar)) c c************************************************************** 802 format(f7.1,1x,i1,i1,14(f9.3,' (',i1,') ',i1,i1)) 852 format(f7.1,1x,'[',f6.3,']',1x,i1,i1,14(f9.3, * ' [',f6.3,'] ',' (',i1,') ',i1,i1)) do 80 n=1,levels if ( iVERSflag .ne. 3 ) then write(6,802) depth(n),iderror(n,0),iorigflag(n,0), & (temp(n,ip2(j)),msig(n,ip2(j)), & iderror(n,ip2(j)),iorigflag(n,ip2(j)),j=1,nvar) else write(6,852) depth(n),dunc(n),iderror(n,0),iorigflag(n,0), & (temp(n,ip2(j)),xunc(n,ip2(j)),msig(n,ip2(j)), & iderror(n,ip2(j)),iorigflag(n,ip2(j)),j=1,nvar) endif 80 continue write(6,*) ' ' c*************************************************************** c c PRINT ENTIRE-PROFILE ERROR FLAGS c ------------------------------------ c c*************************************************************** 8021 format('VarFlag: ',11x,11(i1,14x)) write(6,8021)(ierror(ip2(j)),j=1,nvar) write(6,*) ' ' endif !- "if (nvar .gt. 0) then" c************************************************************* c c WRITE SECONDARY-HEADER INFORMATION TO THE SCREEN c --------------------------------------------- c c Print the secondary header code (isec(1..nsecond)) and the value c for that secondary header (sechead(isec(n))). c c************************************************************* 803 format(1x,'Secondary header #',i3,3x,f8.3,' (',i1,')') 8031 format(1x,'Secondary header #',i3,3x,f8.3,' (',i1, * ') INTELMET') 903 format(1x,'Secondary header #',i3,3x,f8.0,' (',i1,')') 9031 format(1x,'Secondary header #',i3,3x,f8.0,' (',i1, * ') INTELMET') do 85 n = 1,nsecond intelmet=0 if ( jtot2(isec(n)) .lt. 0 ) then jtot2(isec(n))=-jtot2(isec(n)) intelmet=1 endif if ( int(sechead(isec(n))) .lt. sechead(isec(n))) then if ( intelmet .eq. 0 ) then write(6,803) isec(n), sechead(isec(n)),jsig2(isec(n)) else write(6,8031) isec(n), sechead(isec(n)),jsig2(isec(n)) endif else if ( intelmet .eq. 0 ) then write(6,903) isec(n), sechead(isec(n)),jsig2(isec(n)) else write(6,9031) isec(n), sechead(isec(n)),jsig2(isec(n)) endif endif 85 continue write(6,*) ' ' c************************************************************* c c WRITE VARIABLE SPECIFIC INFORMATION TO THE SCREEN c ------------------------------------------------- c c************************************************************* 813 format(1x,'Measured Variable #',i3,' Information Code #',i3, & 3x,f8.3,' (',i1,')') 814 format(1x,'Measured Variable #',i3,' Information Code #',i3, & 3x,f8.3,' (',i1,') INTMET') 913 format(1x,'Measured Variable #',i3,' Information Code #',i3, & 3x,f8.0,' (',i1,')') 914 format(1x,'Measured Variable #',i3,' Information Code #',i3, & 3x,f8.0,' (',i1,') INTMET') do 86 j0=1,nvar j=ip2(j0) do 87 i=1,maxpinf intelmet=0 if ( jtotp(i,j) .lt. 0 ) then jtotp(i,j)=-jtotp(i,j) intelmet=1 endif if ( jtotp(i,j) .gt. 0 ) then if ( int(parminf(i,j)) .lt. parminf(i,j)) then if ( intelmet .eq. 0 ) then write(6,813) j, i,parminf(i,j),jsigp(i,j) else write(6,814) j, i,parminf(i,j),jsigp(i,j) endif else if ( intelmet .eq. 0 ) then write(6,913) j, i,parminf(i,j),jsigp(i,j) else write(6,914) j, i,parminf(i,j),jsigp(i,j) endif endif jtotp(i,j)=0 endif 87 continue 86 continue c************************************************************* c c WRITE BIOLOGICAL HEADER INFORMATION TO THE SCREEN c ------------------------------------------ c c Print the biology header code (ibio(1..nbio)) and the value c for that biology header (bio(ibio(n))). c c************************************************************* 804 format(1x,'Biological header #',i3,3x,f13.3,' (',i1,')') do 90 n = 1,nbio write(6,804) ibio(n), bio(ibio(n)),jsigb(ibio(n)) bio(ibio(n))=bmiss jsigb(ibio(n))=0 ibio(n)=0 90 continue nbio=0 write(6,*) ' ' c************************************************************* c c WRITE TAXA SET/BIOMASS VARIABLE INFORMATION TO THE SCREEN c ---------------------------------------------------------- c c For each set/variable (1..nbothtot), print the set/variable code c (ivtax = vtax(1,n)) and each member of that set (1..vtax(0,n)), c where the sub-code is itaxnum(n2,n) and the sub-value is vtax(n2,n). c c************************************************************* 805 format(5x,' Code #',i4,3x,f13.3,' (',i1,') ',i1,i1) do 91 n = 1,nbothtot intax = vtax(0,n) ivtax = vtax(1,n) if ( ivtax .lt. 0. .and. ivtax .gt. -501.) then write(6,'(a8,i3,1x,a25,i12," (",i1,")")') 'Taxa-set',n, & ': Biomass Parameter [1]#',ivtax,jsigtax(1,n) else write(6,'(a8,i3,1x,a22,4x,i10," (",i1,") ")') 'Taxa-set',n, & ': Taxonomic Code [1]#',ivtax,jsigtax(1,n) endif vtax(0,n)=0. vtax(1,n)=0. do 92 n2 = 2,intax write(6,805) itaxnum(n2,n), vtax(n2,n), jsigtax(n2,n), & itaxerr(n2,n),itaxorigerr(n2,n) vtax(n2,n)=bmiss jsigtax(n2,n)=0 itaxnum(n2,n)=0 92 continue write(6,*)' ' 91 continue nbothtot=0 write(6,*) ' ' 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 set to "3" if this is an IQuOD file 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 dunc - uncertainty for each depth value (IQuOD) c xunc - uncertainty for each variable value (IQuOD) 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 xunc(maxlevel,maxcalc),dunc(maxlevel) 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 /uncertain/ dunc,xunc common /posuncertain/ rlatunc,rlonunc 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' .and. xchar(1:1) .ne. 'Q' ) 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 elseif ( xchar(1:1) .eq. 'Q' ) then iVERSflag=3 !- IQuOD 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) if ( iVERSflag .eq. 3 ) then call charout(istartc,idumsig,idumprec,idumtot, * ichar,rlatunc,bmiss) endif call charout(istartc,isig(2),iprec(2),itotfig(2),ichar, * rlon,bmiss) if ( iVERSflag .eq. 3 ) then call charout(istartc,idumsig,idumprec,idumtot, * ichar,rlonunc,bmiss) endif 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 profile 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) c place intelligent metadata info in total figs (negative) if ( iVERSflag .eq. 3 ) then read(ichar(istartc:istartc),'(i1)') intelm istartc=istartc+1 if ( intelm .eq. 1 ) jtotp(nn,ip2(n))=-jtotp(nn,ip2(n)) endif 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 npi=0 chars(1)(1:4)='NONE' chars(2)(1:4)='NONE' 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**************************************************************** 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) c place intelligent metadata info in total figs (negative) if ( iVERSflag .eq. 3 ) then read(ichar(istartc:istartc),'(i1)') intelm istartc=istartc+1 if ( intelm .eq. 1 ) jtot2(nn)=-jtot2(nn) endif 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 nbio=0 inbio=0 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 if ( iVERSflag .eq. 3 ) then call charout(istartc,idumsig,idumprec, & idumtot,ichar,dunc(n),bmiss) if ( dunc(n) .le. bmiss ) dunc(n)=0.0 endif 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 if ( iVERSflag .eq. 3 ) then call charout(istartc,idumsig,idumprec, & idumtot,ichar,xunc(n,ip2(i)),bmiss) if ( xunc(n,ip2(i)) .le. bmiss ) xunc(n,ip2(i))=0.0 endif 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 xunc(maxlevel,maxcalc),dunc(maxlevel) 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 /uncertain/ dunc,xunc 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 -999.99 - missing value marker (bmiss) 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 profile 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