      SUBROUTINE MBTbiasant(itsprobe,temp,maxlevel,maxcalc,
     * numlevels,iyearx,levelmaxbias,depth,isoor,numsec)

C     MBTBIASANT CORRECTS MBT BIAS BASED ON INFORMATION FROM
C     ANTONOV.  THE CORRECTIONS ARE ON STANDARD LEVELS

      parameter (maxyear=3000,maxset=137,maxlayer=137)
      character*4 cdepthset
      character*7 firsttime
      character*80 filename,infile
      dimension xbias(maxyear,maxset)
      dimension temp(maxlevel,maxcalc)
      dimension depth(maxlevel)
      dimension xlayer(maxlayer,2)

      common /extra/ ir2,ireqsecond,ireqbio

      save firsttime
      save xbias,nlayers,xlayer

      if ( firsttime .ne. 'mbtbias' ) then
       firsttime = 'mbtbias'

c      set layers

       call setlayers(nlayers,xlayer,maxlayer)

       call clearstring(filename,80)
       call checkwhichdepthfile(cdepthset)
       if ( cdepthset .eq. 'orig' ) then
        call extraname('sys.inf'//CHAR(0),
     *   'antonov_mbtbias'//CHAR(0),filename)
       else
        infile='antonov_mbtbias_'//cdepthset//CHAR(0)
        call extraname('sys.inf'//CHAR(0),infile,filename)
       endif
       open(9,file=filename,status='old')

       xyear0=0.0
       iyear=0
       inumset=0
       do 55 n=1,maxyear

        read(9,*,end=44) xyear,xdep,xbias0,inum
        if ( xyear0 .ne. xyear ) then
         iyear=xyear
         xyear0=xyear
         inumset=0
        endif

        inumset=inumset+1
        if ( inum .ge. 30 ) then
         xbias(iyear,inumset)=xbias0
        else
         xbias(iyear,inumset)=0.0
        endif

55     continue
44     continue
       close(9)
 
      endif

      if ( itsprobe .eq. 1 ) then

       do 60 n0=1,numlevels

        if ( isoor .eq. 1 ) then
         n=n0
         ic=n0
         np=0
        else

         if ( n0 .le. maxlevel ) then
          ic=n0
          np=0
          dpt=depth(n0)
         else
          call overmax(maxlevel,nsecond,n0,0,ic,np)
          dpt=temp(ic,np)
         endif

         n=0
         do 65 n2=1,nlayers

          if ( dpt .ge. xlayer(n2,1) .and.
     *         dpt .lt. xlayer(n2,2) ) then
           n=n2
          endif

65       continue

        endif

c       write(6,*) 'nn',n,dpt,levelmaxbias,xbias(iyearx,n),iyearx
        if ( n .eq. 0 .or. n .gt. levelmaxbias ) return

        temp(ic,np+1)=temp(ic,np+1)-xbias(iyearx,n)

60     continue

      endif

      return
      end
      SUBROUTINE XBTbias_gour_rese_new(itsprobe,depth,temp,maxlevel,
     * maxcalc,numsec,numlevels,iyearx,month,ixprobe,bmiss,ifix,iplat)

C     XBTBIASgour CORRECTS XBT BIAS BASED ON INFORMATION FROM
C     GOURETSKI AND RESEGHETTI 2010  THE CORRECTIONS ARE MADE BEFORE
C     INTERPOLATION TO STANDARD LEVELS
      parameter (maxyear=50,maxset=40,n46=8,n7db=8,n5=3,n10=4)
      parameter (maxdepth=3000,monthx=12,ntno=4)
      parameter (ntmax=4)
      character*21 firsttime
      dimension depth(maxlevel),temp(maxlevel,maxcalc)
      dimension itype46(n46),itype7db(n7db)
      dimension itype5(n5),itype10(n10)
      dimension itypeno(ntno)
      dimension thermal_bias(maxyear,monthx,ntmax)
      dimension dstretch(maxyear,monthx,maxdepth,ntmax)
      dimension t_bias(maxyear,ntmax)
c     dimension d_bias(maxyear,ntyp)
      dimension coeff1(maxyear,ntmax),coeff2(maxyear,ntmax)

      data itype46 /202,203,208,209,215,216,223,226/
      data itype7db /201,207,214,217,227,228,232,235/
      data itype5 /210,219,224/
      data itype10 /205,211,220,229/
      data itypeno /234,233,204,225/


      save firsttime
      save thermal_bias,dstretch,coeff1,
     * coeff2,t_bias,nyearmin,nyearmax,myearmin,myearmax,
     * oyearmax,oyearmin
      if ( firsttime .ne. 'xbtbias_gour_rese_new' ) then
       firsttime = 'xbtbias_gour_rese_new'

      call readgournew1(maxyear,monthx,ntmax,thermal_bias,nyearmin,
     * nyearmax)
      call readgournew2(maxyear,monthx,ntmax,thermal_bias,nyearmin,
     * nyearmax)
      call readgournew3(maxyear,monthx,ntmax,thermal_bias,myearmin,
     * myearmax)
      call readgournew4(maxyear,monthx,maxdepth,ntmax,dstretch,
     * nyearmin,nyearmax)
      call readgournew5(maxyear,monthx,maxdepth,ntmax,dstretch,
     * oyearmin,oyearmax)
      call readgournew6(maxyear,monthx,maxdepth,ntmax,dstretch,
     * myearmin,myearmax)
      call readgournew7(maxyear,ntmax,coeff1,coeff2,t_bias,
     * nyearmin,nyearmax)
      endif
       ntyp=0
       ifix=0
      if ( numlevels .le. maxlevel ) then
       dpt=depth(numlevels)
      else
       call overmax(maxlevel,numsec,numlevels,0,ic,np)
       dpt=temp(ic,np)
      endif
       shalmax=550.
c      write(6,*) 'entershallowdeep'
       call xbtshallowdeep(ishallow,ixprobe,dpt,shalmax,iplat)
c      write(6,*) 'ishallow',ishallow
c       if (ishallow .eq. -1) return
c      if ( dpt .gt. 960. ) return
      idpt=dpt
      iyear=iyearx
      if ( iyearx .lt. 1967 ) iyear=1967
      if ( iyearx .gt. nyearmax ) iyear=nyearmax
c     write(6,*) 'iyear,nyearmin',iyear,nyearmin
       if (itsprobe .eq. 2) then
c      write(6,*) 'itsprobe',itsprobe,ixprobe
        if (ixprobe .eq. 2) then       
         ntyp=0
        elseif ( ixprobe .ne. 2 .and. ixprobe .ne. 0) then
        do 150 nn=1,n46
150      if ( ixprobe .eq. itype46(nn) ) ntyp=1
        do 155 nn=1,n7db
155      if ( ixprobe .eq. itype7db(nn) ) ntyp=2
        do 160 nn=1,n5
160      if ( ixprobe .eq. itype5(nn) ) ntyp=3
c       write(6,*) 'ixp',ixprobe,ntyp
        do 165 nn=1,n10
165      if ( ixprobe .eq. itype10(nn) ) ntyp=4
        do 170,nn=1,ntno
170      if ( ixprobe .eq. itypeno(nn) ) ntyp=0
        endif
 
        if (ntyp .eq. 0) then
        if (ishallow .eq. 1) ntyp=1
        if (ishallow .eq. 0) ntyp=2
        endif
        if (ntyp .eq. 2) then
        if (dpt .gt. 960) return
c        if (iyearx .lt. 1970) then
c        dstretch(iyear,month,idepth,ntyp)=dstretch(inyear,month,
c     * idepth,ntyp)
c        endif
        endif
        if (ntyp .eq. 3) then
        if (iyearx .lt. 1984 ) iyear=1984
        endif
        endif 
c      endif
c      write(6,*) 'ixprobe,iyearx,iyear', ixprobe,iyear,iyear
c     write(6,*) 'ntyp',ntyp
c     write(6,*) 'iyearmin,iyearmax',iyearmin,iyearmax
       ifix=1
       if (ntyp .ne. 4 ) then
       do 200 k=1,numlevels
       idepth=depth(k)
       depth(k)=depth(k)*(dstretch(iyear,month,idepth,ntyp))
       temp(k,1)=temp(k,1)-thermal_bias(iyear,month,ntyp)
c       write(6,*) 'iyearx,month',iyear,month,
c     * ixprobe,idpt,idepth
c     * month,thermal_bias(iyear,month,ntyp),dstretch(iyear,
c     *month,idepth,ntyp),idepth,ixprobe
c      write(6,*) 'iyearx,month,thermal_bias,dstretch,depth',iyear,
c    * month,thermal_bias(iyear,month,ntyp),dstretch(iyear,
c    * month,idepth,ntyp),idepth,iyear,month,idepth,ntyp
200    continue
c       write(6,*) 'iyear,month,ntyp', iyear,month,ntyp,
c     * thermal_bias(iyear,month,ntyp),dstretch(iyear,month,depth(100),
c     * ntyp),depth(100)
       else
       do 400 k=1,numlevels
       d_bias= -1.*(coeff1(iyear,ntyp)+
     * coeff2(iyear,ntyp)*depth(k))
       depth(k)=depth(k)-d_bias
       temp(k,1)=temp(k,1)-t_bias(iyear,ntyp)
c       write(6,*) 'iyearx,month,iuniq',iyear,month,
c      * ixprobe,idpt,idepth,iuniq
400    continue
      endif
c     write(6,*) dstretch(iyear,month,depth(k),ntyp)
      return
      end

      SUBROUTINE XBTBIASant(itsprobe,temp,maxlevel,maxcalc,
     * numlevels,iyearx,levelmaxbias,depth,isoor,nsecond)

C     XBTBIASANT CORRECTS XBT BIAS BASED ON INFORMATION FROM
C     ANTONOV.  THE CORRECTIONS ARE ON STANDARD LEVELS

c     levelmaxbias is the maximum standard level at which
c     bias correction should be applied.  levelmaxbias
c     should correspond to 1000. meters depth

      parameter (maxyear=3000,maxset=137,maxlayer=137)
      character*4 cdepthset
      character*7 firsttime
      character*80 filename,infile
      dimension xbias(maxyear,maxset)
      dimension depth(maxlevel),temp(maxlevel,maxcalc)
      dimension xlayer(maxlayer,2)

      common /extra/ ir2,ireqsecond,ireqbio

      save firsttime
      save xbias,iyearmin,iyearmax,nlayers,xlayer

      if ( firsttime .ne. 'xbtbias' ) then
       firsttime = 'xbtbias'

c      set layers

       call setlayers(nlayers,xlayer,maxlayer)
       call clearstring(filename,80)
       call checkwhichdepthfile(cdepthset)
       if ( cdepthset .eq. 'orig' ) then
        call extraname('sys.inf'//CHAR(0),
     *   'antonov_xbtbias'//CHAR(0),filename)
       else
        open(9,file='other_xbtbias',status='old',
     *   iostat=ios)
        if ( ios .ne. 0 ) then
         infile='antonov_xbtbias_'//cdepthset//CHAR(0)
         call extraname('sys.inf'//CHAR(0),infile,filename) 
        else
         call clearstring(filename,80)
         read(9,'(a)') filename
         close(9)
         write(6,*) 'infile:',filename
         call addCend(filename,80,0)
        endif
       endif
       open(9,file=filename,status='old')

       xyear0=0.0
       iyear=0
       inumset=0
       iyearmax=0.0
       iyearmin=5000

       do 55 n=1,maxyear

        read(9,*,end=44) xyear,xdep,xbias0,inum
        if ( xyear0 .ne. xyear ) then
         iyear=xyear
         if ( iyear .gt. iyearmax ) iyearmax=iyear
         if ( iyear .lt. iyearmin ) iyearmin=iyear
         xyear0=xyear
         inumset=0
        endif

        inumset=inumset+1
        if ( inum .ge. 30 ) then
         xbias(iyear,inumset)=xbias0
        else
         xbias(iyear,inumset)=0.0
        endif

55     continue
44     continue
       close(9)
 
      endif

      iyearb=iyearx
      if ( iyearx .lt. iyearmin ) iyearb=iyearmin
      if ( iyearx .gt. iyearmax ) iyearb=iyearmax

      if ( itsprobe .eq. 2 ) then

       do 60 n0=1,numlevels

        if ( isoor .eq. 1 ) then
         n=n0
         ic=n0
         np=0
        else

         if ( n0 .le. maxlevel ) then
          ic=n0
          np=0
          dpt=depth(n0)
         else
          call overmax(maxlevel,nsecond,n0,0,ic,np)
          dpt=temp(ic,np)
         endif

         n=0
         do 65 n2=1,nlayers

          if ( dpt .ge. xlayer(n2,1) .and.
     *         dpt .lt. xlayer(n2,2) ) then
           n=n2
          endif

65       continue 

        endif

        if ( n .eq. 0 .or. n .gt. levelmaxbias ) return

        temp(ic,np+1)=temp(ic,np+1)-xbias(iyearb,n)

60     continue

      endif

      return
      end
      SUBROUTINE XBTBIASCHOOSE(ichoice,iyear,month,numlevels,isoor,
     * ifix,ireset54,ihanawaalready)

C     XBTBIASCHOOSE CALCULATES APPROPRIATE XBTBIAS
C     DEPENDING ON USER CHOICE

c   choices:
c    -1, reset second header 54 only
c     0. no corrections
c     1,needs Hanawa et al.; 1994 applied (XBT)
c     2,needs Kizu et al.; 2005 applied (XBT)
c     3,Hanawa et al.; 1994 applied (XBT)
c     4,Kizu et al.; 2005 applied (XBT)
c     Note: if choice is 3, 3 and 4 are executed
c     5,Levitus et al.; 2009 applied (XBT/MBT)
c     6,Wijffels et al.; 2008 Table 1 applied (XBT)
c     7,Wijffels et al.; 2008 Table 2 applied (XBT)
c     8,Ishii and Kimoto; 2009 applied (XBT/MBT)
c     9,Gouretski and Reseghetti; 2010 applied (XBT/MBT)
c     10,Good; 2011 applied (XBT)
c     11,Hamon et al.; 2012 applied (XBT/MBT)
c     12,Gourestki; 2012 applied (XBT)
c     13,Cowley et al. (in prep)
c     14,Lijing from Cowley et al. (in prep)
c     15,Lijing (in prep)

c     ireset54 is set to 1 if second header 54 is to
c     be reset based on above choice.

c     ihanawaalready is set to 1 if a depth equation 
c     transformation has already been applied (where appropriate)
c     [For most cases this means Hanawa has been applied,
c      for choice 9, Gouretski+Reseghetti, this means Sippican
c      depth equation]

      parameter (acoeff=6.472, bcoeff=0.00216)
      parameter (maxlevel=6000,maxcalc=200)
      parameter (kdim=137,noffset=200,bmiss=-1.E10)
      parameter (xbtmaxdepth=2500.)

      character*13 firsttime
      dimension numlevels(0:1),dz(kdim),t0(maxlevel)
      dimension iprec(maxlevel)

      common /thedata/ depth(maxlevel),temp(maxlevel,maxcalc)
      common /significant/ isignif(maxlevel,maxcalc)
      common /eachparm/ numeach(6),numtot2,numtot3,ntax,numsecse
      common /extra/ ireqpars2,ireqsecond,ireqbio

      save firsttime
      save levelmaxbias,dz,ndeps

      if ( firsttime .ne. 'XBTbiaschoice' ) then
       call setstandepsfromfile(ndeps,dz)
c      levelmaxbias is the maximum standard depth for XBTs
c      which are corrected (Levitus correction)
       call finddepthlevelnum(dz,kdim,ndeps,950.,levelmaxbias)

       firsttime='XBTbiaschoice'
      endif

c     Is this an XBT?

      xprobe=temp(numtot2+noffset+5,numeach(1))

      if ( temp(numtot2+29,numeach(1)) .gt. bmiss ) then
       ixtype=temp(numtot2+29,numeach(1))
      else
       ixtype=0
      endif

      if ( ixtype .ne. 2 ) then
       ifix=-1
       return
      endif

c     Get platform (for airdrops, airplane=183)
      iplat=-1
      if ( temp(numtot2+3,numeach(1)) .gt. bmiss )
     * iplat=temp(numtot2+3,numeach(1))

c     Check for depth fix instructions
c     If insufficient information, but year > 1997
c     assume Hanawa
c     xneg is to multiply eventual correction code by -1 
      xneg=1.
      xswitch=temp(numtot2+33,numeach(1))
      if ( temp(numtot2+54,numeach(1)) .le. bmiss )  then
       xno54=1.
      else
       xno54=0.
       if ( temp(numtot2+54,numeach(1)) .lt. 0. .and.
     *  iyear .gt. 1997 .and. ichoice .gt. 0 ) then
        xswitch=1.
        xneg=-1
       endif
      endif

      if ( xprobe .gt. bmiss ) then
       ixtype2=xprobe
      else
       ixtype2=ixtype
       xprobe=temp(numtot2+29,numeach(1))
      endif

c     Check if T5
      it5=0
      if ( ixtype2 .eq. 204 .or. ixtype2 .eq. 210 .or.
     *     ixtype2 .eq. 219 .or. ixtype .eq. 224 .or.
     *     ixtype2 .eq. 225 ) then
       it5=1
      endif

c     Check if a fix is needed
c      ifix=-1, no fix can be made due to
c      max depth exceeded for non-T5/Fast Deep/air drop
c      or no probe indicator, or no depth equation given
c      ifix=0, Hanawa correction already applied
c      ifix=1, run Hanawa correction

      ifix=0
      xfix=0.

      if ( ichoice .ne. 0 ) then

c      Record precision of each temperature
       
       do 400 nn=1,numlevels(isoor)
400     call findprecone(iprec(nn),isignif(nn,1),temp(nn,1))

c      Check for non-corrected XBTs
c      Air-drop, submarine, MHI, Sparton 20, 20DB
       if ( isoor .eq. 1 ) then
        dpt=dz(numlevels(1))
        do 355 nn=1,numlevels(1)
355      depth(nn)=dz(nn)
       elseif ( numlevels(0) .le. maxlevel ) then
        dpt=depth(numlevels(0))
       else
        call overmax(maxlevel,nsecond,numlevels(0),0,ic,np)
        dpt=temp(ic,np)
       endif

c     Exceeds max possible for XBT
       if ( dpt .gt. xbtmaxdepth ) then
        ifix=-1
        return
       endif
        
c      Hamon defines shallow/deep cutoff differently
c     shalmax is max depth for shallow XBT
c     from wijffels et al., except for hamon et al (11)
       shalmax=550.
       if ( ichoice .eq. 11 ) shalmax=500. 
       call xbtshallowdeep(ishallow,ixtype2,dpt,shalmax,iplat)
       call XBTneedsconv(numlevels(isoor),xprobe,xswitch,iyear,ifix,
     * iplat)
       xfix=ifix
       if ( xfix .gt. 0. ) xfix=xfix*xneg

c      Gouretski + Reseghetti (ichoice=9) uses uncorrected XBTs
c      Lijing corrections (14,15) use given depth equation
c      Wijjfels Table 2 (Willis) corrections (7) use given depth equation
       if ( ifix .gt. 0 .and. ichoice .ne. 9 .and.
     *      ichoice .gt. 0 .and.ichoice .ne. 14 .and.
     *      ichoice .ne. 15 .and. ichoice .ne. 7 .and.
     *      ihanawaalready .eq. 0 .and.
     *    (ishallow .ge. 0 .or. it5 .eq. 1 )) then
c      Conversion to Hanawa or Kizu (TSK T5)
        call XBTconv(numlevels(isoor),xprobe)
        write(6,*) 'H95',depth(697)
c      Reset xfix to  Hanawa/Kizu fix
c      Hanawa=3, Kizu=4 (where ifix=1,2)
        xfix=ifix+2.
       endif

       if ( ichoice .eq. 5 ) then

c      Levitus corrections

        if ( ifix .ge. 0 .and.
     *     (ishallow .ge. 0 .or. it5 .eq. 1 )) then

         call XBTbiasant(ixtype,temp,maxlevel,maxcalc,
     *    numlevels(isoor),iyear,levelmaxbias,depth,isoor,
     *    numeach(1))
         xfix=ichoice*xneg

        endif

       elseif ( ichoice .eq. 6 ) then

        if ( ishallow .ge. 0 .and. ixtype .eq. 2 ) then
c        Wijffels Table 1
         call XBTbiaswij(ixtype,depth,temp,maxlevel,
     *    maxcalc,numeach(1),numlevels(isoor),iyear,month,
     *    ifix)
         xfix=ichoice*xneg
        endif

       elseif ( ichoice .eq. 7 ) then
c        Wijffels Table 2 (Willis)
          if ( xswitch .gt. bmiss ) then
           iswitch=xswitch
          else
           if ( iyear .gt. 1997 ) then
           iswitch=1
          else
           iswitch=0
          endif
         endif

c        write(6,*) 'here',iswitch,ixtype,ixtype2
         call XBTbiaswil(ixtype,ixtype2,depth,temp,maxlevel,
     *    maxcalc,numeach(1),numlevels(isoor),iyear,month,
     *    iswitch,ifix,iplat)
         if ( ifix .eq. 1 ) xfix=ichoice*xneg

       elseif ( ichoice .eq. 8 ) then

c       Ishii + Kimoto
        call XBTbiasish(ixtype,ixtype2,depth,temp,maxlevel,
     *   maxcalc,numeach(1),numlevels(isoor),iyear,month,ifix)
        if ( ifix .eq. 1 ) xfix=ichoice*xneg

       elseif ( ichoice .eq. 9 ) then

c      Gouretski + Reseghetti

c      Adjust depths to Sippican equation if necessary
        if ( xswitch .eq. 1. .and. ihanawaalready .eq. 0 ) then

         call timefromdepth(numlevels(isoor),t0,maxlevel,1,
     *    depth)
         call droprate_apply(acoeff,bcoeff,numlevels(isoor),depth,
     *    maxlevel,t0)
        endif

        call XBTbias_gour_rese_new(ixtype,depth,temp,maxlevel,
     *   maxcal,numeach(1),numlevels(isoor),iyear,month,ixtype2,
     *   bmiss,ifix,iplat)
 
c        call XBTbiasgour(ixtype,depth,temp,maxlevel,
c     *   maxcalc,numeach(1),numlevels(isoor),iyear,ixtype2,bmiss,
c     *   ifix)
c       write(6,*) 'ifixgour',ifix
        if ( ifix .eq. 1 ) xfix=ichoice*xneg

c     Adjust for below zero values

        ncheck=8
        if ( ncheck .gt. numlevels(isoor) )
     *   ncheck=numlevels(isoor)
        islessthanzero=0
        do 700 kk=1,ncheck
         if ( depth(kk) .lt. 0. ) then
          islessthanzero=1
          temp(kk,1)=bmiss
         endif
700     continue

        if ( islessthanzero .eq. 1 .and. depth(1) .le. 0. )
     *   temp(1,1)=bmiss

       elseif ( ichoice .eq. 10 ) then

c       Good 2011

        call XBTbiasgood(ixtype,depth,temp,maxlevel,
     *   maxcalc,numeach(1),numlevels(isoor),iyear,ixtype2,bmiss,
     *   ifix)
        if ( ifix .eq. 1 ) xfix=ichoice*xneg

       elseif ( ichoice .eq. 11 ) then

c      Hamon et al. 2012 not yet prepared

       call XBTbiashamon(ixtype,depth,temp,maxlevel,maxcalc,
     *numeach(1),numlevels(isoor),iyear,ixtype2,rlat,rlon,bmiss,ifix,
     * iplat)
        if ( ifix .eq. 1 ) xfix=ichoice*xneg

       elseif ( ichoice .eq. 12 ) then

c       Gouretski 2012 

        if ( xswitch .eq. 1. .and. ihanawaalready .eq. 0 ) then

         call timefromdepth(numlevels(isoor),t0,maxlevel,1,
     *    depth)
         call droprate_apply(acoeff,bcoeff,numlevels(isoor),depth,
     *    maxlevel,t0)
        endif

         call XBTbiasgourt12(ixtype,depth,temp,maxlevel,
     *    maxcalc,numeach(1),numlevels(isoor),iyear,ixtype2,bmiss,
     *    ifix,iplat)
        if ( ifix .eq. 1 ) xfix=ichoice*xneg

       elseif ( ichoice .eq. 13 ) then

c      Cowley et al 2012
c      iterat is the version of the corrections: current=3
        iterat=4
        if ( ishallow .ge. 0 .and. it5 .eq. 0 ) then
         call XBTbiascowlX(depth,temp,maxlevel,
     *    maxcalc,ixtype,ixtype2,iyear,numeach(1),
     *    numlevels(isoor),iterat,iplat)
         xfix=ichoice*xneg
        endif

       elseif ( ichoice .eq. 14 ) then

c       Cowley et al 2012 Lijing correction
        if ( ishallow .ge. 0 .and. it5 .eq. 0 ) then
         call XBTbiaslijing(depth,temp,maxlevel,
     *    maxcalc,ixtype,ixtype2,iyear,numeach(1),
     *    numlevels(isoor),bmiss,xswitch,iplat)
         xfix=ichoice*xneg
        endif

       elseif ( ichoice .eq. 15 ) then

c       Lijing et al 2012
c       iwrite writes info to screen when set to 1
        iwrite=0
        call XBTbiaslijing2(depth,temp,maxlevel,
     *   maxcalc,ixtype,ixtype2,iyear,numeach(1),
     *   numlevels(isoor),bmiss,iwrite,ifix,xswitch,
     *   iplat)
        if ( ifix .eq. 1 ) xfix=ichoice*xneg
c       write(6,*) 'xfix',ifix,xfix,xneg,ichoice

       endif

c     Reset second header 54
       if ( ireset54 .eq. 1 ) then
        temp(numtot2+54,numeach(1))= xfix 
        temp(1,numeach(1))=temp(1,numeach(1))+xno54
        if ( xfix .lt. 10. ) then
         isignif(numtot2+54,numeach(1))=1
        else
         isignif(numtot2+54,numeach(1))=2
        endif
       endif

c     Reset significant figures

      do 401 nn=1,numlevels(isoor)
401    call findsignif(isignif(nn,1),iprec(nn),temp(nn,1))

      endif

      return
      end


      SUBROUTINE XBTbiascowlX(depth,temp,maxlevel,maxcalc,
     * itsprobe,ixbttype,iyear0,numsec,numlevels,iterat,iplat)

C     XBT BIAS CORRECTION FROM COWLEY ET AL. 2012
C     SO FAR THE ONLY PROBE TYPES COVERED ARE
C      2 (xbt4 - 208) [Also 202, 203, 205, 206, 208
C                      209, 211, 212, 215, 216 ]
C     42 (xbt7 - 207) [Also 201, 213, 214, 235, 236,
C                      217, 232]
C    212 (xbt6t - 216)
C    222 (xbt7t - 217) [Also 232 TSK DB]
C    ASSUMPTIONS: 
C     UNKNOWN PROBE TYPE SHALLOW: SAME AS xbt4
C     UNKNOWN PROBE TYPE DEEP: SAME AS xbt7
C     T5 NOT CORRECTED
C     KNOWN PROBES NOT COVERED ABOVE USE
C     SHALLOW/DEEP SAME AS UNKNOWN
C     SHALLOW/DEEP CRITERA SWITCH AT 550 M.

c     iterat is the iteration of the corrections
c     1 uses cowley_XBT_corrs.csv
c     2 uses cowley_XBT_corrs2.csv
c     3 uses cowley_XBT_corrs3.csv

      parameter (ishallowprobe=208,ideepprobe=207)
      parameter (ideepprobetsk=217)
      parameter (icmax=10,maxyear=3000)

      character*11 firsttime
      character*30 ctext,cprobe
      character*80 text,filename

      dimension icomma(icmax,2)
      dimension iyearcount(maxyear,0:3)
      dimension xoutput(maxyear,5,3)
      dimension xoutsd(maxyear,5,3)
      dimension iprobetype(maxyear,5)
      dimension depth(maxlevel),temp(maxlevel,maxcalc)

      save firsttime
      save xoutput,xoutsd,iprobetype,iyearcount,
     * iyearmin,iyearmax

      if ( firsttime .ne. 'XBTbiascowl' ) then
       firsttime='XBTbiascowl'

c     read in bias corrections

      if ( iterat .eq. 1 ) then
        call extraname('sys.inf'//CHAR(0),
     * 'cowley_XBT_corrs.csv'//CHAR(0),
     *  filename)
       elseif ( iterat .eq. 2 ) then
        call extraname('sys.inf'//CHAR(0),
     *  'cowley_XBT_corrs2.csv'//CHAR(0),
     *  filename)
       else
        call extraname('sys.inf'//CHAR(0),
     *  'cowley_XBT_corrs4.csv'//CHAR(0),
     *  filename)
       endif

       open(9,file=filename,status='old')

       read(9,'(a)') text
       iyearmin=maxyear
       iyearmax=0
       itype0=0

       do 50 n=1,maxyear

        call clearstring(text,80)
        read(9,'(a)',end=4) text
        call findlastchar(nsp,text,80)

        call commafindx(nsp,icmax,ncomma,icomma,text)

c     value
        ivaluefound=0
        if ( text(icomma(4,1):icomma(4,1)+icomma(4,2)-1)
     *   .ne. 'NaN' ) then 
         read(text(icomma(4,1):icomma(4,1)+icomma(4,2)-1),*)
     *   xvalue
         ivaluefound=1
        endif
        if ( ivaluefound .eq. 0 ) goto 50

c     standard deviation
        if ( text(icomma(5,1):icomma(5,1)+icomma(5,2)-1)
     *   .ne. 'NaN' ) then 
         read(text(icomma(5,1):icomma(5,1)+icomma(5,2)-1),*)
     *    xsd
        endif

        call clearstring(ctext,30)
        ctext(1:icomma(1,2))=
     *   text(icomma(1,1):icomma(1,1)+icomma(1,2)-1)
        nspx=icomma(1,2)
        itype=0
        if ( (nspx .eq. 17 .and. ctext(1:17) .eq.
     *   'Depth error slope') .or. (nspx .eq. 5 .and.
     *    ctext(1:5) .eq. 'alpha')  ) then
         itype=1
        elseif ( (nspx .eq. 18 .and. ctext(1:18) .eq.
     *   'Depth error offset') .or. (nspx .eq. 4 .and.
     *   ctext(1:4) .eq. 'beta') ) then
         itype=2
        elseif ( (nspx .eq. 12 .and. (ctext(1:12) .eq.
     *   'Thermal Bias' .or. ctext(1:12) .eq.
     *   'Thermal bias')) .or. (nspx .eq. 7 .and.
     *    ctext(1:7) .eq. 'delta T') .or.
     *    nspx .eq. 6 .and. ctext(1:6) .eq. 
     *    't_bias') then
         itype=3
        endif

c       if ( itype .ne. itype0 )
c    *   call arrayinit(iyearcount,1,maxyear)
        itype0=itype


c     Year
        read(text(icomma(2,1):icomma(2,1)+icomma(2,2)-1),*
     *   ) xyear
        nyear=xyear
        if ( iyearmax .lt. nyear) iyearmax=nyear
        if ( iyearmin .gt. nyear) iyearmin=nyear
c       if ( nyear .eq. 1995 )
c    *  write(6,*) 'ny',itype,iyearcount(nyear,itype)

        iyearcount(nyear,itype)=iyearcount(nyear,itype)+1
c       iyearcount(nyear+1)=iyearcount(nyear+1)+1
c       iyearcount(nyear+2)=iyearcount(nyear+2)+1
        iyc=iyearcount(nyear,itype)

c     Probe type
        if ( iterat .lt. 3 ) then 
         read(text(icomma(3,1):icomma(3,1)+icomma(3,2)-1),*)
     *    nprobe
         xprobe=nprobe
        else
         cprobe=text(icomma(3,1):icomma(3,1)+icomma(3,2)-1)
         call getxcowl(icomma(3,2),cprobe,iwodprobe)
        endif

c       write(6,*) nyear,xvalue,xsd,iwodprobe
        if ( itype .gt. 0 ) then
c        do 35 ny=nyear,nyear+2
         do 35 ny=nyear,nyear
          xoutput(ny,iyc,itype)=xvalue 
          xoutsd(ny,iyc,itype)=xsd
          iprobetype(ny,iyc)=iwodprobe
35       continue
        endif

50     continue 
4      continue

       close(9)
       do 555 n2=iyearmin,iyearmax
        iyearcount(n2,0)=iyearcount(n2,1)
        do 556 n3=2,3
556      if ( iyearcount(n2,n3) .gt. iyearcount(n2,0) )
     *        iyearcount(n2,0)=iyearcount(n2,n3)
555    continue

      endif

c     Determine year and probe type

      if ( itsprobe .ne. 2 ) return

c      Determine shallow or deep

      if ( numlevels .le. maxlevel ) then
       dpt=depth(numlevels)
      else
       call overmax(maxlevel,numsec,numlevels,0,ic,np)
       dpt=temp(ic,np)
      endif

      call xbtshallowdeep(ishallow,ixbttype,dpt,550.,iplat)
c     call xbtshallowdeep(ishallow,ixbttype,xdepth)

c     Do not adjust if ishallow=-1 (different probe types)

      if ( ishallow .eq. -1 ) return

c      Check if this is a TSK

      itsk=istsk(ixbttype)
c     write(6,*) 'itsk',itsk,ixbttype

      ifound=0
      xa=0.
      xc=0.
      tb=0.

      iyear=iyear0
      if ( iyear .lt. iyearmin ) iyear=iyearmin
      if ( iyear .gt. iyearmax ) iyear=iyearmax

      do 55 n=1,iyearcount(iyear,0)

       iput=0
c      write(6,*) 'iput',n,ixbttype,iprobetype(iyear,n),
c    * iyearcount(iyear,0),iyear
       if ( ixbttype .eq. iprobetype(iyear,n) ) then
        ifound=2
        iput=1
c    Special case: TSK DB same eq. for TSK T7
       elseif ( iprobetype(iyear,n) .eq. ideepprobetsk
     * .and. itsk .gt. 0 .and. ixbttype .eq. 232 ) then
        ifound=2
        iput=1
       elseif ( ifound .lt. 2 ) then 

        iput=1
        if ( ishallow .eq. 1 .and. iprobetype(iyear,n)
     *       .eq. ishallowprobe ) then
         ifound=2
        elseif ( ishallow .eq. 0 .and. iprobetype(iyear,n)
     *   .eq. ideepprobe ) then
         ifound=2
        elseif ( ifound .gt. 0 ) then
         iput=0
        endif

        if ( ifound .eq. 0 ) ifound=1
         
       endif
      
c      write(6,*) 'n',n,iput,xoutput(iyear,n,1),
c    *  xoutput(iyear,n,2),xoutput(iyear,n,3),
c    * iyear,ishallow,
c    * ixbttype,iprobetype(iyear,n)
       if ( iput .eq. 1 ) then
        xa=xoutput(iyear,n,1)
        xc=xoutput(iyear,n,2)
        tb=xoutput(iyear,n,3)
       endif

55    continue

c     make depth/temperature corrections

      do 80 n=1,numlevels

       if ( n .le. maxlevel ) then
c       if ( iyear .eq. 1986  )
c    *   write(98,*) depth(n),depth(n)*(1.-xa)-xc,
c    *   temp(n,1),temp(n,1)-tb,xa,xc,tb
        depth(n)=depth(n)*(1.-xa)-xc
        temp(n,1)=temp(n,1)-tb
       else
        call overmax(maxlevel,numsec,n,0,ic,np)
        temp(ic,np)=(temp(ic,np)*(1-xa))-xc
        temp(ic,np+1)=temp(ic,np+1)-tb
       endif

80    continue

      return
      end

      SUBROUTINE GETXCOWL(nsp0,cinput,icodeout)

C    GETCOWL GETS PROBE TYPE FROM LIST OF KNOWN STRINGS

      parameter (maxdescriptor=500,icmax=15)
      character*7 firsttime
      character*80 filename
      character*150 cdescriptor(maxdescriptor)
      character*150 cunknown(maxdescriptor)
      character*150 crecord
      character*(*) cinput

      dimension icode(maxdescriptor)
      dimension ispaces(maxdescriptor)
      dimension ispacesunk(maxdescriptor)
      dimension icomma(icmax,2)

      save firsttime,cdescriptor,cunknown
      save icode,ndescriptor,nunknown,ispaces,
     * ispacesunk

      if ( firsttime .ne. 'getcowl' ) then
       firsttime='getcowl'
        call extraname('sys.inf'//CHAR(0),
     * 'cowleyprobe.txt'//CHAR(0),
     *  filename)

       open(10,file=filename,status='old')

       ndescriptor=0
       nunknown=0

       do 50 n=1,maxdescriptor

        call clearstring(crecord,150)
        icode(ndescriptor+1)=0

        read(10,'(a)',end=4) crecord
        call findlastchar(iend,crecord,150)
        call commafindx(iend,icmax,ncomma,icomma,crecord)
        call clearstring(cdescriptor(ndescriptor+1),50)

        if ( icomma(1,2) .gt. 0 ) then
         ndescriptor=ndescriptor+1
         cdescriptor(ndescriptor)=
     *    crecord(icomma(1,1):icomma(1,1)+icomma(1,2)-1)
         ispaces(ndescriptor)=icomma(1,2)

         if ( ncomma .ge. 2 .and. icomma(2,2) .gt. 0 ) then
          read(crecord(icomma(2,1):icomma(2,1)+icomma(2,2)-1),*)
     *     icode(ndescriptor)
         endif

        endif

50     continue
4      continue

       close(10)

      endif

      isigx=0
      ifound=0

      call spacefix(cinput,nsp0,nsps,nspf,nsp)
      do 75 n=1,ndescriptor

       if ( nsp .eq. ispaces(n) .and. cinput(nsps:nspf) .eq.
     *      cdescriptor(n)(1:nsp) ) then
        icodeout=icode(n)
        return
       endif
75    continue

      if ( ifound .eq. 0 ) then
       do 85 n=1,nunknown
        if ( nsp .eq. ispacesunk(n) .and.
     *       cinput(nsps:nspf) .eq. cunknown(n)(1:nsp) ) then
         return
        endif
85     continue
       write(6,*) 'unidentified code:',cinput(nsps:nsp)
     * ,":"
       nunknown=nunknown+1
       ispacesunk(nunknown)=nsp
       call clearstring(cunknown(nunknown),150)
       cunknown(nunknown)(1:nsp)=cinput(nsps:nspf)

      endif

      return
      end

      SUBROUTINE XBTBIASgood(itsprobe,depth,temp,maxlevel,
     * maxcalc,numsec,numlevels,iyearx,ixprobe,bmiss,ifix)

C     XBTBIASgood CORRECTS XBT BIAS BASED ON INFORMATION FROM
C     GOOD 2010  THE CORRECTIONS ARE MADE BEFORE
C     INTERPOLATION TO STANDARD LEVELS

      parameter (maxyear=3000,maxset=40,nt4=4,n7db=8)
      parameter (maxdepth=3000,ntno=7,nt10=3)
      character*7 firsttime
      character*80 filename,text
      dimension depth(maxlevel),temp(maxlevel,maxcalc)
      dimension zstretch(maxdepth,4)
      dimension itype4(nt4),itype7db(n7db)
      dimension itypeno(ntno),itype10(nt10)

      data itype4 /202,208,215,223/
      data itype7db /201,207,214,217,227,228,232,235/
      data itypeno /234,233,219,210,204,224,225/
      data itype10 /205,211,220/

      save firsttime
      save zstretch,iyearmin,iyearmax

      if ( firsttime .ne. 'xbtbias' ) then
       firsttime = 'xbtbias'
       iyearmin=5000
       iyearmax=0

       call clearstring(filename,80)
       call extraname('sys.inf'//CHAR(0),
     *  'good_corrections_xbt.dat'//CHAR(0),filename)

       open(9,file=filename,status='old')
       read(9,'(a)') text

       do 55 i=1,maxyear

        read(9,*,end=44) iyear,xt4,xt7,xt10,xunk
c       write(6,*) 'iyear',xt4,xt7,xt10,xunk
        zstretch(iyear,1)=xt4
        zstretch(iyear,2)=xt7
        zstretch(iyear,3)=xt10
        zstretch(iyear,4)=xunk

         if ( iyear .lt. iyearmin ) iyearmin=iyear
         if ( iyear .gt. iyearmax ) iyearmax=iyear

55     continue
44     continue
       close(9)

      endif
    
      iyear=iyearx
      if ( iyearx .lt. iyearmin ) iyear=iyearmin
      if ( iyearx .gt. iyearmax ) iyear=iyearmax
c       write(6,*) 'ixprobe',ixprobe,iyearx

c    See which type of XBT this is (T4/T6, T7/DB, or
c    other type.  Other type not corrected)

       ixbt=4
       ifix=0
      if ( itsprobe .eq. 2 ) then

       if ( ixprobe .ne. 2 .and. ixprobe .ne. 0 ) then
        do 150 nn=1,nt4
150      if ( ixprobe .eq. itype4(nn) ) ixbt=1
        do 155 nn=1,n7db
155      if ( ixprobe .eq. itype7db(nn) ) ixbt=2
        do 160 nn=1,nt10
160      if ( ixprobe .eq. itype10(nn) ) ixbt=3
        do 165 nn=1,ntno
165      if ( ixprobe .eq. itypeno(nn) ) ixbt=-1
c       write(6,*) 'itype',ixprobe,ixbt
        if ( ixbt .eq. -1 ) return
       endif

      ifix=1

c      calculate final depth

       do 200 k=1,numlevels
        depth(k)=depth(k)*zstretch(iyear,ixbt)
c       write(6,*) 'new z',k,iyear,depth(k),zstretch(k,ixbt)

200    continue

      endif

      return
      end
       SUBROUTINE XBTBIASgourt12(itsprobe,depth,temp,maxlevel,
     * maxcalc,numsec,numlevels,iyearx,ixprobe,bmiss,ifix,iplat)
      parameter (maxyear=3000,maxset=40,nt4=8,n7db=8)
      parameter (maxdepth=3000)
      parameter (ntno=7,nt10=4)
      parameter (icmax=13)
      character*14 firsttime
      character*80 filename,text

      dimension icomma(icmax,2)
      dimension depth(maxlevel),temp(maxlevel,maxcalc)
      dimension itype4(nt4),itype7db(n7db)
      dimension itypeno(ntno),itype10(nt10)
      dimension doff(maxdepth,4)
      dimension slope(maxdepth,4)
      dimension tbias(maxdepth,4)

      data itype10 /205,211,220,229/
      data itype4 /202,203,208,209,215,216,223,224/
      data itype7db /201,207,214,217,227,228,231,235/
      data itypeno /234,233,219,210,204,224,225/

      save firsttime
      save doff,slope,tbias,iyearmin,iyearmax

      if  (firsttime .ne. 'XBTBIASgourt12' ) then
       firsttime='XBTBIASgourt12'

c     read in bias corrections

      call clearstring(text,80)
      call extraname('sys.inf'//CHAR(0),
     *  'gouretski_2012.dat'//CHAR(0), filename)

      open(9,file=filename,status='old')

c      read in headers
      
      read(9,'(a)') text
      read(9,'(a)') text
       iyearmin=5000
       iyearmax=0

       do 50 i=1,maxyear
       	
      read(9,'(a)',end=44) text
c      write(9,*) text
      call findlastchar(nsp,text,80)
  
      call commafindx(nsp,icmax,ncomma,icomma,text)
      read(text(icomma(1,1):icomma(1,1)+icomma(1,2)-1),*)
     * iyear

      if ( iyear .lt. iyearmin ) iyearmin=iyear
      if ( iyear .gt. iyearmax ) iyearmax=iyear

c for T10
      call checkifallspace(text,icomma(2,1),icomma(2,2),ispace)
      if ( ispace .eq. 0 ) then
       read(text(icomma(2,1):icomma(2,1)+icomma(2,2)-1),*)
     *  doff(iyear,1)
       read(text(icomma(3,1):icomma(3,1)+icomma(3,2)-1),*)
     *  slope(iyear,1)
       read(text(icomma(4,1):icomma(4,1)+icomma(4,2)-1),*)
     *  tbias(iyear,1)
      endif

c for T4 
      call checkifallspace(text,icomma(5,1),icomma(5,2),ispace)
      if ( ispace .eq. 0 ) then
       read(text(icomma(5,1):icomma(5,1)+icomma(5,2)-1),*)
     *  doff(iyear,2)
       read(text(icomma(6,1):icomma(6,1)+icomma(6,2)-1),*)
     *  slope(iyear,2)
       read(text(icomma(7,1):icomma(7,1)+icomma(7,2)-1),*)
     *  tbias(iyear,2)
      endif

c for SX 
      call checkifallspace(text,icomma(8,1),icomma(8,2),ispace)
      if ( ispace .eq. 0 ) then
       read(text(icomma(8,1):icomma(8,1)+icomma(8,2)-1),*)
     *  doff(iyear,3)
       read(text(icomma(9,1):icomma(9,1)+icomma(9,2)-1),*)
     *  slope(iyear,3)
       read(text(icomma(10,1):icomma(10,1)+icomma(10,2)-1),*)
     *  tbias(iyear,3)
      endif

c for T7 
      call checkifallspace(text,icomma(11,1),icomma(11,2),ispace)
      if ( ispace .eq. 0 ) then
       read(text(icomma(11,1):icomma(11,1)+icomma(11,2)-1),*)
     *  doff(iyear,4)
       read(text(icomma(12,1):icomma(12,1)+icomma(12,2)-1),*)
     *  slope(iyear,4)
       read(text(icomma(13,1):icomma(13,1)+icomma(13,2)-1),*)
     *  tbias(iyear,4)
      endif

c       write(6,*) iyear,doff,slope,tbias
c       write(6,*) iyear,doff(iyear,1),slope(iyear,1),tbias(iyear,1),
c     * doff(iyear,2),slope(iyear,2),tbias(iyear,2),
c     * doff(iyear,3),slope(iyear,3),tbias(iyear,3),
c     * doff(iyear,4),slope(iyear,4),tbias(iyear,4)       

c      call clearstring(text,80)

50       continue
44       continue
       close(9)

       endif

       ntyp=0
       ifix=0
c      Determine shallow or deep
       
      if (numlevels .le. maxlevel) then
        dpt =depth(numlevels)
      else
        call overmax(maxlevel,numsec,numlevels,0,ic,np)
        dpt=temp(ic,np)
      endif
       
        shalmax=550 
        call xbtshallowdeep(ishallow,ixprobe,dpt,shalmax,iplat)
c        ixprobe=ixbttype
c      if ( ishallow .eq. -1) return
        if ( dpt .gt. 960.) return

      iyear=iyearx
      if ( iyearx .lt. iyearmin ) iyear=iyearmin
      if ( iyearx .gt. iyearmax ) iyear=iyearmax


       if ( itsprobe .eq. 2 ) then
       if ( ixprobe .ne. 2 .and. ixprobe .ne. 0 ) then

c      write(6,*) 'ixprobe',ixprobe,iyearx

      do 700 nn=1,n7db
700       if ( ixprobe .eq. itype7db(nn) ) ntyp=4

      do 701 nn=1,nt4
701       if ( ixprobe .eq. itype4(nn) ) ntyp=2

      do 702 nn=1,nt10
702       if ( ixprobe .eq. itype10(nn) ) ntyp=1

      do 703 nn=1,ntno
703       if ( ixprobe .eq. itypeno(nn) ) ntyp=0
       endif

      if (ntyp .eq. 0) then
      if (ishallow .eq. 1) ntyp=3
      if (ishallow .eq. 0) ntyp=4

      endif 
     
      ifix=1

      do 200 k=1,numlevels
       depth(k)=depth(k)+(doff(iyear,ntyp)+
     *  slope(iyear,ntyp)*depth(k))
       temp(k,1)=temp(k,1)-tbias(iyear,ntyp)
200      continue
      endif

      return
      end

      SUBROUTINE XBTbiashamon(itsprobe,depth,temp,maxlevel,maxcalc,
     *numsec,numlevels,iyearx,ixprobe,rlat,rlon,bmiss,ifix,iplat)

c     XBTbiasHamon corrects XBT bias based on information from
c     Hamon et al. The corrections are made before interpolation
c     to standard levels

      parameter (maxyear=3000,maxset=40)
      parameter (ntmax=6)
      parameter (n7db=8,n46=8,ntno=7,nt0=1)
      character*14 firsttime
      dimension depth(maxlevel),temp(maxlevel,maxcalc)
      dimension doffDA(maxyear,ntmax),doffDB(maxyear,ntmax)
      dimension doffZD(maxyear,ntmax)
      dimension toff(maxyear,ntmax)
      dimension itype7db(n7db),itype46(n46)
      dimension itypeno(ntno)
      data itype46 /202,203,208,209,215,216,223,226/
      data itype7db /201,207,214,217,227,228,232,235/
      data itypeno /234,233,224,225,205,211,220/
c      data itype0 /2/
      save firsttime
      save toff,doffDA,doffDB,doffZD,nyearmin,nyearmax,
     * myearmin,myearmax

      if ( firsttime .ne. 'XBTbiashamon' ) then
       firsttime = 'XBTbiashamon'
c read in corrections
       call readhamontable1(maxyear,ntyp,toff)
       call readhamontable2(maxyear,ntyp,doffDA,doffDB,doffZD,
     *  nyearmin,nyearmax)
       call readhamontable3(maxyear,ntyp,doffDA,doffDB,doffZD,
     *  nyearmin,nyearmax)
       call readhamontable4(maxyear,ntyp,doffDA,doffDB,doffZD,
     *  myearmin,myearmax)
       endif
       ntyp=0
       ifix=0
      if ( numlevels .le. maxlevel ) then
       dpt=depth(numlevels)
      else
       call overmax(maxlevel,numsec,numlevels,0,ic,np)
      dpt=temp(ic,np)
      endif
      shalmax=500.
      call xbtshallowdeep(ishallow,ixprobe,dpt,shalmax,iplat)
c     write(6,*) 'ishallow:',ishallow 
      if (ishallow .eq. -1) return      
  
      call xbtwestpacocean(iwestpacific,rlat,rlon)
c      write(6,*) 'rlat,rlon',rlat,rlon
c     write(6,*) 'iwestpacific:', iwestpacific,depth(110)

      call hamon_mbtxbtmean(itsprobe,temp, maxlevel,maxcalc,iwarm,
     *  numlevels,bmiss,depth,nbinmax,xmeanall)      
c     write(6,*) 'iwarm:', iwarm
          iyear=iyearx
      if (iyearx .lt. nyearmin ) iyear=nyearmin
      if (iyearx .gt. nyearmax ) iyear=nyearmax
c       write(6,*) 'nyearmin, nyearmax', nyearmin , nyearmax

      if (iyearx .gt. 1985) then
       iwestpacific = 0
      endif
c     write(6,*) 'iyear,iwestpacific:',iyear, iwestpacific
         if (itsprobe .eq. 2.) then
c       write(6,*) 'itsprobe', itsprobe
c      write(6,*) 'iyear',iyear,ixprobe
        if (ixprobe .eq. 2. ) then
         ntyp=0
       if (ntyp .eq. 0) then
         if (ishallow .eq. 0 .and. iwestpacific .eq. 0 .and.
     *       iwarm .eq. 0) ntyp=1
         if (ishallow .eq. 0 .and. iwestpacific .eq. 0 .and.
     *        iwarm .eq. 1) ntyp=2
         if (ishallow .eq. 0 .and. iwestpacific .eq. 1) 
     *                      ntyp=5

         if (ishallow .eq. 1 .and. iwestpacific .eq. 0 .and.
     *        iwarm .eq. 0) ntyp=3
         if (ishallow .eq. 1 .and. iwestpacific .eq. 0 .and.
     *        iwarm .eq. 1) ntyp=4

         if (ishallow .eq. 1 .and. iwestpacific .eq. 1) 
     *                      ntyp=6
       endif

         elseif (ixprobe .ne. 2.  .and. ixprobe .ne. 0.) then

       do 701 nn=1,n46
701     if ( ixprobe .eq. itype46(nn) ) ntyp=7
       do 702 nn=1,n7db
702     if ( ixprobe .eq. itype7db(nn) ) ntyp=8
       do 703 nn=1,ntno
703     if ( ixprobe .eq. itypeno(nn) ) ntyp=-1
         if (ntyp .eq. -1) return

c       write(6,*) iyear,ntyp 
        if (ntyp .eq. 7) then
         if (iwestpacific .eq. 0 .and. iwarm .eq. 0) ntyp=3 
         if (iwestpacific .eq. 0 .and. iwarm .eq. 1) ntyp=4
         if (iwestpacific .eq. 1) ntyp=6
       endif
        if (ntyp .eq. 8) then
        
         if (iwestpacific .eq. 0 .and. iwarm .eq. 0) ntyp=1 
         if (iwestpacific .eq. 0 .and. iwarm .eq. 1) ntyp=2
        if (iwestpacific .eq. 1) ntyp=5
       endif
        endif
        endif

       ifix=1
      do 200 k=1, numlevels
c       write(6,*) 'depth', depth(k)
       depth(k) = depth(k)*(1. -doffDB(iyear,ntyp)-
     *  (doffDA(iyear,ntyp)*depth(k)))-(doffZD(iyear,ntyp))
       temp(k,1) = temp(k,1)-toff(iyear,ntyp)
c       write(6,*) 'depth', depth(k)
200   continue
c      write(6,*) 'iyear,ntyp', iyear,ntyp
c      write(6,*)'doffDA,doffDB,doffZD,toff',doffDA(iyear,ntyp),
c    * doffDB(iyear,ntyp),doffZD(iyear,ntyp),toff(iyear,ntyp)


      return
      end



      SUBROUTINE XBTBIASish(itsprobe,ixprobe,depth,temp,maxlevel,
     * maxcalc,numsec,numlevels,iyearx,monthx,ifix)

C     XBTBIASish CORRECTS XBT BIAS BASED ON INFORMATION FROM
C     ISHII et al.  THE CORRECTIONS ARE MADE BEFORE
C     INTERPOLATION TO STANDARD LEVELS

C     IFIX=0 IF NO CORRECTION APPLIED
C     IFIX=1 IF CORRECTION APPLIED

      parameter (maxyear=3000,maxtype=1000)
      parameter (numtype=12)
      character*7 firsttime
      character*80 filename,text
      dimension depth(maxlevel),temp(maxlevel,maxcalc)
      dimension xcorr(maxyear,12,numtype),xcorrin(numtype)
      dimension xcorrdiff(numtype),icolumntype(0:maxtype)

      save firsttime
      save xcorr,iyearmin,iyearmax,icolumntype

      if ( firsttime .ne. 'xbtbias' ) then
       firsttime = 'xbtbias'
       call clearstring(filename,80)
       call extraname('sys.inf'//CHAR(0),
     *  'ishii_biascorrect.txt'//CHAR(0),filename)
       open(9,file=filename,status='old')

       iyearmin=5000
       iyearmax=0
       inumset=0
       read(9,'(a)') text
       do 55 n=1,maxyear

        read(9,*,end=44) iyear,(xcorrin(i),i=1,numtype)

        inumset=inumset+1
        do 56 ix=1,numtype
56       xcorr(iyear,6,ix)=xcorrin(ix)
        if ( iyear .lt. iyearmin ) iyearmin=iyear
        if ( iyear .gt. iyearmax ) iyearmax=iyear

55     continue
44     continue
       close(9)

       do 60 iy=iyearmin,iyearmax-1
        do 61 n=1,numtype
61      xcorrdiff(n)=(xcorr(iy+1,6,n)-xcorr(iy,6,n))/12.
    
        do 65 mon=1,6
         xmon0=mon
         mon0=mon+6
         xmon=mon+6
    
         do 66 n=1,numtype
          xcorr(iy,mon0,n)=xcorr(iy,6,n)+(xmon0*xcorrdiff(n))
          if ( mon .ne. 6 ) 
     *     xcorr(iy+1,mon,n)=xcorr(iy,6,n)+(xmon*xcorrdiff(n))
c         if ( iy .eq. 1986 .and. n .eq. 11) write(6,*) 'xcorr',iy,
c    *     mon0,n,xmon,xcorrdiff(n),(xmon*xcorrdiff(n)),
c    *     xcorr(iy,6,n),xcorr(iy,mon0,n)
66       continue

65      continue

60     continue

       do 75 mon=7,12
        do 76 n=1,numtype
         xcorr(iyearmax,mon,n)=xcorr(iyearmax,6,n)
         if ( mon .ne. 12 ) 
     *    xcorr(iyearmin,mon-6,n)=xcorr(iyearmin,6,n)
76      continue
75     continue

       call clearstring(filename,80)
       call extraname('sys.inf'//CHAR(0),
     *  'ishii_type.txt'//CHAR(0),filename)
       open(9,file=filename,status='old')

       read(9,'(a)') text
       read(9,'(a)') text

       call arrayinit(icolumntype,0,maxtype)
       do 150 n=1,maxtype
        read(9,*,end=104) intype,inval         
        icolumntype(intype)=inval
150    continue
104    continue
       close(9)
c      write(6,*) 'columntype 213 ',icolumntype(213)
 
      endif

      itype=0
      if ( itsprobe .eq. 2 ) then

       t1=444.444
       t2=2210838.36
       t3=1486.89
c      t1=462.9629
c      t2=2244447.86
c      t3=1498.1481

       itype=icolumntype(ixprobe)
       ifix=0
       if ( itype .eq. 0 ) return
       ifix=1

c      T5 (Sipp or unknown)
       if ( ixprobe .eq. 204 .or. ixprobe .eq. 210. ) then
        t1=549.450523
        t2=3518716.
        t3=1875.82409
c      T10
       elseif ( ixprobe .eq. 205 .or. ixprobe .eq. 211 ) then
        t1=462.962941
        t2=2127411.12
        t3=1458.56475
c      Fast Deep
       elseif ( ixprobe .eq. 213 .or. ixprobe .eq. 236 ) then
        t1=  549.450523
        t2=  3039466.26
        t3=  1743.40651
       endif
 
       iyear=iyearx
       if ( iyearx .lt. iyearmin ) iyear=iyearmin
       if ( iyearx .gt. iyearmax ) iyear=iyearmax

       xbias=xcorr(iyear,monthx,itype)
c      write(6,*) 'xb',iyear,monthx,itype,xbias,ixprobe
c      write(6,*) 'bias:',xcorr(iyear,monthx,itype),itype,iyear,monthx


       do 80 n=1,numlevels

        if ( n .le. maxlevel ) then
c        if ( iyear .eq. 1986 .and. monthx .eq. 8 )
c    *    write(98,*) depth(n),depth(n)*(1.-xbias),xbias
         t0=t3 - sqrt(t2 - (t1*depth(n)))
         depth(n)=depth(n) - (xbias* t0)
c        write(6,*) 'withbias',depth(n),t0,xbias,(xbias*t0)
        else
         call overmax(maxlevel,numsec,n,0,ic,np)
         t0=t3 - sqrt(t2 - (t1*temp(ic,np)))
         temp(ic,np)=temp(ic,np)-(xbias* t0)
        endif

80     continue

      endif

      return
      end
      SUBROUTINE XBTbiaslijing(depth,temp,maxlevel,maxcalc,
     * itsprobe,ixbttype,iyear0,numsec,numlevels,bmiss,
     * xswitch,iplat)

C     XBT BIAS CORRECTION FROM LIJING ET AL. 2011
C     SO FAR THE ONLY PROBE TYPES COVERED ARE
C      2 (xbt4 - 208) [Also 202, 203, 205, 206, 208
C                      209, 211, 212, 215, 216 ]
C     42 (xbt7 - 207) [Also 201, 213, 214, 235, 236,
C                      217, 232]
C    212 (xbt6t - 216)
C    222 (xbt7t - 217) [Also 232 TSK DB]
C    ASSUMPTIONS: 
C     UNKNOWN PROBE TYPE SHALLOW: SAME AS xbt4
C     UNKNOWN PROBE TYPE DEEP: SAME AS xbt7
C     T5 NOT CORRECTED
C     KNOWN PROBES NOT COVERED ABOVE USE
C     SHALLOW/DEEP SAME AS UNKNOWN
C     SHALLOW/DEEP CRITERA SWITCH AT 550 M.

      parameter (ishallowprobe=208,ideepprobe=207)
      parameter (ideepprobetsk=217)
      parameter (icmax=10,maxyear=3000)
      parameter (maxlevelloc=6000)

      character*13 firsttime
      character*30 ctext,cprobe
      character*80 text,filename

      dimension icomma(icmax,2)
      dimension iyearcount(maxyear,0:4)
      dimension xoutput(maxyear,5,4)
      dimension xoutsd(maxyear,5,3)
      dimension iprobetype(maxyear,5)
      dimension depth(maxlevel),temp(maxlevel,maxcalc)
      dimension t0(maxlevelloc)

      common /eachparm/ numeach(6),numtot2,numtot3,ntax,numsecset

      save firsttime
      save xoutput,xoutsd,iprobetype,iyearcount,
     * iyearmin,iyearmax

      if ( firsttime .ne. 'XBTbiaslijing' ) then
       firsttime='XBTbiaslijing'

c     read in bias corrections

       call extraname('sys.inf'//CHAR(0),
     *  'lijing_XBT_corrs.csv'//CHAR(0),
     *  filename)

       open(9,file=filename,status='old')

       read(9,'(a)') text
       iyearmin=maxyear
       iyearmax=0
       itype0=0

       do 50 n=1,maxyear

        call clearstring(text,80)
        read(9,'(a)',end=4) text
        call findlastchar(nsp,text,80)
c       write(6,*) text(1:nsp)

        call commafindx(nsp,icmax,ncomma,icomma,text)

c     value
        ivaluefound=0
        if ( text(icomma(4,1):icomma(4,1)+icomma(4,2)-1)
     *   .ne. 'NaN' ) then 
         read(text(icomma(4,1):icomma(4,1)+icomma(4,2)-1),*)
     *   xvalue
         ivaluefound=1
        endif
        if ( ivaluefound .eq. 0 ) goto 50

c     standard deviation
        if ( text(icomma(5,1):icomma(5,1)+icomma(5,2)-1)
     *   .ne. 'NaN' ) then 
         read(text(icomma(5,1):icomma(5,1)+icomma(5,2)-1),*)
     *    xsd
        endif

        call clearstring(ctext,30)
        ctext(1:icomma(1,2))=
     *   text(icomma(1,1):icomma(1,1)+icomma(1,2)-1)
        nspx=icomma(1,2)
        itype=0
        if ( nspx .eq. 1 .and. ctext(1:1) .eq.
     *   'a' ) then
         itype=1
        elseif ( nspx .eq. 1 .and. ctext(1:1) .eq.
     *   'b' ) then
         itype=2
        elseif ( (nspx .eq. 6 .and. ctext(1:6) .eq.
     *   'offset') .or. (nspx .eq. 1 .and.
     *   ctext(1:1) .eq. 'c' ) ) then
         itype=3
        elseif ( (nspx .eq. 12 .and. ctext(1:12) .eq.
     *   'thermal bias') .or. (nspx .eq. 7 .and.
     *    ctext(1:7) .eq. 'delta T')  ) then
         itype=4
        endif

c       if ( itype .ne. itype0 )
c    *   call arrayinit(iyearcount,1,maxyear)
        itype0=itype


c     Year
        read(text(icomma(2,1):icomma(2,1)+icomma(2,2)-1),*
     *   ) xyear
        nyear=xyear
        if ( iyearmax .lt. nyear) iyearmax=nyear
        if ( iyearmin .gt. nyear) iyearmin=nyear
c       if ( nyear .eq. 1976 ) write(6,*) 'n',itype,iyearcount(nyear)

        iyearcount(nyear,itype)=iyearcount(nyear,itype)+1
c       iyearcount(nyear+1)=iyearcount(nyear+1)+1
c       iyearcount(nyear+2)=iyearcount(nyear+2)+1
        iyc=iyearcount(nyear,itype)

c     Probe type
        cprobe=text(icomma(3,1):icomma(3,1)+icomma(3,2)-1)
c       getxcowl is in subroutine XBTbiascowlX.f
        call getxcowl(icomma(3,2),cprobe,iwodprobe)

c       write(6,*) nyear,xvalue,xsd,iwodprobe
        if ( itype .gt. 0 ) then
c        do 35 ny=nyear,nyear+2
         do 35 ny=nyear,nyear
          xoutput(ny,iyc,itype)=xvalue 
          xoutsd(ny,iyc,itype)=xsd
          iprobetype(ny,iyc)=iwodprobe
35       continue
        endif

50     continue 
4      continue

       close(9)
       do 555 n2=iyearmin,iyearmax
        iyearcount(n2,0)=iyearcount(n2,1)
        do 556 n3=2,3
556      if ( iyearcount(n2,n3) .gt. iyearcount(n2,0) )
     *        iyearcount(n2,0)=iyearcount(n2,n3)
555    continue

      endif

c     Determine year and probe type

      if ( itsprobe .ne. 2 ) return

c      Determine shallow or deep

      if ( numlevels .le. maxlevel ) then
       dpt=depth(numlevels)
      else
       call overmax(maxlevel,numsec,numlevels,0,ic,np)
       dpt=temp(ic,np)
      endif

      call xbtshallowdeep(ishallow,ixbttype,dpt,550.,iplat)
c     write(6,*) 'shallow',ishallow
c     call xbtshallowdeep(ishallow,ixbttype,xdepth)

c     Do not adjust if ishallow=-1 (different probe types)

      if ( ishallow .eq. -1 ) return

c      Check if this is a TSK

      itsk=istsk(ixbttype)

      ifound=0
      xa=0.
      xb=0.
      xc=0.
      tb=0.

      iyear=iyear0
      if ( iyear .lt. iyearmin ) iyear=iyearmin
      if ( iyear .gt. iyearmax ) iyear=iyearmax

      do 55 n=1,iyearcount(iyear,0)

       iput=0
       if ( ixbttype .eq. iprobetype(iyear,n) ) then
        ifound=2
        iput=1
c    Special case: TSK DB same eq. for TSK T7
       elseif ( iprobetype(iyear,n) .eq. ideepprobetsk
     * .and. itsk .gt. 0 .and. ixbttype .eq. 232 ) then
        ifound=2
        iput=1
       elseif ( ifound .lt. 2 ) then 

        iput=1
        if ( ishallow .eq. 1 .and. iprobetype(iyear,n)
     *       .eq. ishallowprobe ) then
         ifound=2
        elseif ( ishallow .eq. 0 .and. iprobetype(iyear,n)
     *   .eq. ideepprobe ) then
         ifound=2
        elseif ( ifound .gt. 0 ) then
         iput=0
        endif

        if ( ifound .eq. 0 ) ifound=1
         
       endif
      
c      write(6,*) 'n',n,iput,xoutput(iyear,n,1),
c    *  xoutput(iyear,n,2),xoutput(iyear,n,3),
c    * iyear,ishallow,
c    * ixbttype,iprobetype(iyear,n)
       if ( iput .eq. 1 ) then
        xa=xoutput(iyear,n,1)
        xb=xoutput(iyear,n,2)
        xc=xoutput(iyear,n,3)
        tb=xoutput(iyear,n,4)
       endif

55    continue

c     make depth/temperature corrections

      if ( xswitch .eq. 1. ) then
       ihanawa=1
      else
       ihanawa=0
      endif

c     write(6,*) 't0',ihanawa,xa,xb,xc,tb
      call timefromdepth(numlevels,t0,maxlevel,ihanawa,depth)
c     write(6,*) 'tfromd',numlevels,t0(numlevels)
      call droprate_apply(xa,xb,numlevels,depth,maxlevel,t0)

      do 80 n=1,numlevels

       if ( n .le. maxlevel ) then
        depth(n)=depth(n)-xc
        temp(n,1)=temp(n,1)-tb
       else
        call overmax(maxlevel,numsec,n,0,ic,np)
        temp(ic,np)=temp(ic,np)-xc
        temp(ic,np+1)=temp(ic,np+1)-tb
       endif

80    continue

      return
      end
      SUBROUTINE XBTbiaslijing2(depth,temp,maxlevel,maxcalc,
     * itsprobe,ixbttype,iyear0,numsec,numlevels,bmiss,iwrite,
     * ifix, xswitch,iplat)

      parameter (maxyear=3000,ntmax=9)
      parameter (maxlevelloc=6000)
      parameter (n46=8,n7db=8,nfd=2,n10=3,n5=3,n11=2)
      parameter (a_h95=6.691, b_h95=0.00225)
      parameter (a_t5=6.828, b_t5=0.00182)
      parameter (a_t10=6.301,b_t10=0.00216)

      character*14 firsttime

      dimension tbias1(maxyear,ntmax)
      dimension acorr1(maxyear,ntmax)
      dimension depth(maxlevel),temp(maxlevel,maxcalc)
      dimension t0(maxlevelloc),d1(maxlevelloc)

      dimension a1(ntmax),a2(ntmax)
      dimension b1(ntmax),b2(ntmax)
      dimension at1(ntmax),tta(ntmax)
      dimension ttb(ntmax)

      dimension itype46(n46),itype7db(n7db),itypefd(nfd)
      dimension itype10(n10),itype5(n5),itype11(n11)

      data itype46 /202,203,208,209,215,216,223,226/
      data itype7db /201,207,214,217,227,228,232,235/
      data itypefd /213,236/
      data itype11 /206,212/
      data itype10 /205,211,220/
      data itype5 /204,210,219/

      common /eachparm/ numeach(6),numtot2,numtot3,ntax,numsecset

      save firsttime
      save tbias1,acorr1,nyearmin,
     * nyearmax,a1,a2,b1,b2,at1,tta,ttb

      if ( firsttime .ne. 'XBTbiaslijing2' ) then
       firsttime='XBTbiaslijing2'

c     read in corrections
       call readlijingtable_coeff(ntmax,a1,a2,b1,b2,at1,tta,ttb)
       call readlijingtable1(maxyear,ntmax,acorr1,nyearmin,
     *  nyearmax)
       call readlijingtable2(maxyear,ntmax,tbias1)
      endif

c     Determine probe type

      ifix=0
      if ( itsprobe .ne. 2 ) return

c      ntyp is class of XBT for correction
      ntyp=0

c   ntyp definitions
c    1: T7/DB
c    2: unk_deep
c    3: T4/T6
c    4: unk_shallow
c    5: T10
c    6: T5
c    7: TSK T4/T6
c    8: TSK T5
c    9: TSK T7

c      Determine shallow or deep

      if ( numlevels .le. maxlevel ) then
       dpt=depth(numlevels)
      else
       call overmax(maxlevel,numsec,numlevels,0,ic,np)
       dpt=temp(ic,np)
      endif

      call xbtshallowdeep(ishallow,ixbttype,dpt,550.,iplat)
c     write(6,*) 'xbtshall',ixbttype,iplat,ishallow

c     Do not adjust if ishallow=-1 (different probe types)


      ihanawa=-1

      do 704 nn=1,n5
       if ( itype5(nn) .eq. ixbttype) then
        ntyp=6
        ihanawa=6
       endif
704   continue

      if ( ishallow .eq. -1 .and. ntyp .ne. 6) return
      ifix=1

c      Check if this is a TSK

      itsk=istsk(ixbttype)

c      identify XBT class for correction

      do 700 nn=1,n7db
700    if ( itype7db(nn) .eq. ixbttype) ntyp=1

      do 701 nn=1,n46
701    if ( itype46(nn) .eq. ixbttype) ntyp=3

c    fast deep now part of unknown
      do 702 nn=1,nfd
       if ( itypefd(nn) .eq. ixbttype) then
        ntyp=0
c       ihanawa=3
c     if depth > 930 m treat as T5, otherwise as unknown
        if ( dpt .ge. 930. ) ihanawa=6
       endif
702   continue

      do 703 nn=1,n10
       if ( itype10(nn) .eq. ixbttype) then
        ntyp=5
        ihanawa=5
       endif
703   continue

      do 705 nn=1,n11
       if ( itype11(nn) .eq. ixbttype) then
        ntyp=0
c       ihanawa=4
       endif
705   continue
 
      if ( ntyp .eq. 0 ) then
       if ( ishallow .eq. 1 ) ntyp=4
       if ( ishallow .eq. 0 ) ntyp=2
      elseif ( itsk .ne. 0 ) then

       if ( ntyp .eq. 1 ) ntyp=9
       if ( ntyp .eq. 3 ) ntyp=7
       if ( ntyp .eq. 6 ) ntyp=8

      endif

c     get mean temperature 0-100m, full profile

      call lijing2_meant(ishallow,temp,maxlevel,maxcalc,
     * numlevels,bmiss,depth,nbinmax,xmeanall,xmeans)

      iyear=iyear0
      if ( iyear .lt. nyearmin ) iyear=nyearmin
      if ( iyear .gt. nyearmax ) iyear=nyearmax

      afull=a_h95
      bfull=b_h95

c    ihanawa=1 needs
      if ( ihanawa .eq. -1 ) then
       if ( xswitch .eq. 1. ) then
        ihanawa=1
       else
        ihanawa=0
       endif
      endif

      if ( ntyp .eq. 6 .or. ntyp .eq. 8 ) then  
       afull=a_t5
       bfull=b_t5
      elseif ( ntyp .eq. 5 ) then
       afull=a_t10
       bfull=b_t10
      endif

      xa=(afull+acorr1(iyear,ntyp))+(xmeans*at1(ntyp))
      xb=(xa*a1(ntyp)) - a2(ntyp)
      xc=(xa*b1(ntyp)) - b2(ntyp)
c     Change: Jul 3, 2017: temp_original instead of
c     xmeanall is used.  Calculation done below
c     tb=tbias1(iyear,ntyp)+((xmeanall*tta(ntyp))+ttb(ntyp))
c     if ( iwrite .eq. 1 ) 
c     write(6,*) 'bias',iyear,ixbttype,ntyp,xa,xb,xc,tb
c     write(6,*) 'xm',xmeanall,xmeans,acorr1(iyear,ntyp),
c    * tta(ntyp),a1(ntyp),a2(ntyp),b1(ntyp),b2(ntyp),
c    * tbias1(iyear,ntyp),ttb(ntyp),at1(ntyp)
c     write(6,*) 'xsw',xsw

c     make depth/temperature corrections

      call timefromdepth(numlevels,t0,maxlevel,ihanawa,depth)
      call droprate_apply(xa,xb,numlevels,d1,maxlevel,t0)
c     write(6,*) 'H95',t0(14),xa,xb,xc,d1(14),d1(14)-xc

      do 80 n=1,numlevels

       if ( n .le. maxlevel ) then
        depth(n)=d1(n)-xc
        tb=tbias1(iyear,ntyp)+((temp(n,1)*tta(ntyp))+ttb(ntyp))
        temp(n,1)=temp(n,1)-tb
       else
        call overmax(maxlevel,numsec,n,0,ic,np)
        temp(ic,np)=temp(ic,np)+d1(n)-xc
        tb=tbias1(iyear,ntyp)+((temp(ic,np+1)*tta(ntyp))+ttb(ntyp))
        temp(ic,np+1)=temp(ic,np+1)-tb
       endif

80    continue

      return
      end
      SUBROUTINE XBTBIASwij(itsprobe,depth,temp,maxlevel,
     * maxcalc,numsec,numlevels,iyearx,monthx,ifix)

C     XBTBIASwij CORRECTS XBT BIAS BASED ON INFORMATION FROM
C     WIJFFELS et al.  THE CORRECTIONS ARE MADE BEFORE
C     INTERPOLATION TO STANDARD LEVELS

      parameter (maxyear=3000,maxset=40)
      character*7 firsttime
      character*80 filename
      dimension depth(maxlevel),temp(maxlevel,maxcalc)
      dimension xshallow(maxyear,0:12),xdeep(maxyear,0:12)

      save firsttime
      save xshallow,xdeep,iyearmin,iyearmax

      if ( firsttime .ne. 'xbtbias' ) then
       firsttime = 'xbtbias'
       call clearstring(filename,80)
       call extraname('sys.inf'//CHAR(0),
     *  'wijffels_biascorrect.txt'//CHAR(0),
     *   filename)
       open(9,file=filename,status='old')

       iyearmin=5000
       iyearmax=0
       inumset=0
       do 55 n=1,maxyear

        read(9,*,end=44) iyear,xshallowin,xdum1,xdeepin,xdum2
        inumset=inumset+1
        xshallow(iyear,0)=xshallowin
        xdeep(iyear,0)=xdeepin
        if ( iyear .lt. iyearmin ) iyearmin=iyear
        if ( iyear .gt. iyearmax ) iyearmax=iyear

55     continue
44     continue
       close(9)

       do 60 iy=iyearmin,iyearmax-1
        xshallowdiff=(xshallow(iy+1,0)-xshallow(iy,0))/12.
        xdeepdiff=(xdeep(iy+1,0)-xdeep(iy,0))/12.

        do 65 mon=1,12
         xmon=mon
         xshallow(iy,mon)=xshallow(iy,0)+((xmon-1)*xshallowdiff)
         xdeep(iy,mon)=xdeep(iy,0)+(xmon*xdeepdiff)
65      continue

60     continue

       do 75 mon=1,12
        xshallow(iyearmax,mon)=xshallow(iyearmax,0)
        xdeep(iyearmax,mon)=xdeep(iyearmax,0)
75     continue
 
      endif

      ifix=0
      if ( itsprobe .eq. 2 ) then

       if ( numlevels .le. maxlevel ) then
        dpt=depth(numlevels)
       else
        call overmax(maxlevel,numsec,numlevels,0,ic,np)
        dpt=temp(ic,np)
       endif

       iyear=iyearx
       if ( iyearx .lt. 1968 ) iyear=1968
       if ( iyearx .gt. iyearmax ) iyear=iyearmax

       if ( dpt .le. 550. ) then
        xbias=xshallow(iyear,monthx)
       else
        xbias=xdeep(iyear,monthx)
       endif

       ifix=1
       do 80 n=1,numlevels

        if ( n .le. maxlevel ) then
         if ( iyear .eq. 1986 .and. monthx .eq. 8 )
     *    write(98,*) depth(n),depth(n)*(1.-xbias),xbias
         depth(n)=depth(n)*(1.-xbias) 
        else
         call overmax(maxlevel,numsec,n,0,ic,np)
         temp(ic,np)=temp(ic,np)*(1-xbias)
        endif

80     continue

      endif

      return
      end
      SUBROUTINE XBTBIASwil(itsprobe,ixprobe,depth,temp,maxlevel,
     * maxcalc,numsec,numlevels,iyearx,monthx,isippeq,ifix,iplat)

C     XBTBIASwil CORRECTS XBT BIAS BASED ON INFORMATION FROM
C     WIJFFELS et al.  TABLE 2 (WILLIS CORRECTIONS)
C     THE CORRECTIONS ARE MADE BEFORE INTERPOLATION TO STANDARD LEVELS

      parameter (maxyear=3000,ntypemax=8)
      parameter (n4=4,n7=4,ndb=4)

      character*7 firsttime
      character*80 filename
      dimension depth(maxlevel),temp(maxlevel,maxcalc)
      dimension xcorr(maxyear,ntypemax,0:12)
      dimension itype4(n4),itype7(n7),itypedb(ndb)
      dimension iyearmin(ntypemax),iyearmax(ntypemax)

      data itype4 /202,208,215,223/
      data itype7 /201,207,217,227/
      data itypedb /214,232,235,228/

      save firsttime
      save xcorr,iyearmin,iyearmax

      if ( firsttime .ne. 'xbtbias' ) then
       firsttime = 'xbtbias'
       filename='wijffels_2_t4_h95.txt'//CHAR(0)
       call readwillistables(ntypemax,maxyear,xcorr,
     *  filename,1,iyearmin,iyearmax)
       filename='wijffels_2_t4_orig.txt'//CHAR(0)
       call readwillistables(ntypemax,maxyear,xcorr,
     *  filename,2,iyearmin,iyearmax)
       filename='wijffels_2_t7_h95.txt'//CHAR(0)
       call readwillistables(ntypemax,maxyear,xcorr,
     *  filename,3,iyearmin,iyearmax)
       filename='wijffels_2_t7_orig.txt'//CHAR(0)
       call readwillistables(ntypemax,maxyear,xcorr,
     *  filename,4,iyearmin,iyearmax)
       filename='wijffels_2_tdb_h95.txt'//CHAR(0)
       call readwillistables(ntypemax,maxyear,xcorr,
     *  filename,5,iyearmin,iyearmax)
       filename='wijffels_2_tdb_orig.txt'//CHAR(0)
       call readwillistables(ntypemax,maxyear,xcorr,
     *  filename,6,iyearmin,iyearmax)
       filename='wijffels_2_unk_deep.txt'//CHAR(0)
       call readwillistables(ntypemax,maxyear,xcorr,
     *  filename,7,iyearmin,iyearmax)
       filename='wijffels_2_unk_shallow.txt'//CHAR(0)
       call readwillistables(ntypemax,maxyear,xcorr,
     *  filename,8,iyearmin,iyearmax)
      endif

      ifix=0
      if ( itsprobe .eq. 2 ) then

       ntyp=0
       do 150 nn=1,n4
150     if ( ixprobe .eq. itype4(nn) ) ntyp=2-isippeq
       do 155 nn=1,n7
155     if ( ixprobe .eq. itype7(nn) ) ntyp=4-isippeq
       do 160 nn=1,ndb
160     if ( ixprobe .eq. itypedb(nn) ) ntyp=6-isippeq
 
       if ( ntyp .eq. 0 ) then

        if ( numlevels .le. maxlevel ) then
         dpt=depth(numlevels)
        else
         call overmax(maxlevel,numsec,numlevels,0,ic,np)
         dpt=temp(ic,np)
        endif

        call xbtshallowdeep(ishallow,ixprobe,dpt,550.,iplat)
        if ( ishallow .lt. 0 ) return

        if ( ishallow .eq. 1 ) then
         ntyp=8
        else
         ntyp=7
        endif
       endif
        
       iyear=iyearx
c      write(6,*) 'ntyp',ntyp,iyearmin(ntyp)
       if ( iyearx .lt. iyearmin(ntyp) ) return
       if ( iyearx .gt. iyearmax(ntyp) ) iyear=iyearmax(ntyp)

       xbias=xcorr(iyear,ntyp,monthx)
       ifix=1

c      write(6,*) 'xb',iyear,ntyp,monthx,xcorr(iyear,ntyp,monthx)
       do 80 n=1,numlevels

        if ( n .le. maxlevel ) then
         if ( iyear .eq. 1986 .and. monthx .eq. 8 )
     *    write(98,*) depth(n),depth(n)*(1.-xbias),xbias
         depth(n)=depth(n)*(1.-xbias) 
        else
         call overmax(maxlevel,numsec,n,0,ic,np)
         temp(ic,np)=temp(ic,np)*(1-xbias)
        endif

80     continue

      endif

      return
      end
      SUBROUTINE XBTCONV(nobsdp,xprobe)

C     XBTCONV CORRECTS XBT DEPTHS FOR DROP RATE ERROR AS PER
C     SZABADOS PERSONAL COMMUNICATION (1992)

      parameter (maxlevel=6000, maxcalc=200, bmiss=-1.E10)
      double precision dx

c***************************************************************
c
c    Common Block:
c
c     thedata - contains depths and parameter data (temp)
c
c***************************************************************

      common /thedata/ depth(maxlevel),temp(maxlevel,maxcalc)

      iprobe=0
      if ( xprobe .gt. bmiss ) iprobe=xprobe 
      do 20 ij = 1 , nobsdp
 
c     Hanawa et al. 1994 for T4,T6,T7
      if ( iprobe .ne. 219 ) then
c       t=1498.148-sqrt(2244447.430-462.963*depth(ij))
cx      depth(ij)=6.733*t-.00254*t**2
c       depth(ij)=6.691*t-.00255*t**2
        dx=depth(ij)*1.D+00
        dx=(1.0417*dx)-(75.906*(1-((1-(.0002063*dx)))**.5))
        depth(ij)=dx
        if ( depth(ij) .lt. 0.0 ) depth(ij)=0.
        if ( isitnan(depth(ij)) .ne. 0 ) depth(ij)=0.
c       write(6,*) 'ij',ij,depth(ij)
       else
c      Kizu et al. 2005 for TSK T5
        if ( depth(ij) .le. 250 ) then
         depth(ij)=depth(ij)*0.9572
        elseif ( depth(ij) .le. 500 ) then
         depth(ij)=depth(ij)*0.9565
        elseif ( depth(ij) .le. 750 ) then
         depth(ij)=depth(ij)*0.9558
        elseif ( depth(ij) .le. 1000. ) then
         depth(ij)=depth(ij)*0.9550
        elseif ( depth(ij) .le. 1250. ) then
         depth(ij)=depth(ij)*0.9542
        elseif ( depth(ij) .le. 1500. ) then
         depth(ij)=depth(ij)*0.9533
        else
         depth(ij)=depth(ij)*0.9524
        endif 
       endif
20    continue
 
      return
      end

      SUBROUTINE XBTNEEDSCONV(nobsdp,xprobe,xswitch,iyear,ifix)

C     XBTCONV CORRECTS XBT DEPTHS FOR DROP RATE ERROR AS PER
C     SZABADOS PERSONAL COMMUNICATION (1992)

c***************************************************************
c
c     Passed Variable:
c
c      nobsdp - number of depth readings
c      xprobe - probe type
c        probe types which need depth conversion:
c           2 - XBT: TYPE UNKNOWN <- ONLY IF DEPTH IS <= 825 METERS
c         201 - XBT: T7 (UNKNOWN BRAND)
c         202 - XBT: T4 (UNKNOWN BRAND)
c         203 - XBT: T6 (UNKNOWN BRAND)
c         207 - XBT: T7 (SIPPICAN)
c         208 - XBT: T4 (SIPPICAN)
c         209 - XBT: T6 (SIPPICAN)
c         214 - XBT: DEEP BLUE (SIPPICAN)
c         215 - XBT: T4 (TSK)
c         216 - XBT: T6 (TSK)
c         217 - XBT: T7 (TSK)
c         219 - XBT: T5 (TSK) *different depth equation
c         223 - XBT: T4 (SPARTON)
c         227 - XBT: T7 (SPARTON)
c         228 - XBT: T7DB (SPARTON)
c      xswitch - set to one if XBT has already been depth corrected
c
c***************************************************************

c***************************************************************
c
c     Parameters:
c
c      maxlevel - maximum number of levels
c      maxcalc - maximum number of measured and calculated parameters
c      bmiss - missing value marker
c
c***************************************************************

      parameter (maxlevel=6000, maxcalc=200, bmiss=-1.E10)

c***************************************************************
c
c    Common Block:
c
c     thedata - contains depths and parameter data (temp)
c
c***************************************************************

      common /thedata/ depth(maxlevel),temp(maxlevel,maxcalc)

      ifix=0

c***************************************************************
c
c     If the depth of this probe reaches deeper than 925 meters,
c     it is probably a T5 or Fast Deep probe, which does not need adjustment
c
c***************************************************************

c     Hanawa fix already applied
      if ( xswitch .gt. 0. ) then
       ifix=0
       return
      endif
 
c     Unknown probe type
      if ( xprobe .le. bmiss ) ifix=-1

c     Probe not an XBT
      iprobe=xprobe
      if ( iprobe- mod(iprobe,200) .ne. 200 .and. iprobe
     *     .ne. 2 ) ifix=-1

c     Maximum depth of non-T5/non-Fast Deep XBT was 840. m
c     until 1997 when max depth of Deep Blue was increased
c     to > 900 m depth
c     For now, to be safe, we use a depth of 1005 meters.
c     Only T5s and Fast Deeps (maybe) go deeper

      xdepmax=1005.

      if ( depth(nobsdp) .gt. xdepmax .and. 
     *     iprobe .ne. 204 .and. iprobe .ne. 210 .and.
     *     iprobe .ne. 219 .and. iprobe .ne. 224 .and.
     *     iprobe .ne. 225 .and. iprobe .ne. 213. .and.
     *     iprobe .ne. 236) ifix=-1.

c      depth equation unknown in or after 1996
      if ( xswitch .lt. 0. .and. iyear .ge. 1996 ) ifix=-1

c     T-10s, Fast Deep, AXBTs ,SXBTs not corrected
c     MHI, Sparton 20, 20DB not corrected
c     non-TSK T5s not corrected

c     T-10s not corrected to Hanawa
      it10=0
      if ( iprobe .eq. 205 .or. iprobe .eq. 211 .or.
     *     iprobe .eq. 220 .or. iprobe .eq. 229 ) it10=1 

c     Fast Deep not corrected to Hanawa
      ifd=0
      if ( iprobe .eq. 213 .or. iprobe .eq. 236 ) ifd=1

c     Air drop XBT not corrected to Hanawa
      iaxbt=0
      if ( iprobe .eq. 233 .or. iprobe .eq. 234 .or.
     *     iprobe .eq. 238 .or. iprobe .eq.
     *      239 ) iaxbt=1

c     Submarine drop XBT not corrected (237)
c     MHI drop rate not corrected (218)
c     Sparton 20,20DB not corrected (230,231)
c     T11 not corrected (212)
      ioth=0
      if ( iprobe .eq. 218 .or. iprobe .eq. 230 .or.
     *     iprobe .eq. 231 .or. iprobe .eq. 237 .or.
     *     iprobe .eq. 212) ioth=1

c      T5 other than TSK not corrected (204,210,224,225)
       it5=0
       if ( iprobe .eq. 204 .or. iprobe .eq. 210 .or.
     *      iprobe .eq. 224 .or. iprobe .eq. 225 ) it5=1

      inofix=it5+ioth+iaxbt+ifd+it10

c     Hanawa et al. 1994 for T4,T6,T7
      if ( ifix .gt. -1 .and. inofix .eq. 0 ) then
       if ( iprobe .ne. 219  ) then
        ifix=1
       else
c       Kizu et al. 2005 for TSK T5
        ifix=2
       endif
      endif
 
      return
      end

      SUBROUTINE ADDCEND(carray,maxspace,itype)

C     ADDCEND ADDS THE C END OF STRING CHARACTER (\0) TO
C     THE END OF A STRING

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Passed Variables:
c
c      carray - character string to be examined
c      maxspace - maximum number of characters in character array
c      itype: 0 = set at first space
c             1 = set after last character
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      character*(*) carray

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Initialize nspace
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      nspace=0

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c    Look at each character in string.  If a character matches
c    the desired character, set the value of nspace.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      do 50 n=1,maxspace

       if ( carray(n:n).eq.' ' .and. nspace.eq.0) nspace=n
       if ( itype .eq. 1 .and.
     * nspace.gt.0 .and. carray(n:n).ne.' ' ) nspace=0

50    continue

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c    If the desired character is not found, set nspace to 
c    maxspace+1.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      if ( nspace.eq.0 ) nspace=maxspace

c****************************************************************
c
c    Add the C end of string character
c
c****************************************************************

      carray(nspace:nspace) = CHAR(0)

      return
      end
      SUBROUTINE ADDOLDMASK(mname,nmask,i,iprobe,iparameter,inew)

C     ADDOLDMASK ADDS A USER SPECIFIED MASK TO THOSE MASKS ALREADY
C     LISTED.  THIS  MASK WILL BE TREATED THE SAME AS
C     ANY MASK OPENED FROM INFORMATION IN MASKCHOICE.D

c**************************************************************
c
c     Passed Variables:
c
c      mname - mask name
c      nmask - number of each type of mask
c       1. number of inclusive sequential masks to be read
c       2. number of inclusive + exclusive sequential to be read
c       3. nmask(2) + number of depth exclusion masks to be read
c       4. nmask(3) + number of sequential masks to be written
c       5. nmask(4) + number of depth exclusion masks to be written
c
c       i - which mask type the mask will be
c       iprobe - the probe type represented by this mask
c       iparameter - the parameter represented by this mask
c       inew - 0 for old mask, 1 for new
c
c**************************************************************

c**************************************************************
c
c     Parameters:
c
c      maxprobe - maximum number of probe types
c      maxmask - maximum number of masks
c      ibasefile - starting number for masks in ifn
c
c**************************************************************

      parameter (maxprobe=100,maxmask=100)

      character*(*) mname
      character*80 filename

      dimension nmask(5)

c********************************************************************
c
c     Common Blocks:
c
c      parm2 - contains ipar2, which stores parameter codes for
c              mask files, file identifier numbers, and probe
c              codes for each maskfile.
c
c********************************************************************

      common /parm2/ ipar2(maxprobe),ifn(maxmask),ipro2(maxmask)

c***************************************************************
c
c     Add one to all mask numbers of masks appearing after the
c     mask to be added.  The mask variables must have their
c     values transfered to those corresponding to the new
c     mask number.  This is done in reverse order so as not
c     to overwrite any information.
c
c***************************************************************

      do 40 n=nmask(5),nmask(i)+1,-1
 
       ifn(n+1) = ifn(n)
       ipro2(n+1)=ipro2(n)
       ipar2(n+1)=ipar2(n)
 
40    continue
 
c***************************************************************
c
c    Add one to each mask type occurring at or later than the
c    mask type of the new mask.
c
c***************************************************************

      do 50 n=i,5

       nmask(n)=nmask(n)+1

50    continue
 
c*****************************************************************
c
c    Set the file identification number to the next available
c    number.  Set the probe type and parameter type according
c    to user specifications.
c
c*****************************************************************

      ifn(nmask(i))=-1

      ipro2(nmask(i))=abs(iprobe)
      if ( iprobe .eq. -1000 ) ipro2(nmask(i))=0
      ipar2(nmask(i))=iparameter

c*****************************************************************
c
c     Open mask
c
c*****************************************************************

      call clearstring(filename,80)
      call maskname(mname,iparameter,filename,ipro2(nmask(i)))

      if ( inew.eq.1 ) then
       call fileopen(filename,'w+'//CHAR(0),ifn(nmask(i)))
      else
       call fileopen(filename,'rb+'//CHAR(0),ifn(nmask(i)))
      endif

c**************************************************************
c
c    Switch unique station numbers to order numbers if necessary
c
c**************************************************************

       call ucheck(ipro2(nmask(i)),iuniqn)
       if ( iprobe .lt. 0 .and. iuniqn .ne. 0) then
       itemp=-1

       call tempfile(itemp)

       idone=0
       icount=0
       do 55 nn=1,20000000

        if ( nmask(i) .le. nmask(2) ) then
         call readmask(ju,ifn(nmask(i)),idone)
        else
         call readmask2(ju,ifn(nmask(i)),idone,isecond)
        endif

        if ( idone .gt. 0 ) then
         call onefilecloseft(ifn(nmask(i)))
         ifn(nmask(i))=itemp
         idone=0
         call filerewind(itemp)
         return
        endif

        call uorderfind(jj,ju,ipro2(nmask(i)))
        if ( jj .gt. -1 ) then
         if ( nmask(i) .le. nmask(2) ) then
          call writetomask(jj,icount,itemp)
         else
          call writetomask2(jj,icount,itemp,isecond)
         endif
        endif

55     continue
       endif

      return
      end
      SUBROUTINE AREAMASKER(kx,ngrid,idim,jdim,mska,iddif,jddif,
     * m1,idstart,idend,jdstart,jdend,nbasin,mixer,mtot)

C     AREAMASKS CONSTRUCTS MASK OF DIFFERENT AREAS OF THE
C     OCEAN

C     OCEAN BASIN INFORMATION IS IN FILE 
C     /OCL/SYS.INF/AREAMASK.1DEG

c**************************************************************
c
c    Passed Variables:
c     kx - depth level for mask
c     ngrid - grid size of graph
c     mska - 1=mask out this area of ocean for each area
c     iddif,jddif - number of grid spacings in the x and
c                   y directions for graph
c     m1 - array containing full longitude, latitude grid
c     idstart,idend - horizontal starting and ending points for graph
c     jdstart,jdend - vertical starting and ending points for graph
c     nbasin - number of areas
c
c**************************************************************

c**************************************************************
c
c     Parameters:
c      masknum - maximum number of basin masks
c      mostmask - maximum number of indices for basins
c      kdim - number of depth levels
c      idim0 - number of longitudes
c
c**************************************************************

      parameter (masknum=100,mostmask=30,kdim=40,idim0=360)
      parameter (kdimax=300)

      character*7 nosouth,nonorth
      character*60 abasin
      character*80 filename

      common /southset/ nosouth
      common /northset/ nonorth

c**************************************************************
c
c     Arrays:
c      num - number of indices per area mask
c      masker - temporary area mask
c      mtot - the number of areas per depth level
c
c      The rest of the arrays hold the indices for each basin.
c      The indices are the i,j coordinates which bound the basin.
c
c      The four elements in the first array dimension are:
c       1 - starting longitude
c       2 - ending longitude
c       3 - starting latitude
c       4 - ending latitude
c
c***************************************************************

      dimension m1(iddif,jddif)
      dimension xmasker2(4,mostmask,masknum)
      dimension num(masknum),masker(4,mostmask,masknum),
     * mtot(masknum),mska(masknum),mixer(masknum)
      dimension kalt(kdimax)

      save kalt

c*************************************************
c
c    Set up kalt in case an alternate set of standard
c    depths is in use
c
c**************************************************

      call equivalentdepths(kalt,kdimax)

c********************************************************
c
c    Read in information on area coverage
c
c********************************************************

      call clearstring(filename,80)
      call extraname('sys.inf'//CHAR(0),
     *  'areamask.1deg'//CHAR(0),filename)
      open(12,file=filename,status='old')

      nbasin=0
      xgrid=ngrid
      xgridx=.5/xgrid
      do 100 nn=1,masknum

       read(12,802,end=4) mtotx, mnum, mixer(mnum), num(mnum),abasin
       nbasin=nbasin+1
       mtot(mnum) = mtotx

       do 101 n2=1,num(mnum)
        read(12,801) (xmasker2(n3,n2,mnum),n3=1,4)
         do 405 n3=1,4

         if ( n3 .le. 2 ) then
          xmasker2(n3,n2,mnum) = xmasker2(n3,n2,mnum) + 90.
         elseif ( xmasker2(n3,n2,mnum) .le. 0. ) then
           xmasker2(n3,n2,mnum) = xmasker2(n3,n2,mnum) + 360.
           if ( n3 .eq. 3 .and. xmasker2(n3,n2,mnum) .ge. 360. )
     *      xmasker2(n3,n2,mnum)= 0. 
         endif

         if (mod(n3,2).eq.0) then
          masker(n3,n2,mnum)=(xmasker2(n3,n2,mnum)*xgrid)+xgridx
         else
          masker(n3,n2,mnum)= (xmasker2(n3,n2,mnum)*xgrid) +1.+xgridx
         endif

405      continue
101    continue

c800    format(3(i4,','),i4)
801    format(3(f7.2,1x),f7.2)
802    format(i2,i3,i4,5x,i3,2x,a60)

       read(12,*)
100   continue

 4    close(12)


c******************************************************
c
c    Above depth 31, do not completely close the
c    North American (30) and West European (31) basins
c
c******************************************************

      if (kalt(kx).lt.31) then
       num(30)=7
       num(31)=7
       mixer(35)=2
       mixer(30)=0
       mixer(31)=0
      endif

      if ( kalt(kx) .lt. 13 ) mixer(4)=-1
      if ( kalt(kx) .lt. 15 ) mixer(11)=-1

c*****************************************************
c
c    Initialize m1
c
c*****************************************************

      do 40 j=1,jddif
       do 41 i=1,iddif

        m1(i,j)= 0

41     continue
40    continue
 
c******************************************************
c
c    Run through each basin for this depth
c
c******************************************************

      do 50 m=1,nbasin

c     skip southern ocean if nosouth set
       if ( nosouth .eq. 'nosouth' .and. m .eq. 10) goto 50
c     skip arctic  ocean if nosouth set
       if ( nonorth .eq. 'nonorth' .and. m .eq. 11) goto 50

      if ( m .eq. 59 ) 
     * write(6,*) 'mtot',nbasin,m,mtot(m),kx,kalt(kx)
       if (mtot(m) .le. kalt(kx) ) then
 
c******************************************************
c
c   n2 is the marker for this basin.  If this basin is
c   not requested to be blocked, set n2 to zero, else
c   set n2 to the basin number.
c
c******************************************************

       n2=0
       if ( mska(m).gt.0 ) n2=m
 
c*******************************************
c
c    Run through each set of indices, putting
c    the proper values at the proper points
c
c*******************************************

       do 53 n=1,num(m)
 
        j1=masker(1,n,m)
        j2=masker(2,n,m)
        i1=masker(3,n,m)
        i2=masker(4,n,m)
        if ( m .eq. 59 ) 
     *  write(6,*) 'x',n,j1,j2,i1,i2,
     *   idstart,idend,jdstart,jdend

        do 54 j=j1,j2

         jx=j-jdstart+1
         if ( j .ge. jdstart .and. j .le. jdend ) then

          do 55 i=i1,i2
 
           if ( idend .ge. idstart ) then
            if ( i .ge. idstart .and. i .le. idend ) then
             ix=i-idstart+1
            else
             goto 55
            endif
           else
            if ( i .ge. idstart ) then
             ix=i-idstart+1
            elseif ( i .le. idend ) then
             ix= ((ngrid*idim0)-idstart)+i+1
            else
             goto 55
            endif 
           endif

           if ( ix .eq. 1800 .and. jx .eq. 900 ) then
c           write(6,*) 'n2',n2,m1(ix,jx),m,mtot(m),
c    *       mtot(m1(ix,jx))
           endif
           if ( m1(ix,jx) .eq. 0 ) then
            m1(ix,jx)=n2
           elseif ( mtot(m) .ge. mtot(m1(ix,jx)) ) then
            m1(ix,jx)=n2
           endif

55       continue
     
         endif

54      continue
 
53     continue
 
       endif

50    continue

      return
      end
      SUBROUTINE ARRAYINIT(iarray,nstart,nend)

C    ARRAYINIT INITIALIZES ALL ELEMENTS IN A ONE DIMENSIONAL
C    INTEGER ARRAY TO ZERO

      dimension iarray(nstart:nend)

      do 50 n=nstart,nend
50     iarray(n)=0

      return
      end
      SUBROUTINE ARRAYINIT2(iarray,nstart,nend,mstart,mend)

C    ARRAYINIT INITIALIZES ALL ELEMENTS IN A TWO DIMENSIONAL
C    INTEGER ARRAY TO ZERO

      dimension iarray(nstart:nend,mstart:mend)

      do 50 m=mstart,mend
       do 55 n=nstart,nend
       
        iarray(n,m)=0

55     continue
50    continue


      return
      end
      SUBROUTINE ARRAYINIT3(iarray,nstart,nend,mstart,mend,
     * lstart,lend)

C    ARRAYINIT INITIALIZES ALL ELEMENTS IN A TWO DIMENSIONAL
C    INTEGER ARRAY TO ZERO

      dimension iarray(nstart:nend,mstart:mend,lstart:lend)

      do 50 l=lstart,lend
       do 55 m=mstart,mend
        do 60 n=nstart,nend
       
         iarray(n,m,l)=0

60      continue
55     continue
50    continue


      return
      end
      SUBROUTINE CALCNEEDSET(ip2,maxlevel,mparms,ireqpars,
     * ireqpars2,ireqex)

C     CALCNEEDSET READS IN THE CODES OF THE MEASURED PARAMETERS
C     NEEDED TO CALCULATE THE CALCULATED PARAMETERS AND SETS
C     THE EXTRA CODES IN IP2

c***************************************************************
c
c    Passed Variables:
c     ip2 - parameter codes
c     maxlevel - maximum number of levels
c     mparms - number of possible measured parameters (including
c              second headers)
c     ireqpars - total number of measured parameters requested
c     ireqpars2 - total number of calculated parameters requested
c     ireqex - necessary measured parameters which are not yet
c     requested
c
c****************************************************************

      parameter (maxcalc=200)

      character*80 filename
      dimension ipc(5), ip2(0:maxlevel)

      common /calctype/ ipx(maxcalc)

      ireqex=0

c*****************************************************************
c
c    Open calc.need which contains the necessary information
c
c*****************************************************************

      call extraname('sys.inf'//CHAR(0),
     * 'calc.need'//CHAR(0),filename)
      open(10,file=filename,status='old')

      read(10,'(a1)') filename
      read(10,'(a1)') filename
      read(10,'(a1)') filename

      do 90 n=1,maxcalc

c******************************************************************
c
c    Read in necessary information
c
c******************************************************************

       read(10,800,end=4) nccode,(ipc(nn),nn=1,nccode)
       write(6,*)'ipcc',nccode,ipc(1),ipc(2)

c******************************************************************
c
c    See if this is one of the requested calculated parameters
c
c******************************************************************

      do 85 n0=ireqpars+1,ireqpars+ireqpars2

       if ( n .eq. ipx(n0)) then

c******************************************************************
c
c    See if the necessary parameters are already requested
c
c******************************************************************

       do 100 n2=1,nccode

        ifound=0
        do 101 n3=1,ireqpars+ireqpars2+ireqex

         if ( ip2(n3) .eq. ipc(n2) ) ifound=1

101     continue

        if ( ifound .eq. 0 ) then
         ireqex=ireqex+1
         ip2(ireqpars+ireqpars2+ireqex) = ipc(n2)
        endif

100    continue

       endif

85     continue

90    continue
800   format(59x,i2,2x,5i2)

4     close(10)

      return
      end
      SUBROUTINE CHANGELOCKSTATUS(lockstat,il,lockup)

C     CHANGELOCKSTATUS RESETS LOCK STATUS TO NEW
C     INPUT VALUE

      character*(*) lockstat
      character*11 locktype(0:4)

      data locktype/'open       ','*READ-ONLY*',
     * '*EXCL-LOCK*','OV_READONLY','OV_EXCLLOCK'/

      call clearstring(lockstat,il)
      call findlastchar(nsp,locktype(lockup),11)
      lockstat(1:nsp)=locktype(lockup)(1:nsp)

      return
      end
      SUBROUTINE CHECKIFALLSPACE(text,istart,icount,ispace)

C     RETURNS ISPACE=1 IF ALL BYTES ARE SPACES

      character*(*) text
 
      ispace=1
      inospace=0
      do 50 nn=istart,istart+icount-1

       if ( text(nn:nn) .ne. ' ' ) inospace=1

50    continue

      if ( inospace .eq. 1 ) ispace=0

      return
      end
      SUBROUTINE CLEARSTRING(c,nsize)

C    CLEARSTRING INITIALIZES A CHARACTER STRING WITH
C    BLANKS

      character*(*) c

      do 80 n=1,nsize
80     c(n:n)=' '

      return
      end
      SUBROUTINE CLOSEDENSEFILES(npots,jpotlevs,ireqpars,ip2,
     *  maxlevel,ioutfile,maxparm,maxpot,iposfile,m)

C     CLOSEDENSEFILES CLOSES FILES CONTAINING VARIABLES
C     ON GIVEN DENSITY SURFACES

      dimension ip2(0:maxlevel),ioutfile(0:maxparm,maxpot)
      dimension jpotlevs(maxpot),iposfile(maxpot)

c     run through for each requested reference surface

      do 45 n=1,npots

c     close position file

      call onefileclose(iposfile(n))

c     close variable files

       do 50 i0=1,ireqpars
        call onefileclose(ioutfile(ip2(i0),n))
50     continue
       
45    continue

      return
      end

      SUBROUTINE COUNTRYCODE

C     COUNTRYCODE PLACES THE ISO COUNTRY CODES INTO A CHARACTER
C     VARIABLE

c*********************************************************
c
c     Parameters:
c
c      maxcc - number of countries with NODC country codes
c
c*********************************************************

      parameter (maxcc=200)

c**************************************************************
c
c    Character Arrays:
c
c     ncc - array of all possible country codes
c     ncc2 - output country codes to main program
c
c***************************************************************

      character*2 ncc(maxcc)
      character*6 nccx
      character*11 firsttime
      character*80 filename,name

      common /countryc/ ncc
      save firsttime

      if ( firsttime .ne. 'countrycode' ) then
       firsttime='countrycode'
      else
       return
      endif

      infile=-2
c     infile=-1
      call clearstring(filename,80)
      call extraname('sys.inf'//CHAR(0),
     * 'countryname.c2'//CHAR(0),filename)
c     write(6,*) filename
      call fileopen(filename,'rb+'//CHAR(0),infile)
c     write(6,*) 'open'

      ieof=0
      ncountry=0
      do 50 n=1,maxcc

       call clearstring(name,80)
c      write(6,*) 'read',infile,ieof
       call readc2mask(nccx,name,infile,ieof)
       if ( ieof .ne. 0 ) goto 4
c       write(6,*) nccx,name
       ncc(n)=nccx(1:2)
       ncountry=ncountry+1

50    continue
4     continue

c     write(6,*) 'here',ncountry,infile
      call onefileclosefts(infile)

      do 55 n=ncountry+1,maxcc
55     ncc(n)='  '

      return
      end

      SUBROUTINE CRUISECON(cc,icruise,icnum)

C     CRUISECON TAKES A COUNTRY CODE AND A CRUISE CODE AND COMBINES
C     THEM TO CREAT A UNIQUE CODE.  THE LAST 6 DIGITS ARE THE CRUISE
C     CODE, THE 1,000,000 PLACE ON UP IS THE COUNTRY CODE NUMBER

c****************************************************
c
c    Passed Variables:
c
c     cc - country code
c     icruise - cruise code
c     icnum - combined integer code
c
c****************************************************

c****************************************************
c
c    Parameter:
c
c     maxcc - number of NODC country codes
c
c****************************************************

      parameter (maxcc=200)

c****************************************************
c
c    Character Array:
c
c     ncc - all NODC country codes 
c
c***************************************************

      character*2 cc,ncc(maxcc)

      common /countryc/ ncc

      ijk=0
      do 42 lm=1,maxcc
42    if (cc.eq.ncc(lm)) ijk=lm

c*****************************************************************
c
c     Construct the full cruise number by adding the integer
c    country code onto the left side of the cruise number
c
c*****************************************************************

      if ( icruise .ge. 0 ) then
       icnum = 1000000 * ijk + icruise
      else
       icnum = - (1000000 * ijk - icruise)
      endif

      return
      end

      SUBROUTINE DEPTHFILETOUSE(infile,nchar,grid)

C     DEPTHFILETOUSE CHECKS WHICH DEPTH SET THE USER HAS DESIGNATED
C     (DEFAULT IS ORIGINAL 33 DEPTHS) AND GRID SIZE, AND SETS UP
C     THE DEPTH FILE ACCORDINGLY

      character*4 cdepthset
      character*(*) infile
      call checkwhichdepthfile(cdepthset)

      call clearstring(infile,nchar)
      if ( grid .le. 0.10 ) then
       infile='etop10th_'//cdepthset//'.d'//CHAR(0)
      elseif ( grid .le. 0.25 ) then
       infile='etopq_'//cdepthset//'.d'//CHAR(0)
      elseif ( grid .le. 1.0 ) then
       infile='etop1_'//cdepthset//'.d'//CHAR(0)
      endif

      return
      end
      SUBROUTINE DISTANCE(rlat1,rlat2,rlon1,rlon2,x)

C     DISTANCE CALCULATES THE DISTANCE BETWEEN TWO 
C     LATITUDE,LONGITUDE POINTS

c*****************************************************
c
c      rlat1,rlon1 - first position
c      rlat2,rlon2 - second position
c      x - distance between points
c
c*****************************************************

c*****************************************************
c
c    Parameters:
c
c     req - radius of the earth at the equator
c     pi - pi
c
c*****************************************************

      parameter (req=6378.137D00, pi=3.141592653D00)

      double precision ang,x1,rlat1a,rlat2a,rlon1a,rlon2a

c*****************************************************
c
c    Convert lats and lons to radians
c
c*****************************************************

      rlat1a=((rlat1*pi)/180.)+0.D00
      rlat2a=((rlat2*pi)/180.)+0.D00

      rlon1a=((rlon1*pi)/180.)+0.D00
      rlon2a=((rlon2*pi)/180.)+0.D00

c*****************************************************
c
c     Figure distance
c
c*****************************************************

      ang=(dsin(rlat1a)*dsin(rlat2a)) +
     *             (dcos(rlat1a)*dcos(rlat2a) *
     *             dcos((rlon1a-rlon2a)))
      if ( ang .ge. 1.0D00 ) then
       x=0.
      else
       x1=req* dacos(ang) 
       x=x1
      endif

      return
      end
      SUBROUTINE DROPRATE_APPLY(a,b,nlevel,depth,maxlevel,t0)

C     DROPRATE_APPLY APPLIES NEW DROP RATE TO XBT DATA

      dimension depth(maxlevel),t0(maxlevel)

      do 50 n=1,nlevel

       depth(n)=a*t0(n) - b*t0(n)*t0(n)
c        write(6,*) 'n',n,t0(n),depth(n),a*t0(n),
c    * b*t0(n)*t0(n)

50    continue

      return
      end
      SUBROUTINE EQUIVALENTDEPTHS(kalt,kdimax)

C     EQUIVALENTDEPTHS SETS UP AN ARRAY OF CORRESPONDING
C     ARRAY ELEMENTS BETWEEN STANDARD 33 DEPTHS AND OTHER
C     STANDARD DEPTH DEFINITIONS (FULL AND GDEM)

      parameter (kdim=40,kdimaxloc=300)
      character*4 whichdepths
      dimension dz(kdim),dzalt(kdimaxloc),kalt(kdimax)

      call setstandeps(dz)
      call checkwhichdepthfile(whichdepths)

      if ( whichdepths .eq. 'orig' ) then
       do 40 k=1,kdim
40      dzalt(k)=dz(k)
       kmax=kdim
      else
       call setstandepsfromfile(kmax,dzalt)
      endif


      do 50 k=1,kmax

       klevel=0
       do 55 k2=1,kdim

        if ( dz(k2) .lt. dzalt(k)+0.01 ) klevel=klevel+1

55     continue
       kalt(k)=klevel

50    continue 

      return
      end
      SUBROUTINE EVERYMASK(nmasks,nmaskse,iprof,ifn,irewind)

C     EVERYMASK LOOKS AT ALL REQUESTED MASKS AND MAKES ONE
C     MASK OF ALL PROFILES WHICH ARE INCLUDED IN EVERY REQUESTED
C     MASK

c***************************************************************
c
c    Passed Variables:
c
c     nmasks - number of masks
c     nmaskse - number of anti masks
c     iprof - number of profiles in each mask
c     ifn - record numbers in each mask
c
c***************************************************************

c***************************************************************
c
c    Parameter
c
c     maxmask - maximum number of masks
c
c     itempfile - file identification number for created mask
c
c***************************************************************

      parameter (maxmask=100)

c***************************************************************
c
c     Arrays:
c
c      iend - set to one if a mask has been completely read in
c      jjx - record numbers in each mask file to compare
c
c***************************************************************

      dimension iend(maxmask), ifn(maxmask), iprof(maxmask)
      dimension jjx(maxmask)

      if ( irewind .eq. 0 ) then
       itempfile=-1
      else
       itempfile=irewind
      endif
      iprofx=0
      iprofe=0

c***************************************************************
c
c    Open temporary 'everymask'
c
c***************************************************************

      call tempfiles(itempfile)

      if ( nmasks .eq. 0 ) then

       do 455 n=1,nmaskse
        iende=0
        do 505 nn=1,20000000
         call readmask(jje,ifn(n),iende) 
         if ( iende .gt. 0 ) goto 455
         call writetomask(jje,iprofe,itempfile)
505     continue
455    continue

      else

c***************************************************************
c
c     Determine which of the requested masks is the smallest.
c     This will be the mask which all others will be compared
c     to to determine if all masks contain a profile
c
c***************************************************************


      minmask = 1
      minprof = iprof(1)

      do 45 n = 2,nmasks

       if ( iprof(n) .lt. minprof ) then

        minmask = n
        minprof = iprof(n)

       endif

45    continue

c*******************************************************************
c
c      Initialize all mask holder values. (maskinit)
c
c       A mask holder value is a C storage unit which holds the
c       last profile number read from a mask.
c
c        nmasks - total number of masks
c        iend - marks end of mask has been reached (when set to one)
c
c       Initialize record holders for minimum mask (jj) and
c       all other masks (jjx)
c
c***************************************************************

      call maskinit(nmasks+nmaskse,iend)
      do 77 nn=1,nmasks+nmaskse
77     iend(nn)=0
   
      jj = 0
      iendt=0

      do 88 n=1,nmasks+nmaskse

       jjx(n) = 0

88    continue

      jjold=0
      do 50 jj0 = 1,minprof

c***************************************************************
c
c     Read the next value from the smallest mask
c
c      readmask reads in the next record number from a mask
c
c      readmask:
c       
c       jj - record number read in
c       ifn - file identification number for this mask
c       iendt - set to one if mask was completely read in
c
c*********************************************************

       call readmask(jj,ifn(minmask),iendt)
       if ( jj .eq. jjold ) goto 50
       jjold=jj
       if ( jj .eq. 660790 ) write(6,*) 'xx',jj,minmask,ifn(minmask)

       if ( iendt .gt. 0 ) goto 4

c*********************************************************
c
c      See if all other masks contain jj, the record
c      number read in from the smallest mask
c
c      itotal is the number of masks which contain jjx
c
c*********************************************************

       itotal = 1

       do 55 n2 = 1,nmasks

        if ( n2 .eq. minmask .or. iend(n2) .gt. 0)  goto 55        

c*********************************************************
c
c     Call readmask to read in value from a mask until
c     a number equal to or larger than jj is found 
c
c*********************************************************

        if ( jjx(n2) .lt. jj ) then

         do 58 i2 = 1,20000000

          call readmask(jjx(n2),ifn(n2),iend(n2))

          if ( jjx(n2) .ge. jj .or. iend(n2) .gt. 0 ) goto 59

58       continue

        endif

c*********************************************************
c
c     If this mask contains jj, add one to the number of
c     masks containing jj
c
c*********************************************************

59      if (iend(n2) .lt. 1 .and. jjx(n2) .eq. jj )
     *   itotal = itotal + 1
       if ( jj .eq. 660790 ) write(6,*) 'xx',jj,in2,jjx(n2),660790,
     *  iend(n2),itotal

55     continue

c*********************************************************
c
c     If all masks contain this record number, add it
c     to the temporary 'everymask' after making sure the
c     profile is not in any antimasks.
c
c     writetomask:
c
c      jj - record number
c      iprof - counter of number of profiles written to file
c      itempfile - file identification number for temporary
c                      mask
c
c************************************************************

       if ( itotal .eq. nmasks ) then

        do 157 n2=nmasks+1,nmasks+nmaskse

        if ( jjx(n2) .lt. jj ) then

         do 158 i2 = 1,20000000

          call readmask(jjx(n2),ifn(n2),iend(n2))

          if ( jjx(n2) .ge. jj .or. iend(n2) .gt. 0 ) goto 159

158      continue

        endif

159     continue 
        if (iend(n2) .lt. 1 .and. jjx(n2) .eq. jj ) goto 50

157     continue
        

        call writetomask(jj,iprofx,itempfile)

       endif

50    continue
4     continue

      endif

c***********************************************************
c
c     Close all masks except 'everymask'
c
c***********************************************************

      do 60 n = 1,nmasks+nmaskse

       if ( irewind .eq. 0 ) then
        call onefilecloseft(ifn(n))
       else
        call filerewind(ifn(n))
       endif

60    continue

      ifn(1) = itempfile
      call filerewind(itempfile)

      if ( nmasks .eq. 0 .and. nmaskse .gt. 1 ) then
       call sortfile(3,itempfile,iprofe)
      endif

      return
      end

      FUNCTION FDENSE(T,S,P0)

C     FDENSE CALCULATES DENSITY
C      T - TEMPERATURE DEG CELSIUS
C      S - SALINITY PSU
C      P - PRESSURE DECIBARS (CHANGED TO BARS FOR CALCULATIONS)

      REAL KW,KSTO,KSTP
 
      P = P0 * .1
 
C
C
      RW =     999.842594 + 6.793952E-2*T - 9.095290E-3*T**2
     1        + 1.001685E-4*T**3 - 1.120083E-6*T**4 + 6.536332E-9*T**5
C
      RSTO =   RW + (0.824493 - 4.0899E-3*T + 7.6438E-5*T**2
     1        - 8.2467E-7*T**3 + 5.3875E-9*T**4) * S
     2       + (-5.72466E-3 + 1.0227E-4*T - 1.6546E-6*T**2) * S**1.5
     3       + 4.8314E-4 * S**2
C
      KW =     19652.21 + 148.4206*T - 2.327105*T**2 + 1.360477E-2*T**3
     1        - 5.155288E-5*T**4
C
      KSTO =   KW + (54.6746 - 0.603459*T + 1.09987E-2*T**2
     1        - 6.1670E-5*T**3) * S
     2       + (7.944E-2 + 1.6483E-2*T - 5.3009E-4*T**2) * S**1.5
C
      KSTP =   KSTO + (3.239908 + 1.43713E-3*T + 1.16092E-4*T**2
     1        - 5.77905E-7*T**3) * P
     2       + (2.2838E-3 - 1.0981E-5*T - 1.6078E-6*T**2) * P * S
     3       + 1.91075E-4 * P * S**1.5
     4       + (8.50935E-5 - 6.12293E-6*T + 5.2787E-8*T**2) * P**2
     5       + (-9.9348E-7 + 2.0816E-8*T + 9.1697E-10*T**2) * P**2 * S
C
      FDENSE =    RSTO/(1.0-P/KSTP)-1000.
C
      RETURN
      END

      REAL FUNCTION FDEPTH(P,LAT)
*********************************************************************
* Depth in meters from pressure in decibars using Saunders
* and Fofonoff's method.
* Deep-Sea Res., 1976,23,109-111.
* Formula refitted for 1980 equation of state units:
*          Pressure        P         Decibars
*          Latitude        LAT       Degrees
*          Depth           DEPTH     Meters
* Checkvalue:  DEPTH=9712.653 M for P=10000 Decibars, LATITUDE=30 Degrees
* Above for station ocean: T=0 Degree Celsius; S=35 (PSS-78)
*********************************************************************
      REAL LAT
      X=SIN(LAT/57.29578)
      X=X*X
* GR=Gravity variation with Latitude: ANON (1970) Bulletin Geodesique
      GR=9.780318*(1.0+(5.2788E-3+2.36E-5*X)*X)+1.092E-6*P
      FDEPTH=(((-1.82E-15*P+2.279E-10)*P-2.2512E-5)*P+9.72659)*P
      FDEPTH=FDEPTH/GR
      RETURN
      END
      SUBROUTINE FILECONSTX( ik, nprb, nyc, nyc2, nt, csea,
     * statpath, nfile, nomal, nomaly, iylook, nsucy, sgrid,
     * ifive)

C     FILECONST CONSTRUCTS CONVENTIONAL FILE NAMES FROM INPUT
C     INFORMATION.

c********************************************************
c
c    Conventional file name consists of:
c
c   Directory pathname (statpath) + /grid size (sgrid)/ +
c   /field type (nt) (no field type for analyzed data)/ +
c   file name
c
c   File name consists of:
c    one to three letter parameter code (mtype) +
c    one character probe codes of all probe types involved (tcar) or
c    zero if all probes which measure the parameter in question
c    are involved + 
c    [ 'y' of 'm' if specific years or months only are involved] +
c    [ two digit beginning year or month (01 -99)] +
c    [ two digit ending year or month (01-99)] +
c    two digit time period (00 - 16): 00 is annual, 01 to 12 are
c    the months, 13-16 are the seasons +
c    [ an A if anomalies are being investigated] +
c    [ a Y, S, or M depending if yearly, seasonal, or monthly
c     analyses are being investigated ]
c
c    [] brackets denote additions used only in the specific
c    special situation listed.
c    
c********************************************************

c********************************************************
c
c    Passed Variables:
c     ik - parameter number
c     nprb - number of probes
c     nyc, nyc2 - starting and ending years (months)
c     nt - type of field:
c          0 - unnamed (analyzed)
c          1 - means
c          2 - number of observations
c          3 - standard deviations
c          4 - standard error of the mean
c          5 - observed minus annual
c          6 - field minus annual
c     csea - character representation of time period
c     statpath - pathname to file
c     nfile - constructed file name
c     nomal - denotes anomaly value if set to one
c     nomaly -type of anomaly:
c             0 - not an anomaly
c             1 - yearly
c             2 - seasonal
c             3 - monthly
c     iylook - look at specific years if set to one
c     nsucy - successive year marker if set to one,
c             a shell is being run on successive years
c     sgrid - grid size
c     ifive - set to one if this is five-degree statistics
c             set to two if this is a standard deviation
c             analysis
c
c*******************************************************

c*******************************************************
c
c     Parameters:
c
c      maxparm - maximum number of parameters in system
c      maxcalc - maximum number of measured and calculated
c                parameters in system
c      maxprobe - maximum number of probes in system
c      maxlevel - maximum number of levels
c
c******************************************************

      parameter (maxparm=100, maxcalc=200, maxprobe=100)
      parameter (maxlevel=6000)

c*******************************************************
c
c    Character Variables:
c
c     tcar - single character representation for probe type
c            The first 9 are the numbers one through nine.
c            The next 26 are the capital letters of the
c            alphabet
c     csea - character representation of the time period:
c            00 - annual
c            01-12 - months (Jan-Dec)
c            13-16 - seasons (Winter-Fall)
c            17-40 - semi- monthly
c     mtype - one to three character representation of the
c             parameter
c     sgrid - character representation of the grid size:
c             '1.00','0.50','0.25', etc.
c     outfile - constructed file name without directory path
c
c*************************************************************

      character*1 tcar(35)
      character*2 csea
      character*3 mtype
      character*4 sgrid
      character*80 statpath, outfile, nfile, cmixname
 
      data tcar/9*'0','A','B','C','D','E','F','G','H','I',
     * 'J','K','L','M','N','O','P','Q','R','S','T','U','V',
     * 'W','X','Y','Z'/
 
c************************************************************
c
c     Common Blocks:
c      parname1 - contains mtype, one to three letter
c                 character codes
c      reqprobe - contains jp, probe type codes for requested
c                 probes
c      totalparms - contains npatot, the number of probe types
c                   which measure each parameter
c
c      surrogate - contains isur, the surrogate for calculated
c                  parameters.  A surrogate is a measured parameter
c                  whose record numbers are used to store the
c                  data of the calculated parameter
c
c***********************************************************

      common /parname1/ mtype(maxlevel)
      common /reqprobe/ jp(0:maxprobe)
      common /totalparms/ npatot(maxparm)
      common /surrogate/ isur(maxcalc)
      common /fracta/ numsuc,nsub
      common /geop/ igeot,jlev,dsurf

c***********************************************************
c
c   Special common:
c
c    pstcom - common to hold information for graphics file
c
c     ipst - set to one if POST file requested
c                   two if JPEG file requested
c                   three if GIF file requested
c                   -1 if a .dat file (data file)
c     kx - depth represented in graphic
c
c**********************************************************

      common /pstcom/ ipst,kx
 
c**********************************************************
c
c    Clear full file name
c
c**********************************************************

      call clearstring(nfile,80)

c**********************************************************
c
c    find length of input file pathname
c
c    Set ntit to this length
c
c**********************************************************

      ntit=0
      ntit2=0
      do 901 n=1,80
901    if (statpath(n:n).eq.' '.and.ntit.eq.0) ntit = n - 1

c**********************************************************
c
c     put grid spacing in filename
c
c     ntit2 is the length of the file name without the
c     full directory path
c
c**********************************************************

      outfile(1:4) = sgrid
      outfile(5:5)='/'
      ntit2=5

c**********************************************************
c
c      put file type in file name:
c       nt=1 for mean fields
c       nt=2 for data distributions
c       nt=3 for standard deviation fields
c
c**********************************************************

      if ( nt .eq. 2 ) then
       outfile(ntit2+1:ntit2+4) = 'num/'
       ntit2 = ntit2+4
      elseif ( nt .eq. 1 .or. nt .eq. 5 .or. nt .eq. -2) then
       outfile(ntit2+1:ntit2+5) = 'mean/'
       ntit2 = ntit2+5
      elseif (nt .eq. 3 .or. nt .eq. 4 ) then
       outfile(ntit2+1:ntit2+3) = 'sd/'
       ntit2= ntit2+3
      endif

c********************************************************
c
c     put one letter parameter abbreviation in file name
c
c*******************************************************

      if ( igeot .ne. 1 .and. igeot .ne. 2 ) then
       call findlastchar(ne,mtype(ik),3)
       outfile(ntit2+1:ntit2+ne) = mtype(ik)(1:ne)
       ntit2= ntit2+ne
       if ( igeot .eq. 3 ) then
        outfile(ntit2+1:ntit2+1) = 'g'
        ntit2=ntit2+1
       endif
      elseif ( igeot .eq. 1 ) then
       outfile(ntit2+1:ntit2+1) = 'G'
       ntit2= ntit2+1
      elseif ( igeot .eq. 2 ) then
       call mixedlayerchoice(ivar,xmixed,del0,del3,
     *  cmixname,nspmix)
       outfile(ntit2+1:ntit2+nspmix)=cmixname(1:nspmix)
       ntit2=ntit2+nspmix
      endif
 
c*****************************************************
c
c     write in probe types
c
c     If all probes which measure a parameter are involved,
c     place a zero '0' instead of the probe types
c
c     Otherwise, place the one character code for each
c     involved probe type in the file name.
c 
c*****************************************************

      if (nprb.ge.npatot(ik)) then

       outfile(ntit2+1:ntit2+1)='0'
       ntit2=ntit2+1

      else

       do 86 n=1,nprb

        ntit2=ntit2+1

        if (jp(n).lt.10) then
        write(outfile(ntit2:ntit2),'(i1)') jp(n)
        else
        outfile(ntit2:ntit2)=tcar(jp(n))
        endif

86     continue

      endif

c*******************************************************
c
c    Designate reference level for density surface
c
c*******************************************************

      if ( igeot .eq. -1 ) then
       outfile(ntit2+1:ntit2+1)='d'
       ntit2=ntit2+1
       if ( jlev .lt. 0 ) then
        outfile(ntit2+1:ntit2+6)='insitu'
        ntit2=ntit2+6
       elseif ( jlev .lt. 1 ) then
        outfile(ntit2+1:ntit2+4)='surf'
        ntit2=ntit2+4
       elseif ( jlev .lt. 1000 ) then
        write(outfile(ntit2+1:ntit2+3),'(i3)') jlev
        ntit2=ntit2+3
       else
        write(outfile(ntit2+1:ntit2+4),'(i4)') jlev
        ntit2=ntit2+4
       endif
      endif


c*******************************************************
c
c    put years or months in file name
c
c    If this is a year or month specific file, place the
c    starting and ending year (or month) in the file name.
c
c*******************************************************

        if (iylook.gt.0.or.nsucy.gt.0) then
        if (iylook.eq.1.or.nsucy.eq.1) then
         outfile(ntit2+1:ntit2+1)='m'
        else
         outfile(ntit2+1:ntit2+1)='y'
        endif
 
         nycx=nyc
         if ( nyc .ge. 1900 ) nycx=nyc-1900

         if (nycx.lt.10) then
          outfile(ntit2+2:ntit2+2)='0'
          write(outfile(ntit2+3:ntit2+3),'(i1)') nycx
         elseif ( nycx .lt. 100 ) then
          write(outfile(ntit2+2:ntit2+3),'(i2)') nycx
         elseif ( nycx .lt. 110 ) then
          outfile(ntit2+2:ntit2+2)='A'
          write(outfile(ntit2+3:ntit2+3),'(i1)') nycx-100
         elseif ( nycx .lt. 120 ) then
          outfile(ntit2+2:ntit2+2)='B'
          write(outfile(ntit2+3:ntit2+3),'(i1)') nycx-110
         endif

         nycx=nyc2
         if ( nyc2 .ge. 1900 ) nycx=nyc2-1900

         if (nycx.lt.10) then
          outfile(ntit2+4:ntit2+4)='0'
          write(outfile(ntit2+5:ntit2+5),'(i1)') nycx
         elseif ( nycx .lt. 100 ) then
          write(outfile(ntit2+4:ntit2+5),'(i2)') nycx
         elseif ( nycx .lt. 110 ) then
          outfile(ntit2+4:ntit2+4)='A'
          write(outfile(ntit2+5:ntit2+5),'(i1)') nycx-100
         elseif ( nycx .lt. 120 ) then
          outfile(ntit2+4:ntit2+4)='B'
          write(outfile(ntit2+5:ntit2+5),'(i1)') nycx-110
         endif
 
         ntit2 = ntit2 + 5

c   Deal with fractions of year

         if ( numsuc .lt. 0 ) then

          nsuc1 = -numsuc*(nsub-1)+1
          nsuc2 = -numsuc*nsub

          if ( nsuc1 .ge. 10 ) then
           write(outfile(ntit2+1:ntit2+2),'(i2)') nsuc1
           ntit2=ntit2+2
          else
           write(outfile(ntit2+1:ntit2+1),'(i1)') nsuc1
           ntit2=ntit2+1
          endif

          outfile(ntit2+1:ntit2+1)='-'
          ntit2=ntit2+1

          if ( nsuc2 .ge. 10 ) then
           write(outfile(ntit2+1:ntit2+2),'(i2)') nsuc2
           ntit2=ntit2+2
          else
           write(outfile(ntit2+1:ntit2+1),'(i1)') nsuc2
           ntit2=ntit2+1
          endif

         endif
 
       endif

c*******************************************************
c
c     add time period to output file
c
c*******************************************************

      outfile(ntit2+1:ntit2+2)=csea
      ntit2=ntit2+2

c*******************************************************
c
c     add A for anomalies
c     also add type of anomalies:
c      Y for yearly
c      S for seasonal
c      M for monthly
c
c*******************************************************

      if (nomal.gt.0) then
       outfile(ntit2+1:ntit2+1)='A'
       if (nomaly .eq. 1) then
        outfile(ntit2+2:ntit2+2)='Y'
       elseif (nomaly .eq. 2) then
        outfile(ntit2+2:ntit2+2)='S'
       else
        outfile(ntit2+2:ntit2+2)='M'
       endif
      ntit2=ntit2+2
      endif

c******************************************************
c
c    Set standard error of the mean (SE) or
c    difference between observed values and analyzed values (OA)
c    or field minus annual (MA)
c
c*****************************************************

      if ( nt .eq. 4 ) then
       outfile(ntit2+1:ntit2+2)='SE'
       ntit2=ntit2+2
      elseif ( nt .eq. 5 ) then
       outfile(ntit2+1:ntit2+2)='OA'
       ntit2=ntit2+2
      elseif ( nt .eq. 6 ) then
       outfile(ntit2+1:ntit2+2)='MA'
       ntit2=ntit2+2
      elseif ( nt .eq. -1 .or. nt .eq. -2 .or. nt .eq. 7) then
       outfile(ntit2+1:ntit2+2)='AV'
       ntit2=ntit2+2
      elseif ( nt .eq. -3 ) then
       outfile(ntit2+1:ntit2+2)='OI'
       ntit2=ntit2+2
      endif

c*******************************************************
c
c    Graphics output file depth
c
c*******************************************************

      if ( ipst .gt. 0 ) then

       if ( kx .le. 9 ) then
        outfile(ntit2+1:ntit2+1)='0'
        write(outfile(ntit2+2:ntit2+2),'(i1)') kx
       else
        write(outfile(ntit2+1:ntit2+2),'(i2)') kx
       endif
       ntit2=ntit2+2

      endif

      if ( ipst .ne. 0 .and. nt .eq. 1 ) then
       outfile(ntit2+1:ntit2+1)='N'
      endif 

c*******************************************************
c
c    add .5 for five-grid square statistics
c
c*******************************************************

      if ( ifive .eq. 1 ) then
       outfile(ntit2+1:ntit2+2)='.5'
       ntit2=ntit2+2
      elseif ( ifive .eq. 2 ) then
       outfile(ntit2+1:ntit2+3)='.sd'
       ntit2=ntit2+3
      endif

c*******************************************************
c
c    Graphics output file type
c
c*******************************************************

      if ( ipst .eq. 1 ) then
       outfile(ntit2+1:ntit2+3)='.ps'
       ntit2=ntit2+3
      elseif (ipst .eq. 2 ) then
       outfile(ntit2+1:ntit2+3)='.jp'
       ntit2=ntit2+3
      elseif (ipst .eq. 3 ) then
       outfile(ntit2+1:ntit2+3)='.gf'
       ntit2=ntit2+3
      elseif (ipst .eq. 4 ) then
       outfile(ntit2+1:ntit2+4)='.eps'
       ntit2=ntit2+4
      endif

c*******************************************************
c
c    add pathname and file name together for full file name
c
c*******************************************************

        nfile=statpath(1:ntit)//'/'//outfile(1:ntit2)
 
c*******************************************************
c
c    Reinitialize outfile
c
c*******************************************************

      call clearstring(outfile,80)

      return
      end

      SUBROUTINE FINDCHAR(nspace,carray,maxspace,cfind)

C     FINDCHAR FINDS THE FIRST OCCURRANCE OF A DESIRED CHARACTER IN
C     A CHARACTER STRING.

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Passed Variables:
c
c      nspace - distance, in characters, from the beginning of
c               the character string at which the first occurance
c               of the desired character is found
c      carray - character string to be examined
c      maxspace - maximum number of characters in character array
c      cfind - character to be searched for
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      character*1 cfind
      character*(*) carray

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Initialize nspace
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      nspace=0

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c    Look at each character in string.  If a character matches
c    the desired character, set the value of nspace.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      do 50 n=1,maxspace

       if ( carray(n:n).eq.cfind .and. nspace.eq.0) nspace=n

50    continue

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c    If the desired character is not found, set nspace to 
c    maxspace+1.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      if ( nspace.eq.0 ) nspace=maxspace+1

      return
      end
      SUBROUTINE FINDDEPTHLEVELNUM(dz,kdim,numdeps,zdepth,idepthout)

C     FINDDEPTHLEVELNUM FINDS THE CLOSEST STANDARD DEPTH LEVEL
C     NUMBER BASED ON GIVEN DEPTH

      dimension dz(kdim)

      idepthout=0
      kmore=0
      kless=0
      do 50 k=1,numdeps

       if ( dz(k) .lt. zdepth + 0.01 .and.
     *      dz(k) .gt. zdepth - 0.01 ) then
        idepthout=k
        return
       endif

       if ( dz(k) .lt. zdepth ) kless=k+1
       if ( dz(k) .gt. zdepth .and. kmore .eq. 0 ) 
     *  kmore=k

50    continue

      if ( kless .eq. 0 ) return

      if ( kmore .eq. 0 ) then
       idepthout=numdeps+1
       return
      endif

      zless=zdepth-dz(kless)
      zmore=dz(kmore)-zdepth

      if ( zless .lt. zmore ) then
       idepthout=kless
      else
       idepthout=kmore
      endif

      return
      end
      SUBROUTINE FINDLASTCHAR(nspace,carray,maxspace)

C     FINDLASTCHAR FINDS THE LOCATION OF THE LAST NON-BLANK
C     IN A CHARACTER STRING

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Passed Variables:
c
c      nspace - distance, in characters, from the beginning of
c               the character string where the last non-blank
c               character is found
c      carray - character string to be examined
c      maxspace - maximum number of characters in character array
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      character*(*) carray

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Initialize nspace
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      nspace=-1

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c    Look at each character in string.  If a character is a blank
c    set the value of nspace. If a nonblank character is found,
c    nspace is set to zero.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      do 50 n=1,maxspace
         
c        write(6,*) 'x50',n,'|',carray(n:n),'|'
c        if ( carray(n:n) .eq. CHAR(0) ) then
         i=isitreturn(carray(n:n))
         if ( i .eq. 1 ) then
           if ( nspace .eq. 0 ) then
            nspace=n
           endif
           goto 4
         endif
         
         if ( carray(n:n) .eq. " " .and. nspace .eq. 0 ) nspace=n

         if ( carray(n:n) .ne. " ") nspace=0
         
50    continue
4     continue

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c    If a blank is not found, set nspace to maxspace.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      if ( nspace.eq.0 ) nspace=maxspace+1
      if ( nspace .eq. -1 ) nspace=1
      nspace=nspace-1

      return
      end
      SUBROUTINE FINDPRECONE(iprec,isig,val)

C     FINDPRECONE FINDS THE PRECISION OF A VALUE

c***********************************************
c
c    Passed Variables:
c
c     iprec - precision of value
c     isig - number of significant figures in value
c     val - value in question
c
c***********************************************

c***********************************************
c
c   Find the number of significant figures left of the decimal
c
c************************************************

      if ( isig .ge. 0 ) then
       jsig = 0
       call findsignif(jsig,0,val)
       if ( isig .le. 0 ) isig=jsig

c************************************************
c
c    Find precision
c
c************************************************

       iprec = isig - jsig
       if ( iprec .lt. 0 ) iprec=0

c**************************************************************
c
c      See if the precision needs to be adjusted for trace values
c
c**************************************************************

       xp = 10**(iprec)

       if ( val .lt. 1. .and. val .gt. 0.
     *  .and. isig .gt. 0 ) then

        itempt = xp * val
        if ( itempt .eq. 0 ) then
         iprec = iprec+1
        endif

       endif

c    Add this line for values less than 1.0 and
c    greater than -1.0

       if ( val .lt. 1. .and. val .gt. -1. .and.
     *      iprec .eq. 0 ) iprec=1

      else

       iprec=0

      endif

      return
      end
      SUBROUTINE FINDSIGNIF(isignif,iprecise,value)

C     FINDSIGNIF FINDS THE NUMBER OF SIGNIFICANT
C     DIGITS IN A VALUE.

c**********************************************************
c
c     Passed Variables:
c
c      isignif - number of significant digits
c      iprecise - precision of reading (number of digits
c                to the right of the decimal point)
c      value - data measurement in question
c
c**********************************************************

c**********************************************************
c
c     Use the absolute value of the data measurement
c     to find significant figures
c
c**********************************************************

      if ( value.lt.0 )then
       avalue = -value
      else
       avalue = value
      endif

      if ( iprecise.gt.0 ) then 

       xx=10.
       do 55 i=2,iprecise+1
55      xx=xx * 10.

        avalue = avalue + 4.999/xx

      endif      

c**********************************************************
c
c     Find the number of digits to the left of the
c     decimal point
c
c**********************************************************

      x = 1.

      if ( x .gt. avalue ) then

       isignif = 0

      else

       do 40 n = 1,12

        x = x * 10.

        if ( x .gt. avalue ) then

         isignif = float(n) 
         goto 4

        endif
40     continue
4     continue

      endif

c***********************************************
c
c     Add the number of significant digits to
c     the left of the decimal to the number of
c     significant digits.
c
c***********************************************

      isignif = isignif + iprecise

      if ( isignif .eq. 0 .and. avalue .gt. -.000001 .and.
     * avalue .lt. .000001 ) isignif =1

      return 
      end
      REAL FUNCTION FPRESS(DEPTH,LAT,DLAST,PLAST,N)
*********************************************************************
c     Function fpress computes pressure from depth using
c     the algorithm outlined in Processing of Oceanographic
c     Station Data (JPOTS)
c
c     DEPTH - depth 
c     LAT   - latitude
c     DLAST  - last recorded depth
c     PLAST - last recorded pressure
c     N - number of iterations of trapezoidal integration
c
c     Check Value: DEPTH=5000, LAT=15, DLAST=4500, PLAST=4575.04
c                  P = 5089.22
c
*********************************************************************

      REAL LAT
      FPRESS=0.0
      IT=0
      X=SIN(LAT/57.29578)
      X=X*X
c RHOLAST - density of seawater at 35 PSU and 0 degC
c           for last recorded pressure
      RHOLAST = FDENSE(0.,35.,PLAST)+1000.
c GRLAST - Gravity at last recorded pressure
      GRLAST=9.780318*(1.0+(5.2788E-3+2.36E-5*X)*X)+1.092E-6*PLAST
c P=Pressure estimate calculated using last recorded pressure
      P=PLAST + ((RHOLAST*GRLAST)*(DEPTH-DLAST))/1.E4

      DO 50 NN=1,N

      IF ( NN .EQ. 1 ) THEN

      GR0=9.780318*(1.0+(5.2788E-3+2.36E-5*X)*X)
      RHO0 = FDENSE(0.,35.,0.) + 1000.

* GR=Gravity variation with Latitude: ANON (1970) Bulletin Geodesique
      GR=9.780318*(1.0+(5.2788E-3+2.36E-5*X)*X)+1.092E-6*P
* RHO=Density of seawater at 35 PSU and 0 degC, pressure P
      RHO = FDENSE(0.,35.,P) + 1000.
      FPRESS= .5 * (DEPTH/1.E4)*((RHO*GR)+(RHO0*GR0))
      IT=1

      ELSE

      TNM=IT
      DEL=P/TNM
      Y=0.5*DEL
      SUM=0.

      DO 100 J=1,IT
      GR=9.780318*(1.0+(5.2788E-3+2.36E-5*X)*X)+1.092E-6*Y
      RHO = FDENSE(0.,35.,Y) + 1000.
      SUM = SUM + (RHO*GR)
      Y=Y+DEL
100   CONTINUE

      FPRESS= 0.5*(FPRESS+(DEPTH/1.E4)*SUM/TNM)
      IT=2*IT
      
      ENDIF

50    CONTINUE

c***********************************************************
c
c   Modification as detailed by R. Millard (personal communication)
c    Iterative process to invert depth to pressure, using the
c    calculated pressure (fpress) as a starting point.
c
c************************************************************

      if ( depth .eq. 0. ) return

      p= fpress
      pp= p
      dp= .01

      do 60 m=1,20

       z1= fdepth(p,lat)
       dz= abs(z1 - depth)/depth
       if ( dz .ne. 0 ) p= p + p*dz

       if ( abs( p - pp ) .le. dp ) then
        fpress= p
        return
       endif

       pp= p

60    continue

      FPRESS= p
    
      RETURN
      END
      SUBROUTINE GEOTHICK(dz,kdim,temp,maxlevel,maxcalc,ik,rlat,klev)

C     GEOTHICK CALCULATES THE GEOPOTENTIAL THICKNESS
C     OF A GIVEN PROFILE BASED ON ITS DENSITY,
C     DEPTH, AND POSITION

C     GEOPOTENTIAL THICKNESS WILL BE IN UNITS OF DYNAMIC CM

c     dz - depths
c     temp - array holding input density information/
c            output geopotential thickness information
c     kdim - maximum number of depths
c     maxcalc - maximum number of parameters in temp
c     ik - parameter number
c     rlat - latitude of profile
c     klev - number of depth levels

      parameter (kdimmax=6000,bmiss=-1.E10)

      dimension dz(kdim),temp(maxlevel,maxcalc)
      dimension press(kdimmax)
      if ( dz(1) .eq. 0. ) then
       press(1) =0.
      else
       press(1)=fpress(dz(1),rlat,0.,0.,3)
      endif

c     calculate pressure based on depth and position

      kl=klev
      if ( klev .ge. kdim ) kl=kdim-1

      do 200 k=2,kl+1
200     press(k)=fpress(dz(k),rlat,dz(k-1),press(k-1),3)
      write(6,*) 'press(k)',press(k)
 
      do 20 k=1,kl

       if ( temp(k,ik) .gt. bmiss ) then

c     calculate layer thickness

        if ( dz(k)  .gt. .0001 ) then
         x0=press(k-1)+((press(k)-press(k-1))/2.)
        else
         x0=0.
        endif
        xz=press(k)+((press(k+1)-press(k))/2.)

        xthick=xz-x0
         
c     calculate standard geopotential

        astd= 1./(fdense(0.,35.,press(k))+1000.)

c      calculate geopotential

        a= 1./(temp(k,ik)+1000.)

c      calculate geopotential thickness

c       write(6,*) 'Level',k,temp(k,ik),fdense(0.,35.,press(k)),
c    * a, astd
        temp(k,ik)=(a-astd)*xthick*10.E4
c       write(6,*) press(k-1),press(k),press(k+1),x0,xz,xthick
c       write(6,*) temp(k,ik)

       endif

20    continue
   
      return
      end
      SUBROUTINE GETMAINPROBE(iyes,mainprobe,jp,nparm0)

c------------------------------------------------------------------
C     GETMAINPROBES GETS THE NUMBER AND NAMES OF EACH MAIN
C     PROBE TYPE
c------------------------------------------------------------------

      parameter (maxlevel=6000, maxparm=100, maxprobe=100)
      parameter (maxcalc=200)

      character*1 cchoice(maxlevel)
      character*11 ctype(maxprobe)
      character*80 text,text2

      character*80 filename  !- added by Todd 08-june-2000

      common /probes/ ctype

      dimension nopas(maxprobe), nprm(maxprobe,maxparm)
      dimension  nprec(maxcalc,maxprobe), npatot(maxparm)

      common /nopars/ nopas
      common /partype/ nprm
      common /parmord/ nprec
      common /totalparms/ npatot

      iyes=0
      call extraname('system/infofiles.dir'//CHAR(0),
     * 'probefile.d'//CHAR(0),filename)

      open(9,file=filename,status='old')
      read(9,'(a1)') text
      read(9,'(a1)') text
      read(9,*) nmain

      if ( mainprobe .gt. nmain ) then
       iyes=-1
       goto 4
      endif

      read(9,*) nparm

      do 10 nn=1,9
10     read(9,'(a1)') text

      do 15 nn=1,nparm
15     read(9,'(a1)') text

      do 20 nn=1,5
20     read(9,'(a1)') text

      do 25 nn=1,nmain

       call clearstring(text,80)
       read(9,'(a80)') text

       if ( nn .eq. mainprobe ) then

        call clearstring(text2,80)
        n3=0
        nspace1=0
        do 200 n2=2,80
         if ( nspace1 .eq. 0 .and. text(n2:n2) .ne. ' ' ) then
          n3=n3+1
          text2(n3:n3)=text(n2:n2)
         else
          nspace1=1
         endif
200     continue

        call findlastchar(nspc,text2,80)
        call findlastchar(nsp,ctype(jp),11) !- fixed (15-may-01 TOB)

        if ( nspc .eq. nsp .and. text2(1:nspc) .eq.
     *       ctype(jp)(1:nsp) ) then

         iyes=0

        else

         do 66 nb=1,nopas(jp)
          npatot(nprm(jp,nb))=npatot(nprm(jp,nb))-1
          nprm(jp,nb)=0
          nprec(nb,jp)=0
66       continue

         call readprobeinfo(jp,text,cchoice,ctype,nprm,nopas,
     *                      npatot,nprec,nparm0,0)
         iyes=1
         call findlastchar(nsp,ctype(jp),11) !- fixed (15-may-01 TOB)
c        ctype2=ctype(jp)(1:nsp)//CHAR(0)
         ctype(jp)(nsp+1:nsp+1)=CHAR(0)
         call cname2(ctype(jp),jp)

        endif

        goto 4

       endif

25    continue

4     close(9)

      return
      end




      SUBROUTINE GETTODAYSDATE(itodayyear,itodaymonth,itodayday)

c    gettodaysdate gets the year, month, day for the
c    present day from a file

      character*80 filename

      call clearstring(filename,80)
      call extraname('sys.inf'//CHAR(0),
     * 'today_is.txt'//CHAR(0),filename)
      open(9,file=filename,status='old')
  
      read(9,*) itodayyear,itodaymonth,itodayday

      close(9)

      return
      end
      SUBROUTINE GRID(rlat,rlon,lat,lon,space)
 
C    CALCULATES GRID NUMBERS FROM INPUT LATITUDE AND LONGITUDE
 
c************************************************************
c
c    Passed Variables:
c
c     rlat,rlon - actual latitude and longitude
c     lat,lon - calculated grid box numbers
c     space - grid spacing (1.0 is a 1 degree latitude
c             by one degree longitude grid box)
c
c***********************************************************

      double precision spaced
      spaced=(space*1.D+00)+1.D-07

c**********************************************************
c
c     Calculate latitude grid number:
c
c      1. add 90 to actual latitude, since actual latitudes
c         run from -90 to 90, and grid numbers run from
c         1 to 180.
c
c      2. Divide by spacing.  The additional 1E-7 is to
c         insure that any latitude right on the line between
c         two grid boxes will be included in the smaller 
c         number grid box.
c     
c      3. Add one, since a grid number for actual latitude
c         -90 would be 0 otherwise.
c
c**********************************************************

      lat=(((rlat*1.D+00)+(90.*1.D+00))/spaced)+1.D+00
 
c**********************************************************
c
c    Calculate longitude grid number
c
c     1. Longitude grid numbers run from 1 to 360 while
c        actual longitudes run from -180 to 180.  The difference
c        from latitude is that negative values are converted
c        to the larger end of longitude grid numbers.
c        They are converted to the values 181 to 360. 
c
c**********************************************************

      if (rlon.lt.0) then
       lon=(((rlon*1.D+00)+360.D+00)/spaced)+1.D+00
      else
       lon=((rlon*1.D+00)/spaced)+1.D+00
      endif
 
      return
      end

      subroutine gridset(idimgs0,idimge0,jdimgs0,jdimge0,idim,m,
     *                   igeo,igeofile,numprotot)
 
C     GRIDSET CONSTRUCTS A MASK OF ALL PROFILES WITHIN
C     THE BOUNDARIES OF USER INPUT LATITUDE AND LONGITUDE NUMBERS
C     WRITES THESE TO MASK AND SORTS THE MASK

C     NOW CAN ALSO CONSTRUCT A SURFACE FILE DATE MASK (IGEO=1)
C     SPECIAL CODE ADDED TO ACCOMODATE 1/10 DEGREE CLIMATOLOGY

c*********************************************************
c
c    Passed Variables:
c
c      idimgs - starting longitude number
c      idimge - ending longitude number
c      jdimgs - starting latitude number
c      jdimge - ending latitude number
c
c      idim - number of longitude spacings
c    
c      m - probe type
c      igeo - 0 = geographic masks
c             1 = surface probe date mask
c      igeofile = output mask file
c
c**********************************************************

c**********************************************************
c
c   Parameter:
c
c    maxmask - maximum number of masks
c
c**********************************************************

      parameter (maxmask=100,idim0=360)
      parameter (igeo1=436,igeo2=437)

c**********************************************************
c
c    Character Array:
c
c      filename - constructed file name
c
c**********************************************************

      character*80 filename

      idimgs=idimgs0
      idimge=idimge0
      jdimgs=jdimgs0
      jdimge=jdimge0
      idimx=idim

c**********************************************************
c
c     Open geomask.p the primary geographic sorting mask
c     and geomask.2 the secondary geographic sorting mask.
c
c      maskname constructs a file name
c        'xxxxx.x' - file name
c        0 - parameter code (zero is 'other')
c        filename- full filename (including directory structure)
c        m - probe code
c
c     fileopen opens the correct file:
c
c       filename - constructed file name
c       'rb+' - opening code meaning open file for binary
c               reading and writing.
c       igeo1,igeo2 - file identification number
c
c************************************************************

      if ( igeo .eq. 0 ) then
       if ( idim .eq. idim0 .or. idim/10 .eq. idim0 ) then

        if ( idim/10 .eq. idim0 ) then
         idimgs=idimgs/10+1
         idimge=idimge/10
         jdimgs=jdimgs/10+1
         jdimge=jdimge/10
         idimx=idim0
        endif

        call maskname('geomask.p'//CHAR(0),0,filename,m)
        call fileopen(filename,'rb+'//CHAR(0),igeo1)
 
        call maskname('geomask.2'//CHAR(0),0,filename,m)
        call fileopen(filename,'rb+'//CHAR(0),igeo2)
       else
        call maskname('geomask25.p'//CHAR(0),0,filename,m)
        call fileopen(filename,'rb+'//CHAR(0),igeo1)
 
        call maskname('geomask25.2'//CHAR(0),0,filename,m)
        call fileopen(filename,'rb+'//CHAR(0),igeo2)
       endif
      else
       call maskname('datemask.p'//CHAR(0),0,filename,m)
       call fileopen(filename,'rb+'//CHAR(0),igeo1)
 
       call maskname('datemask.2'//CHAR(0),0,filename,m)
       call fileopen(filename,'rb+'//CHAR(0),igeo2)
      endif
 
c************************************************************
c
c     For each individual grid box in the requested domain,
c     call georead to read in the profile record numbers for
c     the profiles in each grid box and write out the number
c     to the temporary file using writetomask.
c
c     georead:
c
c      i,j - longitude and latitude grid numbers
c      igridpos - record numbers of profiles in grid box
c      idim - number of longitude spacings
c      igeo - primary mask file identification number
c      igeo2 - secondary mask file identification number
c      igeofile - output mask file
c
c
c************************************************************

      numprotot=0

c     write(6,*) 'getting',jdimgs,jdimge,idimgs,idimge
      do 50 j=jdimgs,jdimge
      do 51 i=idimgs,idimge
 
       call georeadtomask(i,j, numpros,idimx, igeo1,igeo2, igeofile )
       numprotot=numprotot+numpros
c      write(6,*) 'xxy',i,j,numpros
 
51    continue
50    continue
 
c***********************************************************
c
c     Sort file by record number.
c
c      sortfile:
c
c      3 - structure indicator
c          0 - one real value
c          1 - two integer values
c          2 - one integer one real value
c          3 - one integer value
c      igeofile - file identification number
c      numprotot - number of structures to free space for
c************************************************************

      call sortfile(3,igeofile,numprotot)
 
c************************************************************
c
c     Close geographic sorting files
c
c************************************************************

      call onefileclose(igeo1)
      call onefileclose(igeo2)
 
      return
      end
      SUBROUTINE HAMON_mbtxbtmean(itsprobe,temp,maxlevel,maxcalc,
     * iwarm,nlevels,bmiss,depth,nbinmax,xmeanall)

C     CALCULATES MEAN TEMPERATURE DOWN TO GIVEN LEVEL FOR EACH
C     GIVEN DEPTH

c     read in delta fields

      parameter (maxbin=200)
      dimension xcount(maxbin)
      dimension xmeant(maxbin)
      dimension temp(maxlevel,maxcalc)
      dimension depth(maxlevel)


c     get means in five-meter bins

      depthmax=0.
      if (itsprobe .eq. 1) then
      nbinmax=20
      elseif (itsprobe .eq. 2) then
      nbinmax=40
      endif
      nbinout=0
      ip2=1

      do 25 k=1,maxbin
       xcount(k)=0.
       xmeant(k)=0.
25    continue

      do 35 k=1,nlevels

       if ( temp(k,ip2) .gt. bmiss .and.
     *      temp(k,ip2) .lt. 50. ) then
        nbin=(depth(k)/5)+1
c       write(6,*) 'xx',depth(k),nbin,maxbin,nbinmax
        if ( nbin .gt. maxbin ) goto 35
        if ( nbin .gt. nbinmax ) nbinmax=nbin
        xcount(nbin)=xcount(nbin)+1.
        xmeant(nbin)=xmeant(nbin)+temp(k,ip2)
       endif
c      write(6,*) 'bin',k,nbin,depth(k),xcount(nbin),
c    *  temp(k,ip2)

35    continue

      nbinout=nbinmax
      nfirst=0
      do 40 k=1,nbinout

        if ( xcount(k) .gt. 0. .and.
     *   nfirst .eq. 0 ) nfirst=k       
       if ( xcount(k) .gt. 1. ) then

        xmeant(k)=xmeant(k)/xcount(k)

       endif

40    continue

c    fill in up to surface

      do 45 k=1,nfirst-1
45     xmeant(k)=xmeant(nfirst) 

c     fill in missing bins

      do 50 k=nfirst+1,nbinout

       if ( xcount(k) .lt. 1. ) then

        k1=k-1

        k2=0
        do 75 kk2=k+1,nbinout
75       if ( k2 .eq. 0 .and. xcount(kk2)  .gt. 0. )
     *    k2=kk2

        d1=(k1-1)*5.
        d2=(k2-1)*5.
        d=(k-1)*5.
        xmeant(k)=xmeant(k1)+((d-d1)/(d2-d1))*(xmeant(k2)-xmeant(k1)) 
       endif
50    continue

c     write(6,*) 'here1'
      dtot=0
      xdep=0
      do 60 k=1,nbinout
      dtot=dtot+xmeant(k)
      xdep=xdep+1.
      xmeanall=dtot/xdep
60    continue
      if (itsprobe .eq. 1) then
      if (xmeanall .ge. 12.) then
       iwarm=1
      elseif (xmeanall .lt. 12.) then
       iwarm=0
      endif
      elseif (itsprobe .eq. 2) then
      if (xmeanall .ge. 10.) then
       iwarm=1
      elseif (xmeanall .lt. 10.) then
       iwarm=0
      endif
      endif
c     write(6,*)'xmeanall',xmeanall

      return
      end
      SUBROUTINE INPROBE(npro,nprotot,numpar,ireqpars,isoor)
      
C     INPROBE READS THE FILE PROBEFILE.D AND SETS THE DEFINING
C     PROBES AND PARAMETER INFORMATION FROM WHAT IT READS.  IT
C     ALSO GETS USER INPUT INFORMATION ON WHICH PROBES AND
C     PARAMETERS ARE TO BE INVESTIGATED IN THE MAIN PROGRAM.
      
c-----------------------------------------------------------------
c
c     Subroutine Steps:
c
c      1. Open probefile.d
c      2. Read in total number of probes and measured and
c         calculated parameters which reside in the system.
c      3. Extract measured parameter information.
c      4. Extract probe information.
c      5. Extract calculated parameter information.
c      6. Extract secondary header information
c      7. Extract biological parameter information
c
c-----------------------------------------------------------------

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c   Passed Variables:
c
c    npro -  number of requested probes
c    nprotot - total number of probes in probefile.d.
c    numpar - total number of measured parameters in probefile.d.
c    maxparm -maximum number of parameters system can hold.
c    ireqpars- number of requested measured parameters.
c    isoor - requested observed (0) or standard (1) levels.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c   Parameter:
c
c    maxcalc - maximu number of measured and calculated 
c              parameters allowed in OCL system.
c    maxparm - maximum number of measured parameters allowed in system
c    nprobe - maximum number of probes allowed in system.
c    maxlevel - maximum number of depth levels
c    maxkdim - maximum number of reference levels
c    noffset - offset between bio and sec headers from
c              set data
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      
      parameter (maxcalc=200,maxparm=100,nprobe=100)
      parameter (maxlevel=6000, maxkdim=137)
      parameter (noffset=200)
      
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c    Character Variables:
c
c     cparm - holder array used to read in probe data
c     cchoice - reads in user choices (marked with an 'x')
c     citf - 1-15 letter parameter name which is read from 
c            probefile.d and is used as the filename under
c            which actual parameter data is stored.
c     citf2 - 1-6 letter parameter abbreviation used to 
c             identify data in printed out profiles.
c     mtype - 1-3 letter parameter code used in auxilary
c             file names such as for analyzed data.
c     ctype - 1-11 letter probe name used in directory structure
c             of OCL system.
c     infile - name for correct probefile.d
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      character*1 cchoice(maxlevel),xchoice
      character*3 mtype(maxlevel),xmtype(maxcalc)
      character*6 citf2(maxlevel),xcitf2(maxcalc)
      character*7 initial
      character*11 ctype(nprobe)
      character*15 infile
      character*15 citf(maxlevel),xcitf(maxcalc)
      character*80 cparm,filename
      save initial

      dimension ip2(0:maxlevel),isurx(maxcalc)

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c    Common Blocks:
c
c     setchoice - choices about which set of data (which probefile.d)
c                 to use.  Contains isetnum, the data set number
c                 (0 corresponds to probefile.d, 1 to probefile1.d etc.)
c                 isetadd, the number to add to parameter
c                 codes for this data set (for using two data sets
c                 simultaneously), and isetadd2, the number to add
c                 to probe codes.
c     reqps - contains ip2, parameter codes for requested parameters.
c     parnames - contains citf (described under character variables)
c     parname1 - contains mtype (described above)
c     parname4 - contains citf2 (described above)
c     probes - contains ctype (described above)
c     surrogate - contains isur which keeps the code of the surrogate
c                 for a calculated parameter.  Surrogates are the
c                 least abundant measured parameter which goes into
c                 the calculating of the calculated parameter.  The
c                 calculated parameter will have the same record
c                 structure as its surrogate.
c     nopars - contains nopas, which keeps the number of parameters
c              measured by each probe.
c     partype - contains nprm, which contains, in order of appearance,
c               the parameters measured for each probe.
c     totalparms - contains npatot, which keeps the number of probes
c                  which measure each parameter.
c     depthcon - contains ixbt, which marks with a one all XBT probe 
c                types.
c     reqprobe - contains jp, which holds probe codes for requested
c                probes.
c     allprobe - contains jpm, which holds probe codes for requested
c                probes, including 'special use' probes, which are
c                marked with a 'y' instead of an 'x'
c     parmord - contains nprec, which holds the order of recording
c               of each parameter code, by probe
c     twoparm - contains itwo.  If a parameter is a biological 
c               parameter, this number is a two.  If a parameter
c               is a secondary header, this number is a one. 
c     extra - parameters other than measured physical and chemical
c             parameters, ireqpars2 = number of calculated parameters,
c             ireqsecond= number of requested second header parameters,
c             ireqbio=number of requested biological parameters
c     eachparm - contains the number of each type of parameter listed,
c                numpar=number of normal (physical and chemical plus
c                overall biological and overall second header)
c                parameters.  numcalc=number of calculated parameters.
c                numsecond=number of specific second header parameters.
c                numbio=number of specific biological parameters
c                numtax=number of taxonomic variables. numsecset is
c                number of parameter specific secod header sets. numtot2 is
c                the first possible code for second header 
c                parameters (minus one).  numtot3 is the first
c                possible code number for biological parameters
c                ntax - number of taxa in individual proflie
c                (minus one)
c     reflevs - contains nplv, the number of reference levels, and
c               dz2, the actual reference levels
c     calctype - contains ipx, the actual parameter codes for
c                each calculated parameter
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      common /setchoice/ isetnum,isetadd,isetadd2
      common /reqps/ ip2
      
      common /parnames/ citf
      common /parname1/ mtype
      common /parname4/ citf2
      common /probes/ ctype
      
      common /reqprobe/ jp(0:nprobe)
      common /allprobe/ jpm(0:nprobe),npromax
      common /nopars/ nopas(nprobe)
      common /partype/ nprm(nprobe,maxparm)
      common /parmord/ nprec(maxcalc,nprobe)
      common /totalparms/ npatot(maxparm)
      common /depthcon/ ixbt(nprobe)
      
      common /surrogate/ isur(maxcalc)
      common /twoparm/ itwo(0:maxparm)
      common /extra/ ireqpars2,ireqsecond, ireqbio
      common /eachparm/ numpars,numcalc,numsecond,numbio,
     *  numtax,numset,numtot2,numtot3,ntax,
     *  numsecset
c     nplv is the number of potential density surfaces
      common /reflevs/ nplv,dz2(maxkdim)
      common /calctype/ ipx(maxcalc)

      if ( initial .ne. 'inprobe' ) then
       initial='inprobe'
       npro=0
       ireqtots=0
       ireqpars2=0
       ireqpars=0
       ireqbio=0
       ireqsecond=0
       numpars=0
       numcalc=0
       numsecond=0
       numbio=0
       numset=0
       numtot2=0
       numtot3=0
       ntax=0
       numsecset=0
      endif
      
      ispace = 0                !- Linux init
      imiddle = 0
      ireqtot=0
      
c***********************************************************
c
c    If a previous data set has been read in, adjust the
c    order number for the second header parameter.
c
c***********************************************************
      
      do nc=1,nprobe
       nprec(ip2(maxlevel),jp(nc)) = 0
      enddo
       
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Open probefile.d.  This file contains all necessary information
c     on probes and parameters (measured and calculated) as well as
c     user input information on which probes and parameters to 
c     be investigated in the main program
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
       
      call clearstring(infile,15)
      if ( isetnum .eq. 0 ) then
       infile = './probefile.d'
      elseif ( isetnum .lt. 10 ) then
       infile(1:9) = 'probefile'
       write(infile(10:10),'(i1)') isetnum
       infile(11:12) = '.d'
      else
       infile(1:11) = './probefile'
       write(infile(12:13),'(i2)') isetnum
       infile(14:15) = '.d'
      endif
 
      open(10,file=infile,status='old')
      
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     This read statement, which will be repeated often,
c     skips text lines in probefile.d
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      read(10,'(/)')

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Read in number of probe types (nprotot) and number of
c     parameters, measured (numpar) and calculated (numcalc).
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      read(10,*) nprototx
      read(10,*) numparx
      read(10,*) numcalc

      if ( isetnum .eq. 0 ) then
       isetadd=0
       isetadd2=0
      endif

      numpar = numparx + isetadd
      nprotot = nprototx + isetadd2

      read(10,'(7(/))')

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Read in information about each measured parameter
c
c      cchoice is blank unless this parameter is to be investigated
c      in the main program.  Any mark will do, although an 'x' is
c      prompted for in the probefile.d text.
c
c      citf is a 15 letter parameter name which will be used
c      in the file name where data is stored
c
c      mtype is a 1-3 letter parameter code used in auxilary file
c      naming.
c
c      citf2 is a 1-6 letter parameter abbreviation used in 
c      identifying parameters in a printed out profile.   
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      call setforsurf(1,0)
      call setforsurf(2,0)
      call setforsurf(3,0)

      do 50 n=isetadd+1,numpar

       call clearstring(cchoice(n),1)
       call clearstring(citf(n),15)
       call clearstring(mtype(n),3)
       call clearstring(citf2(n),6)
       read(10,200) cchoice(n),citf(n),mtype(n),citf2(n)

c    Store lat,lon, and time variable locations in C
c    global variables

       call findlastchar(ny,citf(n),15)
 
       if ( ny .eq. 8 .and. citf(n)(1:ny) .eq. 'Latitude' )
     *  call setforsurf(1,n)
       if ( ny .eq. 9 .and. citf(n)(1:ny) .eq. 'Longitude' )
     *  call setforsurf(2,n)
       if ( ny .eq. 9 .and. citf(n)(1:ny) .eq. 'JulianDay' )
     *  call setforsurf(3,n)

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c      Check if this is a biological parameter.  If it is
c      the first three letters must be 'Bio'.  Assign the 
c      a two to itwo if this is a biological parameter
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

       if ( citf(n)(1:3).eq.'Bio') itwo(n)=2

       if ( cchoice(n).ne.' ' ) then

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c      If this is a chosen parameter, add one to the chosen
c      parameter counter (ireqpars) and record the code number
c      in ip2.  The code number is simply the order in which
c      the parameter is entered in probefile.d
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

        ireqpars=ireqpars+1
        ireqtots=ireqtots+1
        ip2(ireqpars)=n

       endif

50    continue

200   format(a1,a11,14x,a3,6x,a4)

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Add one more parameter, this is the secondary header
c     parameter, which, like the biology parameter, is a two
c     dimensional parameter.  Denote this by setting its itwo
c     to two.  All probes have this parameter.
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      itwo(numpar-isetadd) = 0

      numpars = numpar+1
      numpar = numpar+1

      call clearstring(citf(numpar),15)
      call clearstring(citf2(numpar),6)
      citf(numpar)='Header2'
      citf2(numpar)='Hed2'
      itwo(numpar)=1

      ip2(maxlevel)=numpar

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     As a safeguard against the listed number of parameters
c     being more than the input number of parameters (numpar),
c     lines will be continously read until the line containing
c     all '-' characters is found.  This is more important for the
c     probe types.
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

101   read(10,'(a1)') cparm

      if ( cparm(1:1) .ne. '-' ) goto 101

c************************************************************
c
c     Read in wheter observed or standard level data is to
c     be examined.  If there is a marker in front of
c     the standard level prompt, standard levels will be
c     examined, otherwise, observed levels will be examined.
c
c************************************************************

      read(10,'(/)') 

      read(10,'(a1)') cparm

      isoor=0
      if ( cparm(1:1).ne.' ') isoor=1

      read(10,'(a1)') cparm

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Read in information on probe types
c
c      cchoice is marked only if the probe type is to be
c      investigated in the main program.
c      ctype is the 11 character probe name used in the
c      directory structure of the data base.
c      nprm lists the parameters recorded by each probe type
c      in the order they are listed.
c
c      nproprev = the previous requested probe total ( if more
c      than one data set is being used).
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 

      nproprev = npro

      do 55 n=isetadd2+1,nprotot

       call clearstring(cparm,80)
       read(10,'(a80)') cparm

       cchoice(n)=cparm(1:1)

       call clearstring(ctype(n),11)
       ctype(n)=cparm(2:12)
       read(cparm(20:21),'(i2)') nopas(n)

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c      The parameters which a probe measures are listed by
c      code number, separated either by a ',', a space, or
c      a '-'.  A comma or a space just seperate two code numbers,
c      A hyphen means the probe measures each parameter whose
c      code number falls between the two values, including the
c      values themselves.
c
c      Since a code may be 1-3 digits, these digits must all
c      be read together to form a code.  So, the code is only read
c      when a comma, a space, or a hyphen is encountered.  The 
c      number of digits read is dependent on the distance between
c      hyphen, comma, and/or spaces.
c
c      Reading the codes continues until the number of parameters
c      measured by a probe (nopas) is reached.
c
c      Reset number of parameters (m) to zero
c
c      nspace is set to 24 because this is the space of the first
c      digit of parameter code in cparm.  nspace will be increased
c      as cparm is read.
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

       m=0
       nspace=24

56     if ( cparm(nspace+1:nspace+1).eq.',' .or.
     *  cparm(nspace+1:nspace+1).eq.' ') then 

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c      If a space or a comma is encountered, add one to the
c      parameter counter.  Read the parameter code according
c      to how many digits since the last comma or space (ispace).
c
c      Also increase nspace to the beginning of the next digit.
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

        m=m+1

        if ( ispace.eq.0 ) then

         read(cparm(nspace:nspace),'(i1)') nprm(n,m) 

        elseif ( ispace.eq.1 ) then

         read(cparm(nspace-1:nspace),'(i2)') nprm(n,m)

        elseif ( ispace.eq.2 ) then

         read(cparm(nspace-2:nspace),'(i3)') nprm(n,m)

        endif

        nspace=nspace+2

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c      If this digit is to the right of a hyphen (imiddle=2),
c      set nprm (parameter codes by probe) for each number
c      between the last code read in and the latest code
c      read in successively, including these outside code 
c      values.
c  
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

        if ( imiddle.eq.2 ) then

         npholds=nprm(n,m-1)
         npholde=nprm(n,m)

         m=m-1

         do 60 i=npholds+1,npholde

          m=m+1
          nprm(n,m)=i

60       continue

        endif
          
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Reinitialize ispace.
c     If the last code read in was to the left of a hyphen,
c     (imiddle=1), set imiddle to 2, since the next entered
c     code will be to the right of the hyphen.
c     Otherwise reinitialize imiddle.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

        ispace=0
        if ( imiddle.eq.1 ) then
         imiddle=2
        else
         imiddle=0
        endif

       elseif ( cparm(nspace+1:nspace+1).eq.'-' ) then

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     If the code to be entered is to the left of a hyphen,
c     record this information by making imiddle=1.  Also
c     change the hyphen to a comma so the code can be entered.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

        imiddle=1
        cparm(nspace+1:nspace+1)=','

       else

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Bump ispace and nspace up one since this code must have
c     more digits.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

        ispace=ispace+1
        nspace=nspace+1

       endif

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     If all codes have not been read, read the next code.
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

       if ( m.lt.nopas(n)) goto 56

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c      Add one to counter npatot, which counts how many probes
c      measure each parameter, for each parameter measured.
c
c      Also, invert nprm, that is, for each parameter, record
c      the order in which it was recorded.
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

       do 58 i=1,nopas(n)

        nprm(n,i) = nprm(n,i) + isetadd

        npatot(nprm(n,i))=npatot(nprm(n,i))+1

        nprec(nprm(n,i),n)=i

58     continue

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Set nprec and nprm for the second header
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      nprec(numpar,n)=nopas(n)+1
      nprm(n,nopas(n)+1)=numpar
 
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c      Check if this probe is an XBT type.  XBT probes
c      name code must start with a large or small x.  XBT's
c      need to have their depths corrected later.
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

       if ( ctype(n)(1:1).eq.'X' .or. ctype(n)(1:1).eq.'x') then

        ixbt(n)=1

       endif

c**********************************************************
c
c     Check if this is a surface probe (if probe starts
c     with SUR)
c
c**********************************************************

       if ( ctype(n)(1:3) .eq. 'SUR' .or.
     *      ctype(n)(1:3) .eq. 'sur' ) then
        call setsurfprobe(n,1)
       else
        call setsurfprobe(n,0)
       endif

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c      If this is a chosen probe, add one to chosen probes
c      (npro) and place the code in jp.  The code is simply
c      the order of listing in probefile.d.
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

       if ( cchoice(n).ne.' ') then

        if ( cchoice(n) .ne. 'y' ) then
         npro=npro+1
         jp(npro)=n
        endif

        npromax=npromax+1
        jpm(npromax)=n

       endif

55    continue

c***********************************************************
c
c    If a previous data set has been read in, adjust the
c    order number for the second header parameter.
c
c***********************************************************

      do 909 nc=1,nproprev
       nprec(ip2(maxlevel),jp(nc)) = nopas(jp(nc))+1
       nprm(jp(nc),nopas(jp(nc))+1) = ip2(maxlevel)
909   continue
     
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     As a safeguard against the listed number of probes
c     being more than the input number of probes (nprotot),
c     lines will be continously read until the line containing
c     all '-' characters is found.  This may be manipulated by
c     user to gain the proper auxilary file names. (See manual.)  
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

102   read(10,'(a1)') cparm

      if ( cparm(1:1) .ne. '-' ) goto 102

      read(10,'(3(/))')

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c    Read in calculated parameter information.  The information
c    is similiar to measured parameter data with the following 
c    differences.  For potential temperature and potential density
c    there are 33 and 34 categories respectively.  These correspond
c    to using the standard level represented by each number as
c    the reference level.  The 34th category for potential density
c    is in situ density.  citf and citf2 for these parameters are as
c    listed plus and ending of one or two digits corresponding to 
c    the reference level used.  To choose one or more potential
c    temperatures or densities to be investigated, place the number
c    of different reference levels to be investigated in the two spaces
c    to the left of the parameter name.  Between the dotted lines at
c    the bottom of probefile.d, enter the reference levels desired,
c    first potential temperature, then potential densities if some of
c    both are desired.  For other calculated parameters, simply place
c    an 'x' in the first column as before.  isur is the surrogate for
c    each measured parameter.  This is the least abundant measured 
c    parameter involved in the calculation of the parameter.  The file
c    structure of the calculated parameter will be the same as that of
c    the surrogate parameter.  So to look in potential temperature
c    files, salinity record numbers will be used.  The code number of
c    each calculated parameter is the number listed plus the total
c    number of measured parameters (numpar).
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c    Set potential temperature and potential density information.
c    (numpar+(1tonplv) and numpar+nplv+(1tonplv+1) codes respectively.
c
c    ipt and ipd are the number of potential temperature and potential
c    density parameters to be investigated in the main program.  The
c    actual code numbers are then listed below.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      call clearstring(xcitf(1),15)
      call clearstring(xmtype(1),3)
      call clearstring(xcitf2(1),6)
      call clearstring(xcitf(2),15)
      call clearstring(xmtype(2),3)
      call clearstring(xcitf2(2),6)
      read(10,240) ipt,xcitf(1),xmtype(1),xcitf2(1),isurx(1)
      read(10,240) ipd,xcitf(2),xmtype(2),xcitf2(2),isurx(2)

240   format(i2,a11,17x,a1,8x,a4,7x,i3)

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Set character variables for potential temperature and
c     potential density.  First call findchar to find the end
c     of each variable, then add the appropriate suffix.
c
c     findchar outputs the distance from the beginning of a 
c     character array to the first occurance of a character.
c     Here, n1 is the distance, the second variable is the array
c     in question, the third is the maximum length of a variable
c     and the last is the character to be searched for.  So the
c     length of an array is the distance -1 to the first space
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      call findlastchar(n1,xcitf(1),15)
      n1=n1+1
      call findlastchar(n2,xcitf2(1),4)
      n2=n2+1
      call findlastchar(n3,xmtype(1),3)
      n3=n3+1
      call findlastchar(n4,xcitf(2),15)
      n4=n4+1
      call findlastchar(n5,xcitf2(2),4)
      n5=n5+1
      call findlastchar(n6,xmtype(2),3)
      n6=n6+1

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c    Read in rest of calculated parameters.
c    First set the number of calculated parameters to ipt+ipd since
c    these parameters are evaluated first.
c    For each chosen parameter, set the values of the character
c    codes in the space for the code of the last measured code
c    entered plus the number of requested calculated parameters.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      ireqpars2=ipd+ipt
      ireqtots=ireqtots+ipd+ipt
      ipo=0

      do 75 n=3,numcalc


       call clearstring(xcitf(n),15)
       call clearstring(xmtype(n),3)
       call clearstring(xcitf2(n),6)
       read(10,250) xchoice,xcitf(n),xmtype(n),xcitf2(n),isurx(n)       

       if (xchoice .ne. ' ') then

        ireqpars2=ireqpars2+1
        ireqtots=ireqtots+1
        ipo=ipo+1
        nchoice=numpar+ipt+ipd+ipo
        ipx(ipt+ipd+ipo)=(2*nplv)+n-2
        ip2(ireqpars+ireqpars2)=nchoice
        call clearstring(citf(nchoice),15)
        call clearstring(mtype(nchoice),3)
        call clearstring(citf2(nchoice),6)
        citf(nchoice)=xcitf(n)
        mtype(nchoice)=xmtype(n)
        citf2(nchoice)=xcitf2(n)
        isur(nchoice)=isurx(n)
       
        do 98 np=1+isetadd2,nprotot
         nprec(nchoice,np)=nprec(isur(nchoice),np)
98      continue

       endif

75    continue

250   format(a1,1x,a11,17x,a1,8x,a4,7x,i3)

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Read in requested potential temperature and potential
c     density requested parameters.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      read(10,'(a80)') cparm

      do 70 i=1,ipt

       read(10,*) ichoice
       nchoice=numpar+i       
       ipx(i)=ichoice

       ip2(ireqpars+i)=nchoice

       call clearstring(citf(numpar+i),15)
       call clearstring(mtype(numpar+i),3)
       call clearstring(citf2(numpar+i),6)
       citf(numpar+i)=xcitf(1)
       citf2(numpar+i)=xcitf2(1)
       mtype(numpar+i)=xmtype(1)
       isur(numpar+i)=isur(1)
       do 199 np=1+isetadd2,nprotot
        nprec(nchoice,np)=nprec(isur(nchoice),np)
199     continue

       if ( ichoice.lt.10 ) then
        write(citf(numpar+i)(n1+1:n1+1),'(i1)') ichoice
        write(citf2(numpar+i)(n2+1:n2+1),'(i1)') ichoice
        write(mtype(numpar+i)(n3+1:n3+1),'(i1)') ichoice
       else
        write(citf(numpar+i)(n1+1:n1+2),'(i2)') ichoice
        write(citf2(numpar+i)(n2+1:n2+2),'(i2)') ichoice
        write(mtype(numpar+i)(n3+1:n3+2),'(i2)') ichoice
       endif

70    continue

      do 71 i=ipt+1,ipt+ipd

       read(10,*) ichoice
       nchoice=numpar+i       
       ipx(i)=ichoice

       ip2(ireqpars+i)=nchoice

       call clearstring(citf(numpar+i),15)
       call clearstring(mtype(numpar+i),3)
       call clearstring(citf2(numpar+i),6)
       citf(numpar+i)=xcitf(2)
       citf2(numpar+i)=xcitf2(2)
       mtype(numpar+i)=xmtype(2)
       isur(numpar+i)=isurx(2)
       do 99 np=1+isetadd2,nprotot
        nprec(nchoice,np)=nprec(isur(nchoice),np)
99     continue


       if ( ichoice .eq. 2*nplv+1 ) then
        call clearstring(citf(numpar+i),15)
        call clearstring(mtype(numpar+i),3)
        call clearstring(citf2(numpar+i),6)
        citf(numpar+i)='indensit'
        citf2(numpar+i)='IDen'
        mtype(numpar+i)='DIS'
        isur(numpar+i)=isurx(2)
       elseif ( ichoice-nplv.lt.10 ) then
        write(citf(numpar+i)(n4:n4),'(i1)') ichoice-nplv
        write(citf2(numpar+i)(n5:n5),'(i1)') ichoice-nplv
        write(mtype(numpar+i)(n6:n6),'(i1)') ichoice-nplv
       else
        write(citf(numpar+i)(n4:n4+1),'(i2)') ichoice-nplv
        write(citf2(numpar+i)(n5:n5+1),'(i2)') ichoice-nplv
        write(mtype(numpar+i)(n6:n6+1),'(i2)') ichoice-nplv
       endif

71    continue

c******************************************************
c
c    Store all calculated parameter identifiers at
c    the end of the requested list
c
c******************************************************

      do 72 ii=1,numcalc
       call clearstring(citf(numpar+ipt+ipd+ipo+ii),15)
       call clearstring(mtype(numpar+ipt+ipd+ipo+ii),3)
       call clearstring(citf2(numpar+ipt+ipd+ipo+ii),6)
       citf(numpar+ipt+ipd+ipo+ii)=xcitf(ii)
       mtype(numpar+ipt+ipd+ipo+ii)=xmtype(ii)
       citf2(numpar+ipt+ipd+ipo+ii)=xcitf2(ii)
       isur(numpar+ipt+ipd+ipo+ii)=isurx(ii)
72    continue

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Set the actual number of calculated parameters.  This
c     is the number (numcalc) which was read in + all the
c     rest of the potential temperature and potential density
c     parameters ((2*nplv)-2)+1 for in situ density
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      numcalc=ipt+ipd+ipo
      

c     read(10,'(a80)') cparm
c     read(10,'(a80)') cparm

      close(10)
      call extraname('sys.inf'//CHAR(0),
     * 'secbiofile.d'//CHAR(0),filename)
      open(10,file=filename,status='old')

      read(10,'(a80)') cparm

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c    Read in Secondary Header Information
c
c    The parameter numbers of secondary header information will
c    be nchoice + code number as listed in probefile.d
c
c    nchoice is set to maxcalc+maxparm+1.  This ensures that
c    second parameter code numbers will not change even when
c    measured and calculated parameters are added to the data
c    base
c
c    numsecond is the number of secondary header specific parameters
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      nchoice=maxparm+maxcalc+1

      read(10,*) numsecond

      do 85 n=1,numsecond

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c      Add one to the choice number and read in the next
c      specific second header parameter, including 
c      choice prefence, name, and maximum number of figures
c      in the parameter
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 

       nchoice=nchoice+1

       call clearstring(citf(nchoice),15)
       read(10,300) cchoice(nchoice),citf(nchoice)


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c      Set four letter parameter code to the first four letters
c      of the parameter name.
c
c      Set mtype to the parameter code
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

       call clearstring(citf2(nchoice),6)
       citf2(nchoice)=citf(nchoice)(1:4)

       call clearstring(mtype(nchoice),3)
       if ( nchoice.lt.10 ) then
        write(mtype(nchoice+n2)(1:1),'(i1)') nchoice
       elseif ( nchoice.lt.100 ) then
        write(mtype(nchoice)(1:2),'(i2)') nchoice
       else
        write(mtype(nchoice)(1:3),'(i3)') nchoice
       endif

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c      If this is a chosen parameter, add one to chosen second
c      header parameters, add one to total chosen parameters,
c      store the parameter code in ip2
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

       if ( cchoice(nchoice).ne.' ') then

        ireqsecond=ireqsecond+1
        ireqtot=ireqtot+1
        ip2(ireqtot)=nchoice

       endif


85    continue

104   read(10,'(a1)') cparm

      if ( cparm(1:1) .ne. '-' ) goto 104

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Read in Parameters Specific Set Information
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      nchoice=maxparm+maxcalc+noffset + 1

      read(10,'(a80)') cparm

      read(10,*) numset

      do 196 n=1,numset

       nchoice=nchoice+1

       call clearstring(citf(nchoice),15)
       read(10,300) cchoice(nchoice),citf(nchoice)
       call clearstring(citf2(nchoice),6)
       citf2(nchoice)=citf(nchoice)(1:4)

       call clearstring(mtype(nchoice),3)
       if ( nchoice.lt.10 ) then
        write(mtype(nchoice)(1:1),'(i1)') nchoice
       elseif ( nchoice.lt.100 ) then
        write(mtype(nchoice)(1:2),'(i2)') nchoice
       else 
        write(mtype(nchoice)(1:3),'(i3)') nchoice
       endif

       if ( cchoice(nchoice).ne.' ') then

        ireqset=ireqset+1
        ireqtot=ireqtot+1
        ip2(ireqtot)=nchoice

       endif

196   continue

114   read(10,'(a1)') cparm

      if ( cparm(1:1) .ne. '-' ) goto 114

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Read in Specific Biological Parameters
c
c     nchoice starts at maxparm + 2*maxcalc +1.  This ensures
c     that the addition of other parameters will not affect
c     the biology numbering system.
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      nchoice=(2*maxparm)+maxcalc+noffset+1

      read(10,'(a80)') cparm

      read(10,*) numbio

      do 95 n=1,numbio

       nchoice=nchoice+1

       call clearstring(citf(nchoice),15)
       call clearstring(citf2(nchoice),6)
       call clearstring(mtype(nchoice),3)
       citf2(nchoice)=citf(nchoice)(1:4)
       read(10,300) cchoice(nchoice),citf(nchoice)

       if ( nchoice.lt.10 ) then
        write(mtype(nchoice)(1:1),'(i1)') nchoice
       elseif ( nchoice.lt.100 ) then
        write(mtype(nchoice)(1:2),'(i2)') nchoice
       else 
        write(mtype(nchoice)(1:3),'(i3)') nchoice
       endif

       if ( cchoice(nchoice).ne.' ') then

        ireqbio=ireqbio+1
        ireqtot=ireqtot+1
        ip2(ireqtot)=nchoice

       endif

95    continue

300   format(a1,3x,a15)

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Read in Biological Taxa Parameters
c
c     nchoice starts at the end of the biological parameters
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      nchoice=(2*maxparm)+maxcalc+(2*noffset) + 1

      read(10,'(a80)') cparm

      read(10,*) numtax

      do 96 n=1,numtax

       nchoice=nchoice+1

       call clearstring(citf(nchoice),15)
       call clearstring(citf2(nchoice),6)
       call clearstring(mtype(nchoice),3)
       read(10,300) cchoice(nchoice),citf(nchoice)
       citf2(nchoice)=citf(nchoice)(1:4)

       if ( nchoice.lt.10 ) then
        write(mtype(nchoice)(1:1),'(i1)') nchoice
       elseif ( nchoice.lt.100 ) then
        write(mtype(nchoice)(1:2),'(i2)') nchoice
       else 
        write(mtype(nchoice)(1:3),'(i3)') nchoice
       endif

       if ( cchoice(nchoice).ne.' ') then

        ireqbio=ireqbio+1
        ireqtot=ireqtot+1
        ip2(ireqtot)=nchoice

       endif

96    continue

      close(10)
     
      isetadd = numpar - 1
      isetadd2 = nprotot

      return
      end
      SUBROUTINE INPUT( npro, ireqpars, isoor )
      
C     INPUT IS THE MAIN INPUT PROGRAM FOR THE OCEAN CLIMATE
C     LABORATORY DATA ACCESS SYSTEM.  IT TAKES INFORMATION ON
C     THE PROBES AND PARAMETERS INCLUDED IN THE SYSTEM FROM
C     PROBEFILE.D.  IT GETS INFORMATION ON WHICH PROBES AND
C     PARAMETERS ARE BEING INVESTIGATED FROM CHOICEFILE.D. 
C     IT OBTAINS CALCULATED PARAMETER INFORMATION FROM 
C     CALCFILE.D.  ALL THIS INFORMATION IS SENT EITHER TO THE
C     MAIN PROGRAM, OR TO GLOBAL C VARIABLES, OR FORTRAN 
C     COMMON BLOCKS.  NECESSARY FILES FOR THIS SUBROUTINE TO
C     RUN PROPERLY ARE PROBEFILE.D, CHOICEFILE.D, AND CALCFILE.D.
C     
C     INPUT IS A UNIVERSAL INPUT PROGRAM FOR THE OCL SYSTEM
C     AND THEREFORE CONTAINS MUCH DATA THAT WILL NOT BE USED
C     IN MANY APPLICATIONS.

c------------------------------------------------------------
c
c     Subroutine Steps:
c
c      1. Set interpolation intervals
c         (FORTRAN subroutine setdel)
c      2. Set standard depths
c         (FORTRAN subroutine setstandeps)
c      3. Get overall information about parameters and probes
c         in the system from probefile.d.
c         (FORTRAN subroutine inprobe)
c      4. Get user input information on what probes and parameters
c         are to be investigated from probefile.d.
c         (FORTRAN subroutine inprobe)
c      5. Get user input information on calculated parameters from
c         probefile.d. (FORTRAN subroutine inprobe)
c      6. Set global C variables. (FORTRAN subroutine setglobal)
c
c------------------------------------------------------------

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c    Passed Variables:
c
c     npro - number of probes to be investigated in main program
c     ireqpars - number of parameters to be investigated
c     isoor - observed (0) or standard (1) level profiles to
c             be investigated
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c   Parameters:
c
c    kdim - number of standard depth levels
c    maxparm - maximum number of parameters
c    nprobe - maximum number of probes
c    maxcalc - maximum number of measured parameters plus
c              calculated parameters
c    maxlevel - maximum number of depth levels
c    maxcc - maximum number of NODC country codes
c    noffset - offset from biological (second header) data
c              for taxa (parameter specific) sets
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      parameter (kdim=40,maxparm=100,nprobe=100,maxcalc=200)
      parameter (maxlevel=6000,maxcc=200,noffset=200)
      parameter (maxkdim=137)
      
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c   Character Variables:
c
c    citf - 1-15 letter parameter names, used to name main files in
c           OCL directory structure.
c    citf2 - 1-6 letter parameter names, used to identify data in
c            written (ASCII) profiles.
c    ctype - 1-11 letter probe abbreviation, used to name directories
c            in OCL directory structure.
c    mtype - 1-3 letter parameter code, used for auxilary file names
c            for applications, such as analyzed data.
c    ncc - all NODC country codes
c
c    actionrec - string passed to mergelocking system
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      character citf*15,ctype*11,citf2*6,mtype*3
      character ncc*2
 
      character*15 actionrec
c     character*35 cPROGrec
 
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c    Arrays:
c
c     ip2 - numerical parameter codes (as enumerated in probefile.d)
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 
      dimension ip2(0:maxlevel)

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c   Common Blocks:
c
c     setchoice - choices about which set of data (which probefile.d)
c                 to use.  Contains isetnum, the data set number 
c                 (0 corresponds to probefile.d, 1 to probefile1.d etc.)
c                 and isetadd, the number to add to parameter
c                 codes for this data set (for using two data sets
c                 simultaneously).
c     reqps - contains ip2, parameter codes for requested parameters
c     dels - inside (del) and outside (del2) limits for 
c            distances from a standard depth at which a value
c            may be used for interpolation to standard levels.
c     levels - contains standeps, depth (meters) of standard levels
c     parnames - contains citf, 1-15 letter parameter names
c     parname4 - contains citf2, 1-6 letter parameter names
c                used in writing out individual profiles.
c     parname1 - contains mtype, 1-3 letter parameter code used
c               in making file names for analyses and other applications.
c     probes - contains ctype, 1-11 letter probe names
c     nopars - contains nopas, thenumber of parameters a probe
c               measures
c     partype - contains nprm, the parameters which 
c               a probe measures, in probefile.d
c     parmord - contains nprec, the order in which a parameter is
c               listed for a probe in probefile.d.
c     reqprobe - contains jp, probe code (from probefile.d)
c                of requested probes
c     allprobe - contains jpm, which holds probe codes for requested
c                probes, including 'special use' probes, which are
c                marked with a 'y' instead of an 'x'
c     totalparm - contains npatot, number of probes which measure
c                 each type of parameter
c     surrogate - contains isur, which type of measured parameter
c                 is used to look at calculated parameters.  For
c                 example, temperature records would be used
c                 to look at potential temperature values, while
c                 oxygen records would be used to look at
c                 AOU values.
c     extra - contains ireqpars2, number of calculated parameters
c             which are being investigated.  Also contains ireqsecond
c             which is number of requested second header parameters,
c             and ireqbio, which is number of requested biological
c             parameters.
c     eachparm - contains number of each type of parameter.
c                numpar - number of measure parameters
c                numcalc - number of calculated parameters
c                numsecond - number of second header parameters
c                numbio - number of biological parameters
c                numset - number of second header parameter specific
c                         variables
c                numtaxa - number of taxa variables
c                numtot2 - number of first possible second header
c                          parameter minus one
c                numtot3 - number of first possible biological
c                          parameter minus one
c                ntax - number of taxa in individual profile
c                numsecset - number of second header parameter specific
c                            sets
c     twoparm - contains itwo.  If itwo is equal to 2 for a
c               parameter, it is the biological parameter.  If itwo
c               is equal to 1, it is the second header parameter.
c
c     depthcon - contains ixbt, marks whether a probe is of the 
c                XBT type and must have its depths corrected.
c                To include a probe in this list, its probe name must
c                start with an 'X' or an 'x'.
c     totprobes - total number of probes
c     countryc - all NODC country codes
c     reflevs - contains nplevs, the number of reference levels,
c               and dz2, the actual reference levels
c     calctype - contains ipx, the actual parameter codes for
c                each calculated parameter
c
c     ilockact  - 0=casual, 1=read-only, 2=exclusive
c     ilocknum  - number of probes to lock-check against (usually "0")
c     actionrec - string passed to mergelocking system
c
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
     
      common /setchoice/ isetnum,isetadd,isetadd2
      common /reqps/ ip2
      common /dels/ del(0:kdim),del2(0:kdim)
      common /levels/ standeps(kdim)
      common /parnames/ citf(maxlevel)
      common /parname1/ mtype(maxlevel)
      common /parname4/ citf2(maxlevel)
      common /probes/ ctype(nprobe)
      common /nopars/ nopas(nprobe)
      common /partype/ nprm(nprobe,maxparm)
      common /parmord/ nprec(maxcalc,nprobe)
      common /reqprobe/ jp(0:nprobe)
      common /allprobe/ jpm(0:nprobe),npromax
      common /totalparms/ npatot(maxparm)
      common /surrogate/ isur(maxcalc)
      common /extra/ ireqpars2,ireqsecond,ireqbio
      common /eachparm/ numpar,numcalc,numsecond,numbio,
     *     numtaxa,numset,numtot2,numtot3,ntax,numsecset
      common /twoparm/ itwo(0:maxparm)
      common /depthcon/ ixbt(nprobe)
      common /totprobes/ nprotot
      common /countryc/ ncc(maxcc)
      common /reflevs/ nplevs,dz2(maxkdim)
      common /calctype/ ipx(maxcalc)
      common /iMlockACT/ ilockact
      common /iMlockNUM/ ilocknum
      common /cMlockTXT/ actionrec
      
      data nplevs,dz2/ 11, 0.,500.,1000.,1500.,2000.,2500.,
     *                 3000.,3500.,4000.,4500.,5000.,126*0./

      ireqex = 0 
      isetnum=0
      isetadd=0
      isetadd2=0

c***********************************************************
c
c   Check to see if an alternate database is requested
c   (value of ialterbase is >0)
c
c***********************************************************

c       write(6,*) 'mainb'
      call changemainbranch(ialterbase)
c       write(6,*) 'mainb'

c***********************************************************
c
c   Initialize file tracking
c
c    maxfile = maximum number of files
c
c***********************************************************

      call zeroftrack(maxfile)
c     write(6,*) '#1'

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c    Read in the standard depths which correspond to each
c    standard level. 
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      call setstandeps(standeps)
c     write(6,*) '#2'

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Set del and del2.  These are the limits of distance
c     from a standard level at which observed values exist
c     which may be used for interpolation to standard levels
c     del is for the two inside values, del2 for the two outside
c     values.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      call setdel(kdim,dz,del,del2)
c     write(6,*) '#3'

c*****************************************************
c
c    Set country codes
c
c*****************************************************

      call countrycode
c     write(6,*) '#4'

c***********************************************************
c
c     See which data set is being investigated
c
c***********************************************************

      iostat=0
      open(10,file='./setchoice.d',status='old',iostat=ios)
      if ( ios .eq. 0 ) then
       read(10,*,iostat=ios) isetnum
       close(10)
       if ( ios .ne. 0 ) isetnum=0
      endif

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Get probe information from probefile.d
c    
c      npro is the number of requested probes
c      nprotot is the number of probes in the system,
c      numax is the number of parameters presently in the system.
c
c     This is the information on the makeup of the OCL system,
c     what probes are in the system, what parameters are in the
c     system and which probes measure which parameters, along with
c     other minor information such as first year of probe use, maximum
c     depth a probe measures, course ranges for parameters.
c   
c     Also input here is information on the file structure fo the
c     OCL system, the four letter codes for probes and the 15 letter
c     names for parameters which make up the directory structure of
c     the system.  Minor coding is also found here, 4 letter parameter
c     abbreviations used in writing out profiles and 1 letter parameter
c     abbreviations used in making file names for later applications
c     such as analyses.
c
c
c     Common Blocks set here:
c
c      parnames - 1-15 letter parameter names
c      parname4 - 1-6 letter parameter names
c      parname1 - 1-3 letter parameter names
c      probes - 1-11 letter probe names
c      nopas - number of parameters a probe measures
c      partype - order of recording of a parameter for each probe
c      totalparms - total number of probes which record a parameter
c      depthcon - probes which need the XBT depth correction
c
c
c     Also get user input from probefile.d.  This consists of whether
c     the user wants to investigate standard or observed levels,
c     and what parameters and probes are to be investigated.
c
c     numax - number of parameters presently in system
c     npro - number of probes to be investigated
c     ireqpars - number of parameters to be investigated
c     isoor - observed (0) or standard levels (1) to be looked at
c
c     Common Blocks Set:
c
c     jp - code numbers (order of probes in probefile.d) for
c          probes to be investigated (common block reqprobe).
c
c
c     Finally, set calculated parameter variables.
c     by reading information from probefile.d and putting
c     the codes of calculated parameters into ip2. 
c
c     ireqpars2 - number of requested calculated parameters
c
c
c     Common Blocks Set
c
c      reqps - contains ip2 which holds parameter codes for
c              requested parameters.
c      isur - surrogate for calculated parameter.  A surrogate
c             is a measured parameter from which information is
c             drawn about a calculated parameter.  So if one needed
c             information on Apparent Oxygen Utilization (AOU), the
c             surrogate is oxygen.  This is because of the three
c             measured parameters needed for calculating AOU,
c             temperature, salinity, and oxygen, oxygen is the least
c             measured, so AOU values will most closely correspond 
c             with oxygen values.  So to investigate AOU, oxygen record
c             numbers are used.
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      call inprobe(npro,nprotot,numax,ireqpars,isoor)
c     write(6,*) 'inprobe'
      
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c    Set number of first possible second header parameter and
c    number of first possible biological parameter.
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      numtot2=maxparm+maxcalc+1
      numtot3=(2*maxparm)+maxcalc+noffset+1
 
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Set needed names globally in C using setglobal.  Setting
c     all the parameter names, abbreviations, and codes, along
c     with the probe codes precludes having to carry these names
c     into the main program and send them back out to the C 
c     subroutines.  These characters are very important because
c     they are used to find the correct files in the OCL directory
c     structure.
c
c     ireqpars+ireqpars2 is the total number of requested parameters
c     ip2 are the parameters codes, they are given to setglobal in
c     common block reqps.
c     nprotot is the total number of probes in system.
c
c     Common Blocks sent are all character variable common blocks,
c      parname,parname1,parname4, and, ctype.
c
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 
 
      if ( ireqpars2 .gt. 0 ) 
     * call calcneedset(ip2,maxlevel,numpar,ireqpars,
     * ireqpars2,ireqex) 
      call setglobal(ireqpars+ireqpars2+ireqex,ireqex,nprotot)

C     GETMAINPROBE SUBSTITUTES THE CORRECT MAIN PROBE TYPE
C     FOR THE FIRST MARKED PROBE.
C   
C     THIS IS ONLY DONE IF FILE DUM.MAINPROBE EXISTS AND
C     CONTAINS A VALID VALUE

      if ( actionrec(1:11) .ne. 'hasdupefile' ) then

       open(9,file='./dum.mainprobe',status='old', iostat=ios)

       if ( ios .eq. 0 ) then

        read(9,*) mainprobe
        close(9)

        call getmainprobe(iyes,mainprobe,jp(1),numax-1)

        endif

c*****************************************************************
c
c    If file dum.mainprobe exists, the designated mainprobe will
c    be substituted for the given first probe. 
c
c*****************************************************************

       call mainprober(npro,numax-1)

      endif

c************************************************************
c
c   Special for monthly retrievals:
c    only one probe will be selected, the probe number found
c    in file probechoice.retrieve.  This file should only
c    exist if the monthly retrievals are being run
c
c************************************************************

      open(9,file='./probechoice.retrieve',status='old',
     *  iostat=ios2 )

      if ( ios2 .eq. 0 ) then
       read(9,*) iprobechoice
       close(9)
       open(9,file='./retrievestop.d',status='unknown')
       if ( iprobechoice .gt. nprotot ) then
        write(9,*) 1
        close(9)
        stop
       else
        write(9,*) 0
        close(9)
       endif
       jp(1)=iprobechoice
       npro=1
       npromax=1
      endif

c     Check main probes, locks, update lock status information
      ilockup=0
      iverb=1
c     write(6,*) 'master'
      call masterlock(jp,maxprobe,npro,ilockact,actionrec,
     * ilocknum,iverb,ilockup)
c     write(6,*) 'master'

c     Update action log
      call updateactionlog(jp,maxprobe,npro,actionrec,ilockact,
     * ilocknum)
c     write(6,*) 'update'

c--------------------------------------------------------------------
 
      return
      end

      SUBROUTINE INSERTFOR2000(nn,c,file,maxchar)

c     INSERTFOR2000 INSERTS A LETTER IN PLACE OF
C     THE FIRST DIGIT FOR YEARS GREATER THAN 1999.
C     IN A DESIGNATED SPOT IN A FILE NAME.

C     nn - input full year/output one digit representing
c          second digit of year
c     character to replace
c     file - full file name

C     EXAMPLES:  FOR FILE OF FORM YEARNN.DATA, WHERE
C      NN=LAST TWO DIGITS OF YEAR
C       input nn=1999, c=N, file=YEARNN.DATA
C       output nn=1999, c=N, file=YEARNN.DATA
C 
C       input nn=2002, c=N, file=YEARNN.DATA
C       output nn=2, c=N, file=YEARAN.DATA
C      
C       input nn=2011, c=N, file=YEARNN.DATA
C       output nn=1, c=N, file=YEARBN.DATA 

      character*(*) file
      character*1 c
      character*1 cadd(0:9)

      data cadd/'A','B','C','D','E','F','G','H','I','J'/

      if ( nn .le. 1999 ) then
       nn=nn-1900
      else
       n2=nn-2000
       nx=n2/10
       call findchar(nadd,file,maxchar,c)
       if ( nadd .le. maxchar) file(nadd:nadd)=cadd(nx)
       nn=n2-(nx*10)
      endif

      return
      end

      SUBROUTINE INSERTNUM(crep,nrep0,chars,maxchar)

C     INSERTNUM REPLACES A GIVEN CHARACTER WITH THE
C     CORRESPONDING NUMBER

c***************************************************
c
c    Passed Variables:
c
c     crep - character to be replaced
c     nrep0 - number to replace character
c     chars - character string in which replacement will occur
c     maxchar - maximum number of characters in chars
c
c****************************************************

      character*1 crep
      character*4 cform
      character*(*) chars

      data cform /'(iX)'/

      inegative=0
      nrep=nrep0

      if ( nrep .lt. 0 ) then
       nrep=-nrep
       inegative=1
      endif

c****************************************************
c
c   Locate first occurance of character to be changed
c
c****************************************************

      do 50 nn=1,maxchar

       if ( chars(nn:nn) .eq. crep ) then

c****************************************************
c
c   Locate last occurance of character to be changed
c
c****************************************************

        do 51 n2=nn+1,maxchar
51       if ( chars(n2:n2) .ne. crep ) goto 52
52      n2=n2-1

        nchar=(n2-nn)+1
        nten=10**(nchar-inegative)

c******************************************************
c
c   Check that there is sufficient room to write given
c   number
c
c******************************************************

        if ( nten+inegative .le. nrep ) then
         write(6,800) 'Given number (',nrep0,
     * ') is larger than space to be',
     * ' written to'
800      format(a14,i3,a28,a11)
         return
        endif

        nadd=0
        if ( inegative .eq. 1 ) then
         chars(nn:nn)='-'
         inegative=0
         nadd=1
        endif

c*****************************************************
c
c   Enter necessary trailing zeros
c
c****************************************************
        do 60 n3=2,nchar
         nten=nten/10
         if ( nrep .lt. nten ) then
          chars(nn+nadd:nn+nadd)='0'
          nadd=nadd+1
         endif
60      continue

c*****************************************************
c
c   Enter number
c
c*****************************************************

        write(cform(3:3),'(i1)') nchar-nadd
        write(chars(nn+nadd:nn+nchar-1),cform) nrep

        return

       endif

50    continue
       
      return
      end 
      SUBROUTINE INSERTNUMEXPAND(crep,nrep0,chars,maxchar)

C     INSERTNUM REPLACES A GIVEN CHARACTER WITH THE
C     CORRESPONDING NUMBER

C     THIS VERSION EXPANDS A CHARACTER STRING IF THE
C     GIVEN NUMBER IS BIGGER THAN SPACE PROVIDED.

c***************************************************
c
c    Passed Variables:
c
c     crep - character to be replaced
c     nrep0 - number to replace character
c     chars - character string in which replacement will occur
c     maxchar - maximum number of characters in chars
c
c****************************************************

      character*1 crep
      character*4 cform
      character*500 file1,file2
      character*(*) chars

      data cform /'(iX)'/

      inegative=0
      nrep=nrep0

      if ( nrep .lt. 0 ) then
       nrep=-nrep
       inegative=1
      endif

c****************************************************
c
c   Locate first occurance of character to be changed
c
c****************************************************

      do 50 nn=1,maxchar

       if ( chars(nn:nn) .eq. crep ) then

c****************************************************
c
c   Locate last occurance of character to be changed
c
c****************************************************

        do 51 n2=nn+1,maxchar
51       if ( chars(n2:n2) .ne. crep ) goto 52
52      n2=n2-1

        nchar=(n2-nn)+1
        nten=10**(nchar-inegative)

c******************************************************
c
c   Check that there is sufficient room to write given
c   number
c
c******************************************************

        if ( nten+inegative .le. nrep ) then

         nrep2=1
         nten2=nten
         do 75 n3=1,10
          nten2=nten2*10
          if ( nten2+inegative .le. nrep ) nrep2=nrep2+1 
75       continue

c    Expand

         file1=chars(1:n2)
         file2=chars(n2+1:maxchar)
         nend=(maxchar-n2)-nrep2
        chars(1:n2)=file1(1:n2)
        chars(n2+nrep2+1:maxchar)=file2(1:nend)

        nchar=nchar+nrep2+inegative
       endif
        write(6,*) 'nten2',nten,inegative,nrep

        nadd=0
        if ( inegative .eq. 1 ) then
         chars(nn:nn)='-'
         inegative=0
         nadd=1
        endif

c*****************************************************
c
c   Enter necessary trailing zeros
c
c****************************************************
        do 60 n3=2,nchar
         nten=nten/10
         if ( nrep .lt. nten ) then
          chars(nn+nadd:nn+nadd)='0'
          nadd=nadd+1
         endif
60      continue

c*****************************************************
c
c   Enter number
c
c*****************************************************

        write(cform(3:3),'(i1)') nchar-nadd
        write(chars(nn+nadd:nn+nchar-1),cform) nrep

        return

       endif

50    continue
       
      return
      end 
      SUBROUTINE INSERTNUMsp(crep,nrep0,chars,maxchar)

C     INSERTNUM REPLACES A GIVEN CHARACTER WITH THE
C     CORRESPONDING NUMBER.

C     THIS VERSION ENTERS SPACES INSTEAD OF ZEROS
C     FOR PLACEHOLDERS

c***************************************************
c
c    Passed Variables:
c
c     crep - character to be replaced
c     nrep0 - number to replace character
c     chars - character string in which replacement will occur
c     maxchar - maximum number of characters in chars
c
c****************************************************

      character*1 crep
      character*4 cform
      character*(*) chars

      data cform /'(iX)'/

      inegative=0
      nrep=nrep0

      if ( nrep .lt. 0 ) then
       nrep=-nrep
       inegative=1
      endif

c****************************************************
c
c   Locate first occurance of character to be changed
c
c****************************************************

      do 50 nn=1,maxchar

       if ( chars(nn:nn) .eq. crep ) then

c****************************************************
c
c   Locate last occurance of character to be changed
c
c****************************************************

        do 51 n2=nn+1,maxchar
51       if ( chars(n2:n2) .ne. crep ) goto 52
52      n2=n2-1

        nchar=(n2-nn)+1
        nten=10**(nchar-inegative)

c******************************************************
c
c   Check that there is sufficient room to write given
c   number
c
c******************************************************

        if ( nten+inegative .le. nrep ) then
         write(6,800) 'Given number (',nrep0,
     * ') is larger than space to be',
     * ' written to'
800      format(a14,i3,a28,a11)
         return
        endif

c*****************************************************
c
c   Enter necessary trailing zeros
c
c****************************************************
        nadd=0
        do 60 n3=2,nchar-inegative
         nten=nten/10
         if ( nrep .lt. nten ) then
          chars(nn+nadd:nn+nadd)=' '
          nadd=nadd+1
         endif
60      continue

        if ( inegative .eq. 1 ) then
         chars(nn+nadd:nn+nadd)='-'
         nadd=nadd+1
        endif

c*****************************************************
c
c   Enter number
c
c*****************************************************

        write(cform(3:3),'(i1)') nchar-nadd
        write(chars(nn+nadd:nn+nchar-1),cform) nrep

        return

       endif

50    continue
       
      return
      end 
      SUBROUTINE INSERTYEAR(nn,c,file,maxchar)

C     INSERTYEAR INSERTS THE LAST TWO DIGITS OF A YEAR
C     FOR THE GIVEN CHARACTER

c     nn - year (may be four digit form or two digit form)
c     c - character to replace
c     file - file name for replacement
c     maxchar - characters in file

      character*1 c
      character*(*) file
  
      n=nn
      if ( nn .lt. 200 ) n=n+1900
      call insertfor2000(n,c,file,maxchar)
      call insertnum(c,n,file,maxchar)

      return
      end
      FUNCTION ISMAINPROBE(probename)

C     ISMAINPROBE CHECKS IF THE GIVEN PROBE IS A MAIN PROBE

      parameter (maxprobe=100)
      character*11 ctypemain(maxprobe),probename
      character*11 firsttime
      dimension nspm(maxprobe)

      save firsttime,ctypemain
      save nmain,nspm

      if ( firsttime .ne. 'ismainprobe' ) then
       call readmainprobes(ctypemain,maxprobe,nmain)
       do 45 nn=1,nmain
45      call findlastchar(nspm(nn),ctypemain(nn),11)
       firsttime='ismainprobe'
      endif

      ismainprobe=0
      call findlastchar(nsp,probename,11)

      do 50 n=1,nmain

       if ( nsp .eq. nspm(n) .and.
     *  probename(1:nsp) .eq. ctypemain(n)(1:nsp) )
     *  ismainprobe=1

50    continue

      return
      end
      SUBROUTINE ISSURF(isurf,m,latindex,lonindex,itimeindex)

C  ISSURF CHECKS IF THIS PROBE IS A SURFACE-ONLY PROBE
C  THE PRESENT WAY TO DO THIS IS TO SEE IF THE PROBE
C  MEASURES LATITUDE, LONGITUDE, AND JULIAN DAY 

c*********************************************************
c
c   Passed Variables:
c
c    isurf - 0= not surface-only
c            1= surface only
c    m - probe code
c    latindex - latitude parameter code
c    lonindex - longitude parameter code
c    itimeindex - julian day parameter code
c
c**********************************************************

      parameter (maxcalc=200, maxprobe=100)
      common /parmord/ nprec(maxcalc,maxprobe)

      latindex=0
      lonindex=0 
      itimeindex=0

      call getforsurf(1,latindex)
      call getforsurf(2,lonindex)
      call getforsurf(3,itimeindex)
c     if ( latindex .eq. 0 ) call getforsurf(1,latindex)
c     if ( lonindex .eq. 0 ) call getforsurf(2,lonindex)
c     if ( itimeindex .eq. 0 ) call getforsurf(3,itimeindex)

      isurf=0
      isurfx=0

      call getsurfprobe(m,isurfx)
      if ( latindex .gt. 0 .and. lonindex .gt. 0 .and.
     *     itimeindex .gt. 0 .and. nprec(latindex,m) .gt. 0 .and.
     *     nprec(lonindex,m) .gt. 0 .and.
     *     nprec(itimeindex,m) .gt. 0 .and. isurfx .eq. 1) isurf=1

      return
      end
      FUNCTION ISTSK(iprobe)

C     ISTSK RETURNS 1 if this is a TSK XBT, 0 OTHERWISE

      ISTSK=0
      if ( iprobe .eq. 215 .or. iprobe .eq. 216 .or.
     *     iprobe .eq. 217 .or. iprobe .eq. 219 .or.
     *     iprobe .eq. 220 .or. iprobe .eq. 232 .or.
     *     iprobe .eq. 233 .or. iprobe .eq. 462 .or.
     *     iprobe .eq. 606 .or. iprobe .eq. 607 .or.
     *     iprobe .eq. 608 .or. iprobe .eq. 609 .or.
     *     iprobe .eq. 610 ) then
       ISTSK=1
      endif

      return
      end
      SUBROUTINE JULIANt(iyear0,iyear,month,iday,time,itimesig,
     *                   xjulian,jsig)

C    COMPUTES JULIAN DAY, INCLUDING TIME, WITH RESPECTS
C    TO MIDNIGHT JANUARY 1 OF THE BASE YEAR

C    ADAPTED FROM ORIGINAL SUBROUTINE CREATED BY LINDA STATHOPOLIS

c*************************************************************
c
c    Passed variables
c
c     iyear0 - base year for calculating julian day
c     iyear - present year
c     month,iday - present month,day
c     time - present time
c     itimesig - number of significant figures in time
c     xjulian - output julian day
c     jsig - output number of significant figures for julian day
c
c************************************************************

      parameter (bmiss=-1E10,zdays=365.)
      dimension yrnorm(13),monthend(12)

c     double precision xjuliand,xtime

      data monthend/31,28,31,30,31,30,31,31,30,31,30,31/
      data yrnorm/0,31,59,90,120,151,181,212,243,273,304,334,365/

      xday=iday
      iadd=0
      xadd=0.
      xjulian0=0.
      xjulian=bmiss
      jsig=0
      iprect=itimesig

c     Calculate days to add between base year and present year

      do 50 i=iyear0,iyear-1
       x1=0.
       if ( (i/4)*4 .eq. i ) x1=1.
       if ( (i/100)*100 .eq. i .and.
     *      (i/400)*400 .ne. i ) x1=0.
       xjulian0=xjulian0+zdays+x1
50    continue

c     Check fo leap year

      if ( (iyear/4)*4 .eq. iyear .and. month .gt. 2 ) xadd=1.
      if ( (iyear/100)*100 .eq. iyear .and.
     *     (iyear/400)*400 .ne. iyear ) xadd=0.
      if ( (iyear/4)*4 .eq. iyear .and. month .eq. 2 ) iadd=1
      if ( (iyear/100)*100 .eq. iyear .and.
     *     (iyear/400)*400 .ne. iyear ) iadd=0.

c     Do not set julian day if the date is suspect

      if ( iyear .le. 0 .or. month .le. 0 .or. iday .le. 0 
     *     .or. month .gt. 12 ) then
       return
      elseif ( iday .gt. monthend(month)+iadd ) then
       return
      endif

c     Calculate time portion

      if ( time .lt. 0. .or. time .gt. 24 ) then
       xtime=0.
       iprect=0
      elseif ( time .eq. 24. ) then
       xadd=xadd+1.
       xtime=0.
       iprect=2
      else
       xtime=time/24.
      endif

c     Calculate julian day

c     xjuliand=xjulian0+yrnorm(month)+
c    * (xday-1.)+xadd
c     xjuliand=xjuliand + xtime
c     xjulian=xjuliand
      xjulian=xjulian0+yrnorm(month)+
     * (xday-1.)+xadd+ xtime

c     Calculate number of sig figs in julian day

      call findsignif(jsig,iprect,xjulian)
      if ( xjulian .eq. 0.00 .and. xtime .eq. 0. .and.
     *    iprect .eq. 1 ) jsig=2

      return
      end
      SUBROUTINE lijing2_meant(ishallow,temp,maxlevel,maxcalc,
     * nlevels,bmiss,depth,nbinmax,xmeanall,xmeans)

C     CALCULATES MEAN TEMPERATURE DOWN TO GIVEN LEVEL FOR 0-100 m
C     AND FOR FULL DEPTH XBT

      parameter (maxbin=400)
      dimension xcount(maxbin)
      dimension xmeant(maxbin)
      dimension temp(maxlevel,maxcalc)
      dimension depth(maxlevel)
 
      nbinmax=0

c     shallow max depth 550, deep max depth 1000 m, other 2000 m
      maxbin_loc=200
      if ( ishallow .eq. 1 ) then
       maxbin_loc=110
      elseif ( ishallow .eq. -1 ) then
       maxbin_loc=maxbin
      endif

c     always calculate 0-100
      nbin_loc=20


c     get means in five-meter bins

      depthmax=0.
      nbinout=0
      ip2=1

      do 25 k=1,maxbin
       xcount(k)=0.
       xmeant(k)=0.
25    continue

      do 35 k=1,nlevels

       if ( temp(k,ip2) .gt. bmiss .and.
     *      temp(k,ip2) .lt. 50. ) then
        nbin=(depth(k)/5)+1
c       write(6,*) 'xx',depth(k),nbin,maxbin,nbinmax
        if ( nbin .gt. maxbin_loc ) goto 35
        if ( nbin .gt. nbinmax ) nbinmax=nbin
        xcount(nbin)=xcount(nbin)+1.
        xmeant(nbin)=xmeant(nbin)+temp(k,ip2)
       endif
c      write(6,*) 'bin',k,nbin,depth(k),xcount(nbin),
c    *  temp(k,ip2)

35    continue

      nbinout=nbinmax
      nfirst=0
      do 40 k=1,nbinout

        if ( xcount(k) .gt. 0. .and.
     *   nfirst .eq. 0 ) nfirst=k       
       if ( xcount(k) .gt. 1. ) then

        xmeant(k)=xmeant(k)/xcount(k)

       endif

40    continue

c    fill in up to surface

      do 45 k=1,nfirst-1
45     xmeant(k)=xmeant(nfirst) 

c     fill in missing bins

      do 50 k=nfirst+1,nbinout

       if ( xcount(k) .lt. 1. ) then

        k1=k-1

        k2=0
        do 75 kk2=k+1,nbinout
75       if ( k2 .eq. 0 .and. xcount(kk2)  .gt. 0. )
     *    k2=kk2

        d1=(k1-1)*5.
        d2=(k2-1)*5.
        d=(k-1)*5.
        xmeant(k)=xmeant(k1)+((d-d1)/(d2-d1))*(xmeant(k2)-xmeant(k1)) 
       endif
50    continue

c     write(6,*) 'here1'
      dtots=0.
      xdeps=0.
      dtot=0.
      xdep=0.
      do 60 k=1,nbinout
      dtot=dtot+xmeant(k)
      xdep=xdep+1.
      if ( k .le. nbin_loc ) then
       dtots=dtot
       xdeps=xdep
      endif
60    continue
      xmeanall=dtot/xdep
      xmeans=dtots/xdeps
c     write(6,*)'xmeanall',xmeanall,xmeans,dtot,xdep,xdeps,nbinout,xmeant(1)

      return
      end
      SUBROUTINE LOCKCHECK(proberec,iaccesstype,istatus,
     * ilockup,iverb)

c*****************************************************************
c    
c     INPUT:
c       proberec - probe of interest
c       iaccesstype -  0 = read-only program (e.g. proflook, overlap)
c                      1 = low risk read/write
c                          (READ-ONLY lock required)
c                      2 = high risk read/write
c                          (EXCL-LOCK required)
c                      8 = Dangerous - do not run on main probe
c
c     RETURN: (istatus)
c        -1  - local probe, no accession permission required
c     .  "0" = read-only access okay / don't own READ-ONLY lock, if present
c     .  "1" = read-write (low risk) access okay (READ-ONLY)
c     .  "2" = read-write (high risk) access okay (EXCL-LOCK)
c     .  "9" = ACCESS DENIED
c    
c*****************************************************************

      parameter (iwhofile = 77, ilockfile = 78)
      parameter (maxprobe=25)
      parameter (ip=11,it=8,il=15,iw=15,iw2=25)

      character*11 proberec,probelockrec(maxprobe)
      character*8 timerec(maxprobe)
      character*15 wholockrec(maxprobe)
      character*15 lockstat(maxprobe)
      character*25 whatrec(maxprobe)

      dimension iLOCK(maxprobe)

      call readlockfile(icounter,maxprobe,
     * probelockrec,ip,lockstat,il,wholockrec,iw,
     * timerec,it,whatrec,iw2,iLOCK,ilockfile)

      call matchlockprobe(icounter,probelockrec,ip,proberec,
     * iprobe,maxprobe)

      if ( iprobe .gt. 0 ) then
       call lockown(wholockrec(iprobe),iw,iown)

       if ( iaccesstype .gt. -1 ) then 
        write(6,*)' '
        write(6,*)'Probe: ',proberec
        write(6,*) 'present user:',wholockrec(iprobe)
        write(6,*) 'lock status:',lockstat(iprobe)
        write(6,*) 'running:',whatrec(iprobe)
       endif

       call lockstatus(iaccesstype,iLOCK(iprobe),iown,
     *  iprobe,istatus,ilockup,iverb)

c     Allow for overnight locks (3 & 4)
       if ( iLOCK(iprobe) .eq. 4 ) then
        istatus=4
       elseif ( istatus .lt. iLOCK(iprobe) .and.
     *  iLOCK(iprobe) .lt. 3 ) then
        istatus=iLOCK(iprobe)
       elseif ( istatus . lt. 2 .and. iLOCK(iprobe) .eq. 3 ) then
        istatus=3
       endif
      else
       istatus=-1
      endif

      return
      end

      SUBROUTINE LOCKEXEC(proberec,lockup,actionrec)

c     Program to upgrade or downgrade a lock

c*****************************************************************
c    
c     INPUT:
c       proberec - probe of interest
c       lockup  - new lock status
c
c*****************************************************************

      parameter (ilockfile = 78, maxprobe = 25)
      parameter (ip=11,il=15,it=8,iw=15,iw2=25)

      dimension iLOCK(maxprobe)

      character*(*) actionrec
      character*11 proberec
      character*11 probename(maxprobe)
      character*15 probeusr(maxprobe)
      character*8 probetime(maxprobe)
      character*15 lockstat(maxprobe)
      character*25 whatrec(maxprobe)

      call readlockfile(icounter,maxprobe,
     * probename,ip,lockstat,il,probeusr,iw,
     * probetime,it,whatrec,iw2,iLOCK,ilockfile)

      call matchlockprobe(icounter,probename,ip,proberec,
     * iprobe, maxprobe)
      if ( iprobe .gt. 0 ) then
       call lockown(probeusr(iprobe),iw,iown)
       
       if ( iown .eq. 1 .or. iLOCK(iprobe) .eq. 0 ) then

        if ( lockup .gt. -1 ) 
     *   call changelockstatus(lockstat(iprobe),il,lockup)
        call updatelocktime(probetime(iprobe),it)
        call setlockwhat(whatrec(iprobe),iw2,actionrec,15)
        call setlockowner(probeusr(iprobe),iw)
        if ( lockup .lt. 0 .and. iLOCK(iprobe) .eq. 0 ) then 
         call clearstring(probeusr(iprobe),iw)
         call clearstring(probetime(iprobe),it)
         call clearstring(whatrec(iprobe),iw2)
        endif

        call writelockfile(icounter,maxprobe,
     *   probename,ip,lockstat,il,probeusr,iw,
     *   probetime,it,whatrec,iw2,ilockfile)
       endif
      endif

      return
      end

      SUBROUTINE LOCKOWN(wholockrec,iw,iown)

C     IOWN IS SET TO ONE IF USER IS OWNER OF LOCK FO
C     THIS PROBE, ZERO OTHERWISE

      character*(*) wholockrec
      character*15 WHOrec

      call clearstring(WHOrec,15)
      call getuser(WHOrec)
      call findlastchar(nsp,WHOrec,15)
      call findlastchar(nsp2,wholockrec,iw)

      if ( nsp .eq. nsp2 .and.
     * WHOrec(1:nsp) .eq. wholockrec(1:nsp) ) then
       iown=1
      else
       iown=0
      endif

      return
      end

      SUBROUTINE LOCKSTATUS(iaccesstype,ilockin,iown,
     * iprobe,istatus,ilockup,iverb)

C      LOCKSTATUS RETURNS THE PRESENT LOCK STATUS FOR THE
C      GIVEN PROBE

c     .  iaccesstype -  0 = read-only program
c     .                      [no lock required, works on all but EXCL-LOCK]
c     .                        Ex: proflook, overlook, overlap, yeargraph
c
c     .                 1 = low-risk read/write program
c     .                      [READ-ONLY lock required]
c     .                        Ex: cruiseinfo, samecheck, oversort
c
c     .                 2 = high-risk read/write program
c     .                      [EXCL-LOCK required]
c     .                        Ex: headsort, paramsort, addcode, changesubset
c     .                 5 = force exclusive lock
c    
c     .                 8 = DANGEROUS:  Do not run on "main probe"
c     .                    [don't allow, with any lock]
c    
c     istatus:
c     .
c        -1  - local probe, no accession permission required
c     .  "0" = read-only access okay / don't own READ-ONLY lock, if present
c     .  "1" = read-write (low risk) access okay (READ-ONLY)
c     .  "2" = read-write (high risk) access okay (EXCL-LOCK)
c     .  "9" = ACCESS DENIED
c
c     ilockup:
c     . -2 (input value) - automatically set to upgrade to necessary lock
c     . -1 (input value) - prompt user for upgrade
c     .  0 - no lock upgrade
c
      istatus=-1
      ilock=ilockin
      if ( ilock .eq. 3 ) then
       ilock=1
      elseif ( ilock .eq. 4 ) then
       ilock=2
      endif

c     DANGEROUS LOCK CHECK
      if (iaccesstype .eq. 8 .and. iprobe .gt. 0 ) then
       if ( iverb .eq. 1 ) then
        write(6,*)' '
        write(6,*)' WARNING!  THIS PROGRAM SHOULD NOT BE RUN'
        write(6,*)'         ON THE MAIN DATABASES!  '
        write(6,*)' '
       endif
       istatus = 9

c     Lock release

      elseif ( iaccesstype .eq. -1 .and. iprobe .gt. 0 ) then

       if ( iown .eq. 1 ) then
        istatus=ilockin
       else
        istatus=9
       endif

c---------------------------------------------------
c     - Request READ ONLY ACCESS (iaccesstype = 0)
c
c           NO LOCK:  allow read-only access (istatus = 0)
c READ-ONLY (owned):  allow read-only access (istatus = 0)
c           (OTHER):  allow read-only access (istatus = 0)
c EXCL-LOCK (owned):  allow read-only access (istatus = 0)
c           (OTHER):  -> NO ACCESS ALLOWED   (istatus = 9)
c    
c---------------------------------------------------

      elseif ( iaccesstype .eq. 0 .and. iprobe .gt. 0 ) then

       if ( iverb .eq. 1 ) write(6,*) 'access type: read-only'
       if ( ilock .lt. 2 .or. iown .eq. 1 ) then
        istatus=0
       else
        istatus=9
        if ( iverb .eq. 1 ) write(6,*)
     * '        comment:  Probe is EXCL-LOCKed by another user!'
       endif

c------------------------------------------------------------
c     - Request READ-WRITE (minor) ACCESS (iaccesstype = 1)
c
c           NO LOCK:  allow read-only access   (istatus = 0)
c READ-ONLY (owned):  allow minor write access (istatus = 1)
c           (OTHER):  allow read-only access   (istatus = 0)
c EXCL-LOCK (owned):  allow minor write access (istatus = 1)
c           (OTHER):  -> NO ACCESS ALLOWED     (istatus = 9)
c
c------------------------------------------------------------

      elseif ( iaccesstype .eq. 1 .and. iprobe .gt. 0 ) then

       if ( iverb .eq. 1 ) write(6,*) 'access type: read-write (minor)'
       if ( ilock .gt. 0 .and. iown .eq. 1 ) then
        istatus=1
       elseif ( ilock .eq. 1 ) then
        istatus=9
        if ( iverb .eq. 1 ) write(6,*)
     * '        comment:  Probe is READ-ONLY locked by another user!'
       elseif ( ilock .gt. 1 ) then
        istatus = 9
        if ( iverb .eq. 1 ) write(6,*)
     * '        comment:  Probe is EXCL-LOCKed by another user!'
       elseif ( ilock .eq. 0 ) then
        istatus = 9
        if ( ilockup .eq. -2 ) then
         istatus=1
        elseif ( ilockup .eq. -1 ) then
         call upgradelockprompt(1,istatus)
        elseif ( iverb .eq. 1 ) then
         write(6,*)
     * '        comment:  Probe unlocked.  Lock probe to write!'
        endif
       endif

c------------------------------------------------------------
c     - Request READ-WRITE (EXCL) ACCESS (iaccesstype = 2)
c
c           NO LOCK:  -> NO ACCESS ALLOWED     (istatus = 9)
c READ-ONLY (owned):  -> NO ACCESS ALLOWED     (istatus = 9)
c           (OTHER):  -> NO ACCESS ALLOWED     (istatus = 9)
c EXCL-LOCK (owned):  allow EXCL write access  (istatus = 2)
c           (OTHER):  -> NO ACCESS ALLOWED     (istatus = 9)
c
c------------------------------------------------------------

      elseif ( (iaccesstype .eq. 2 .or. iaccesstype .eq. 5 )
     *  .and. iprobe .gt. 0 ) then
       
       if ( iverb .eq. 1 ) write(6,*) 'access type: read-write (EXCL)'

       if ( iown .eq. 1 ) then

        if ( ilock .eq. 1 .or.
     *   ( ilock .eq. 0 .and. iaccesstype .eq. 5) ) then
         istatus=9
         if ( ilockup .eq. -2 ) then
          istatus=2
         elseif ( ilockup .eq. -1 ) then
          call upgradelockprompt(2,istatus)
         elseif ( iverb .eq. 1 ) then
          write(6,*)
     * '        comment:  Upgrade to "EXCL-LOCK" for write access.'
         endif
        elseif ( ilock .eq. 0 .and. iaccesstype .ne. 5 ) then
         if ( ilockup .lt. 0 ) then
          write(6,*) 'Cannot upgrade from no lock to EXCL-LOCK'
          write(6,*) 'You must run mergelock to do this'
         elseif ( iverb .eq. 1 ) then
          write(6,*)
     * '       comment:  Upgrade to "EXCL-LOCK" for write access.'
         endif
        else
         istatus = 2
        endif

       elseif (ilock .eq. 0) then

        istatus = 9
        if ( ilockup .eq. -2 .and. iaccesstype .eq. 5) then
         istatus=2
        elseif ( ilockup .eq. -1 .and. iaccesstype .eq. 5) then
         call upgradelockprompt(2,istatus)
        elseif (  iverb .eq. 1 ) then
         if ( ilockup .lt. 0 ) then
          write(6,*) 'Cannot upgrade from no lock to EXCL-LOCK'
          write(6,*) 'You must run mergelock to do this'
         elseif ( iverb .eq. 1 ) then
          write(6,*)
     *  '     comment:  Probe unlocked.  Excl-Lock probe to continue!'
         endif
        else
         istatus = 9
         if ( iverb .eq. 1 ) write(6,*)
     *  '        comment:  Probe is locked by another user!'
        endif

       endif
      endif

      if ( iverb .eq. 1 ) then
       if (istatus .eq. -1) then
        write(6,*)' granted access:  full (non-lockable)'
       elseif (istatus .eq. 0) then
        write(6,*)' granted access:  read-only'
       elseif (istatus .eq. 1) then
        write(6,*)' granted access:  minor read-write'
       elseif (istatus .eq. 2) then
        write(6,*)' granted access:  EXCL read-write'
       elseif (istatus .eq. 9) then
        write(6,*)' granted access:  --> DENIED <--'
       endif
      endif

      return
      end
      SUBROUTINE MAINPROBER(npro,nparms)

C     MAINPROBER SUBSTITUTES THE CORRECT MAIN PROBE TYPE
C     FOR THE FIRST MARKED PROBE.
C     THIS IS ONLY DONE IF FILE DUM.MAINPROBE EXISTS AND
C     CONTAINS A VALID VALUE
C  
C     MAINPROBER ALSO COPIES ALL PROBE INFORMATION FROM
C     THE MAIN PROBE  HOLDER (JP) TO THE ALL PROBE
C     HOLDER (JPM).  ALL INFORMATION FOR ALL PROBES BUT
C     THE FIRST ARE REMOVED FROM JP.

C     NUMBER OF WORKING PROBES (NPRO) IS RESET TO ONE

      parameter (maxlevel=6000, maxparm=100, maxprobe=100)
      parameter (maxcalc=200)

      character*11 ctype(maxprobe)

      common /probes/ ctype

      dimension nopas(maxprobe), nprm(maxprobe,maxparm)
      dimension  nprec(maxcalc,maxprobe), npatot(maxparm)
      dimension jpm(0:maxprobe),jp(0:maxprobe)

      common /nopars/ nopas
      common /partype/ nprm
      common /parmord/ nprec
      common /totalparms/ npatot
      common /allprobe/ jpm,npromax
      common /reqprobe/ jp

      open(19,file='./dum.mainprobe',status='old', iostat=ios)

      if ( ios .ne. 0 ) return

      read(19,*) mainprobe
      close(19)

      call getmainprobe(iyes,mainprobe,jp(1),nparms)

      if ( npromax .eq. 0 ) then

       do 50 nn=1,npro

        jpm(nn)=jp(nn)
        jp(nn)=0

        npromax=npromax+1

50     continue

      endif

      npro=1

      return
      end

      SUBROUTINE MAKEMERGELINE(cline,probelockrec,ip,
     * lockstat,il,wholockrec,iw,timerec,it,whatrec,iw2)

C     READMERGELINE READS IN A LINE FROM
C     THE MERGELOCK FILE AND PLACES THE
C     INFORMATION IN THE APPROPRIATE FIELDS

      parameter (icmax=10,maxform=38)
      character*38 cform
      character*(*) probelockrec
      character*(*) cline
      character*(*) lockstat
      character*(*) wholockrec
      character*(*) timerec
      character*(*) whatrec

      cform="(2x,aAA,BBx,aCC,DDx,aEE,1x,aFF,1x,aGG)"

c     Center lock status

      call centerchar(lockstat,il,ileftspace,icenter,
     * irightspace)
      call insertnum('A',ip,cform,maxform)
      call insertnum('B',ileftspace,cform,maxform)
      call insertnum('C',icenter,cform,maxform)
      call insertnum('D',irightspace,cform,maxform)
      call insertnum('E',iw,cform,maxform)
      call insertnum('F',it,cform,maxform)
      call insertnum('G',iw2,cform,maxform)

      write(cline,cform) probelockrec,lockstat(1:icenter),
     * wholockrec,timerec,whatrec

      return
      end

      SUBROUTINE CENTERCHAR(char,nchar,ileftspace,icenter,
     * irightspace)

C     CENTERCHAR CALCULATES LEFT-SPACE, RIGHT-SPACE AND
C     NUMBER OF CHARACTERS IN CENTER TO CENTER A CHARACTER
C     STRING IN A GIVEN SPACE

      character*(*) char
      call findlastchar(icenter,char,nchar)
      if ( icenter .eq. 0 ) then
       icenter=1
       char(1:1)='-'
      endif

      irightspace=(nchar-icenter)/2 
      ileftspace=irightspace
      if ( icenter + ileftspace + irightspace .lt. nchar ) 
     * ileftspace=ileftspace+1

      return
      end
      SUBROUTINE MASKCODE(filename,mskcd)

C     MASKCODE TAKES A MASK FILE NAME AND ASSIGNS A MASK CODE
C     ACCORDING TO THE SUFFIX:
C
c                1 - (.s,index,.p) sequential mask
c                2 - (.d, .2, .l) two integer mask
c                3 - (.3) three integer
c                4 - (.4) four integer
c                5 - (.c) one integer,one string (15 char)
c                6 - (.c2) two string
c                7 - (2ri) two reals, one integer
c                8 - (2r2i) two reals, two integers
c                9 - (c2i) one string, two integers
c               10 - (c1) one string
c               11 - (.i, .a) ASCII
c               12 - (ci) one integer, one string (80 char)

      character*80 filename

c****************************************************
c
c     Find beginning of suffix (after '.')
c
c****************************************************

      nspace = 0

      do 50 n=1,80
       if ( filename(n:n).eq. '.' ) nspace=n
50    continue
      n=nspace

      call findlastchar(ll,filename,80) !- fixed (15-may-01 TOB)

c****************************************************
c
c    Set mask code number
c
c****************************************************

      if ( n .eq. 0 .or. filename(n+1:n+1) .eq. 's'
     *    .or. filename(n+1:n+1) .eq. 'p' ) then
       mskcd=1
      elseif ( filename(n+1:n+1) .eq. 'd' ) then
       mskcd=2
      elseif ( filename(n+1:n+1) .eq. 'l' ) then
       mskcd=2
      elseif ( filename(n+1:n+1) .eq. '2'.and.
     * ll .eq. n+1 ) then
       mskcd=2 
      elseif ( filename(n+1:n+1) .eq. '3' ) then
       mskcd=3
      elseif ( filename(n+1:n+1) .eq. '4' ) then
       mskcd=4
      elseif ( filename(n+1:n+2) .eq. 'c2' ) then
       mskcd=6
      elseif ( filename(n+1:n+3) .eq. 'c2i' ) then
       mskcd=9
      elseif ( filename(n+1:n+2) .eq. 'c1' ) then
       mskcd=10
      elseif ( filename(n+1:n+2) .eq. 'ci' ) then
       mskcd=12
      elseif ( filename(n+1:n+1) .eq. 'c') then
       mskcd=5
      elseif ( filename(n+1:n+3) .eq. '2ri' ) then
       mskcd=7
      elseif ( filename(n+1:n+4) .eq. '2r2i' ) then
       mskcd=8
      elseif ( filename(n+1:n+1) .eq. 'i' .or. 
     *         filename(n+1:n+1) .eq. 'a' ) then
       mskcd=10
      else
       mskcd=1
      endif

      return
      end
      SUBROUTINE MASKERASE(nm,nt,nmask,ifn,iparm2,ipro2)

C     MASKERASE ERASES A MASK FROM THE SET OF MASKS OPENED FOR
C     A PROBE TYPE

      parameter (maxmask=100)
      dimension nmask(5),ifn(maxmask)
      dimension iparm2(maxmask),ipro2(maxmask)

      if ( nt .eq. 1 ) then
       ns=1
      else
       ns=nmask(nt-1)+1
      endif

      ns=ns+nm-1 
      ne=nmask(5)-1

      call onefilecloseft(ifn(ns))
      do 40 n=ns,ne

       ifn(n) = ifn(n+1)
       ipro2(n) = ipro2(n+1)
       iparm2(n) = iparm2(n+1)

40    continue

      do 45 n=nt,5
45     nmask(n)=nmask(n)-1

      return
      end

      SUBROUTINE MASKINPUT

C
C     MASKINPUT READS IN MASK DATA FROM MASKCHOICE.D AND 
C     ORGANIZES IT.

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Parameter
c
c      maxmask - maximum number of masks
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      parameter (maxmask=100)

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Character Arrays:
c
c      cfile - file names for masks, read in from maskchoice.d
c      text - dummy character for reading irrelevant lines
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      character cfile*80
      character text*80
 
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Common Blocks:
c
c      maskfile - contains cfile, which stores mask file names
c      mfileinf - The mask file information gleened from maskchoice.d.
c                 From this information, the masks to be used in this
c                 iteration of the main program are drawn, depending
c                 on the requested probe type.  This information is
c                 number of each type of mask, parameter of each
c                 mask, and probe of each type of mask.
c
c                 Mask types are:
c
c                 1. Inclusive Sequential Read
c                 2. Exclusive Sequential Read
c                 3. Exclusive Depth Read
c                 4. Sequential Write
c                 5. Depth Exclusion Write
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      common /maskfile/ cfile(maxmask)
      common /mfileinf/ nmask(5),ipar(0:maxmask),
     * ipro(0:maxmask)
 

      call arrayinit(nmask,1,5)

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Open maskchoice.d
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      open(9, file='./maskchoice.d', status='old')
 
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Skip the first fourteen lines.
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      do 70 n=1,14
70    read(9,'(a1)') text
 
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Do a two through loop, once for reading masks, once for
c     writing masks.  Reading masks may also be written to, but
c     writing masks are always opened as new masks, whereas reading
c     masks are opened as old masks.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      do 79 j0=0,1

       do 80 i0=1,3
 
        i= i0 + 3*j0
 
        if ( i .gt. 5 ) goto 80
 
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Read in the number of masks for this type of mask
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

        read(9,'(a40,i2)') text,nmask(i)
c       write(6,*) 'text',i,nmask(i)
        
        if ( i .gt. 1 ) then
         nmstart=nmask(i-1)
        else
         nmstart=0
        endif

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     For each mask, assigned a successive number greater than the
c     number of the last previous type of mask, read the probe and
c     parameter type and the file name.
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

        do 71 n=nmstart+1,nmstart+nmask(i)

         read(9,*) ipar(n), ipro(n)
         read(9,*) cfile(n)
 
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     findchar outputs the distance from the beginning of a
c     character array to the first occurance of a character.
c     Here, n1 is the distance, the second variable is the array
c     in question, the third is the maximum length of a variable
c     and the last is the character to be searched for.  So the
c     length of an array is the distance to the first space minus one
c
c     Add a C end of array symbol to the file name.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

         call findchar(n1,cfile(n),80,' ')
         cfile(n)(n1:n1+1)=CHAR(0)
c        write(6,*) 'n',n,n1,cfile(n)(1:n1+1)

71      continue

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Set the value of this type of mask to the number of this type
c     of masks plus the number of all previous mask types.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

        if ( i .gt. 1 ) nmask(i)=nmask(i-1)+nmask(i)
c       write(6,*) 'nm',i,nmask(i)
 
80     continue
 
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Skip intervening lines
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

       if (j0 .eq. 0) then

        read(9,'(a1)') text
        read(9,'(a1)') text
        read(9,'(a1)') text

       endif
 
79    continue
 
      close(9)
 
      return
      end

      SUBROUTINE MASKINPUTHW(ip2,iprobe)

C     MASKINPUTHW HARDWIRES THE INPUT MASKS FOR THE FINALSD PROGRAM
C     BASED ON VARIABLE

      parameter (maxmask=100)
      character*80 cfile
   
      dimension nmask(5)
      dimension ipar(0:maxmask),ipro(0:maxmask)
      dimension cfile(maxmask)

      common /maskfile/ cfile
      common /mfileinf/ nmask,ipar,ipro

c     Inclusive sequential mask

      nm=0
      iprx=-iprobe
      if ( iprobe .eq. 0 ) iprx=-1000

      if ( ip2 .gt. 2 ) then

       nm=1
       nmask(1)=nm
       ipar(nm)=ip2
       ipro(nm)=iprobe
       cfile(nm)='records.s'//CHAR(0)

      else
   
       nmask(1)=0

      endif

c    Exclusive sequential

      nm=nm+1
      cfile(nm)='cruiseout.s'//CHAR(0)
      ipar(nm)=ip2
      ipro(nm)=iprx
      nm=nm+1
      cfile(nm)='countryout.s'//CHAR(0)
      ipar(nm)=ip2
      ipro(nm)=iprx
      nm=nm+1
      cfile(nm)='duplicate.s'//CHAR(0)
      ipar(nm)=0
      ipro(nm)=iprx

      if ( ip2 .eq. 1 .or. ip2 .eq. 2 ) then
       nm=nm+1
       cfile(nm)='highrespair.s'//CHAR(0)
       ipar(nm)=0
       ipro(nm)=iprx
       nm=nm+1
       cfile(nm)='dinvstand2.s'//CHAR(0)
       ipar(nm)=0
       ipro(nm)=iprx
      endif

      nmask(2)=nm

c     Exclusive depth masks

      nm=nm+1
      cfile(nm)='Bullseye.d'//CHAR(0)
      ipar(nm)=ip2
      ipro(nm)=iprx
      nm=nm+1
      cfile(nm)='outliersS.d'//CHAR(0)
      ipar(nm)=ip2
      ipro(nm)=iprx

      if ( ip2 .eq. 1 .or. ip2 .eq. 2 ) then
       nm=nm+1
       cfile(nm)='dinvstand.d'//CHAR(0)
       ipar(nm)=0
       ipro(nm)=iprx
      endif

      nmask(3)=nm
      nmask(4)=nm
      nmask(5)=nm

      return
      end
      SUBROUTINE MASKSEE(nt,nmask,ifn,iparm2,ipro2,ifile,
     * ik,ipk)

C     MASKSEE ADDS A MASK TO THE SET OF MASKS OPENED FOR
C     A PROBE TYPE

      parameter (maxmask=100)
      dimension nmask(5),ifn(maxmask)
      dimension iparm2(maxmask),ipro2(maxmask)

      if ( nt .eq. 1 ) then
       ns=0
      else
       ns=nmask(nt-1)
      endif

      do 40 n=nmask(5),ns+1,-1

       ifn(n+1) = ifn(n)
       iparm2(n+1) = iparm2(n)
       ipro2(n+1) = ipro2(n)

40    continue

      ifn(ns+1)=ifile
      iparm2(ns+1)=ik
      ipro2(ns+1)=ipk

      do 45 n=nt,5
45     nmask(n)=nmask(n)+1

      return
      end

      SUBROUTINE MASKSET(npro,m,ift,nmask)

C     MASKSET READS IN INFORMATION FROM MASKCHOICE.D (IF THIS
C     IS THE FIRST RUN THROUGH MASKSET) AND SETS MASKS PARAMETERS
C     ACCORDING TO THE INFORMATION THEREIN.  MASKS ARE SET
C     DEPENDING ON THE PROBE TYPE REQUESTED.  ONLY MASKS WITH THE
C     SAME PROBE TYPE OR UNIVERSAL PROBE TYPE (ZERO) ARE OPENED.
C     MASK FILE IDENTIFICATION NUMBERS, WHICH ARE SET HERE, START
C     AT 301.


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Passed Variables:
c
c      npro - number of probe types being investigated
c      m - present probe type code
c      ift - one means open a new file, zero,
c            an old file ( if it exists ).
c      nmask - number of each type of mask
c       1. number of inclusive sequential masks to be read
c       2. number of inclusive + exclusive sequential to be read
c       3. nmask(2) + number of depth exclusion masks to be read
c       4. nmask(3) + number of sequential masks to be written
c       5. nmask(4) + number of depth exclusion masks to be written
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Parameter:
c
c      maxmask - maximum number of masks
c      maxprobe - maximum number of probe types
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      parameter (maxmask=100, maxprobe=100)

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Character Arrays:
c
c      cift - file opening code.  Either w+ for a new file or
c             rb+ for an old file, depending on value of ift.
c      cfile - file name with C end of array marker '\0\
c      filename - constructed file name from user input in maskchoice.d
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      character cift*5
      character*7 firsttime
      character cfile*80, cfl*80
      character filename*80

      dimension nmask(5)

c******************************************************************
c 
c     Arrays:
c
c      imask - full list of all masks in maskchoice.d
c      ipar - full list of all associated mask parameters
c      ipro - full list of all associated mask probes
c      cfile - full list of all mask names
c
c******************************************************************

      dimension imask(0:5),ipar(0:maxmask),ipro(0:maxmask)
      dimension cfile(maxmask)
 
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Common Blocks:
c
c      reqprobe - contains jp, probe codes.
c      maskfile - contains cfile, which stores mask file names
c      parm2 - contains ipar2, which stores parameter codes for
c              mask files, file identifier numbers, and probe
c              codes for each maskfile.
c      mfileinf - The mask file information gleened from maskchoice.d.
c                 From this information, the masks to be used in this
c                 iteration of the main program are drawn, depending
c                 on the requested probe type.
c     mskcodes - Code of what type of mask each present mask is
c                1 - (.s,index,.p) sequential mask
c                2 - (.d, .2) two integer mask
c                3 - (.3) three integer
c                4 - (.4) four integer
c                5 - (.c) one string
c                6 - (.c2) two string
c                7 - (2ri) two reals, one integer
c                8 - (2r2i) two reals, two integers
c                9 - (c2i) one string, two integers
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      common /reqprobe/ jp(0:maxprobe)
      common /maskfile/ cfl(maxmask)
      common /parm2/ ipar2(maxmask),ifn(maxmask),ipro2(maxmask)
      common /mfileinf/ imsk(5),ipr(0:maxmask),ipo(0:maxmask)
      common /mskcodes/ mskcode(maxmask)

c********************************************************************
c
c     Save iset to denote that maskchoice.d has been read.
c
c     The other saved variables are equivalent to common
c     block variables which have been passed from maskinput
c     where file names, number of masks, associated parameters
c     and probes have all been read in.  It is from this overall
c     list that masks are chosen depending on requested probe 
c     type
c
c*******************************************************************

      save firsttime
      save iset
      save cfile
      save imask,ipar,ipro
 
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Initialize number of each type of mask
c     Initialize nx which is a holder number denoting the
c     total number of masks already looked at in the mask loop.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      call arrayinit(nmask,1,5)
      nx = 0
 
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     If ift is one, a new mask will be opened, if ift is zero,
c     an old mask will be opened (if it exists).
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      if ( ift .eq. 0 ) cift = 'rb+'//CHAR(0)
      if ( ift .eq. 1 ) cift = 'w+'//CHAR(0)
 
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Read maskchoice if this is the first time through.
c     The values for common block mfileinf are set here.
c     maskchoice is read using subroutine maskinput
c
c     maskinputhw is a hardwired maskinput for the run of
c     finalsd with qcAupdate.shell.  It will only be accessed
c     if file dum.maskinputhw exists
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      if ( firsttime .ne. 'maskset' ) then

       open(9,file='./dum.maskinputhw',status='old',iostat=ios2)
       if ( ios2 .ne. 0 ) then
c       write(6,*) 'maskinput'
        call maskinput
c       write(6,*) 'maskinputx'
       else
        close(9)
        call system('rm dum.maskinputhw')
        call readinparam(ikx)
        call maskinputhw(ikx,m)
       endif
       iset=1

       firsttime='maskset'
 
c*****************************************************************
c
c    Put the values from common block mfileinf and from variable
c    cfl into local variable so that the local variables can
c    be saved for reuse without rereading maskchoice.d.
c
c*****************************************************************

      do 98 n=1,imsk(5)

       cfile(n)=cfl(n)
c      write(6,*) 'nimsk',n,cfl(n)
       ipar(n)=ipr(n)
       ipro(n)=ipo(n)
      
98    continue

      do 89 n=1,5

       imask(n)=imsk(n)

89    continue

      endif

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Do a loop looking at each type of mask.
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      do 59 j=1,5

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Run a loop looking at each mask of this type.
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

c      write(6,*) 'n',nx,j,imask(j)
       do 60 n=nx+1,imask(j)
 
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c      If this mask is for the requested probe type, or for all
c      probe types, it will be used in the main program this time
c      around.
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

        if (abs(ipro(n)).eq.m .or. ipro(n).eq.0.or.
     *      ipro(n) .eq. -1000 ) then

         nmask(j)=nmask(j)+1
 
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c      Run a loop for each requested probe type
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

         do 75 ii = 1,npro

          if ( npro .gt. 1 )  then
           m2=jp(ii)
          else
           m2=m
          endif

          if ( ii .gt. 1 )  nmask(j)=nmask(j)+1
 
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c       Add one to total mask number.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

         if ( j .ne. 5 ) nmask(5)=nmask(5)+1 
         nn=nmask(5)
 
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c       Set the temporary parameter value for this probe
c       This is so the value may be altered (from -1 to 0) 
c       if necessary without losing information.
c
c      maskname constructs a file name
c        cfile - file name
c        iparn - parameter code (zero is 'other')
c        filename- full filename (including directory structure)
c        m2 - probe code
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

          iparn = ipar(n)
          if ( iparn .lt. 0 ) iparn = 0
          do 88 n0=1,80
88         filename(n0:n0)=' '

c         write(6,*) 'mask',iparn,n,m2,cfile(n)
          call maskname(cfile(n), iparn, filename, m2)
c         write(6,*) 'mask',filename

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c   Set mask code
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

         call maskcode(cfile(n),mskcode(nn))
 
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c       Set file identification number, file parameter code and
c       file probe code.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

c         ifn(nn) = ibasefile + nn
          ifn(nn)=-1
          ipar2(nn)=ipar(n)
          ipro2(nn)=ipro(n)
 
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     fileopen opens the correct file:
c
c       filename - constructed file name
c       cift - opening code
c       ifn - file identification number
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

          if (j.le.3) then
           call fileopen(filename,cift,ifn(nn))
          else
           call fileopen(filename,'w+'//CHAR(0),ifn(nn))
          endif
 
75       continue
 
        endif
 
60     continue
 
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Add the number of this type of mask to each higher arrayed
c     mask type.
c     Set nx to the number of the last of this file type
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      do 80 j2=j+1,4

       nmask(j2)=nmask(j)

80    continue

      nx=imask(j)
 
59    continue
 
c*********************************************************
c
c    Run uniqtoorder on those masks which are stored as
c    unique station numbers
c
c*********************************************************

      do 67 nn=1,npro
       if ( npro .eq. 1 ) then
        mm=m
       else
        mm=jp(nn)
       endif

       call ucheck(mm,iuniqn)
       if ( iuniqn .ne. 0 ) then
        call uniqtoorder(nmask,ifn,ipro2,maxmask,nn,npro,mm,
     *   mskcode)
       endif
67    continue

      return
      end

      SUBROUTINE MASKSIFT(ity,ifilein,itemp,jp,iparm,cmask)

C     MASKSIFT SORTS A UNIQUE STATION NUMBER MASK BY
C     SEQUENTIAL ORDER

c***************************************************
c
c     Passed Variables:
c
c      itype - type of mask: 1 - (.s), 2 - (.d) , 3 - (.3), 5 - (.c)
c      ifilein - original mask file identification number
c      itemp - temporary file id number 
c      jp - probe code number for mask
c      iparm - parameter code number for mask
c      cmask - mask name
c
c**************************************************

      parameter (maxlevel=6000)

      character*17 charu,charulast
      character*80 filename
      character*(*) cmask
  
c     idlev - second and third mask values for
c             given station
c     levsort - second mask value (for sorting)

      dimension idlev(4*maxlevel,2),levsort(4*maxlevel)

      common /silent/ isilent

      isilent=1
      idone=0
      icount=0
      itx=0

c***************************************************
c
c    Set sort code from type code
c
c***************************************************

      itype=ity
      if ( itype .lt. 0 ) itype=-itype
      if ( itype .eq. 1 ) then
       isort=3
      elseif ( itype .eq. 2 ) then
       isort=1
      elseif ( itype .eq. 3 ) then
       isort=4
      elseif ( itype .eq. 5 ) then
       isort=5
      endif

c**************************************************
c
c    Replace unique station numbers with sequential order
c
c**************************************************

      if ( ity .gt. 0 ) then
       call tempfile(itemp)

       do 50 nn=1,50000000

        if ( itype .eq. 1 ) then
         call readmask(ju,ifilein,idone)
        elseif ( itype .eq. 2 ) then
         call readmask2(ju,ifilein,idone,isecond)
        elseif ( itype .eq. 3 ) then
         call readmask3(ju,ifilein,idone,isecond,ithird)
        elseif ( itype .eq. 5 ) then
         call readcmask(ju,charu,ifilein,idone)
        endif

        if ( idone .gt. 0 ) then
         call onefileclose(ifilein)
         call filerewind(itemp)
         goto 4
        endif

c       if ( ifilein .eq. 420 ) write(6,*) idone,nn,ju
        call uniqthere(jj,ju,jp)

        if ( jj .gt. -1 ) then
         if ( itype .eq. 1 )  then
          call writetomask(jj,icount,itemp)
         elseif ( itype .eq. 2 ) then
          call writetomask2(jj,icount,itemp,isecond)
         elseif ( itype .eq. 3 ) then
          call writetomask3(jj,icount,itemp,isecond,ithird)
         elseif ( itype .eq. 5 ) then
          call writecmask(jj,charu,itemp)
          icount=icount+1
         endif
        endif

50     continue
4      continue

       else
        itemp=ifilein
        ifilein=-1
        call fileend(itemp)
        if ( itype .lt. 5 ) then
         call filepos(itemp,0,itype,icount)
        else
         call filepos(itemp,4,0,icount)
        endif
        call filerewind(itemp)
       endif

c****************************************************
c
c   Sort for sequential order
c
c****************************************************

      if ( itype .eq. 5 ) then
       itemp2=itemp+1
       call tempfile(itemp2)
      else
       itemp2=itemp
      endif
      write(6,*) 'isort',isort,itemp,icount
      call sortfile(isort,itemp,icount)

      call filerewind(itemp2)

c****************************************************
c
c   Reopen unique station mask as new mask
c
c****************************************************

      call maskname(cmask,iparm,filename,jp)
      call fileopen(filename,'w+'//CHAR(0),ifilein)

c****************************************************
c  
c   Place unique station numbers back in mask,
c   excluding removed stations and duplicate entries
c
c****************************************************

      jjlast=0
      idnum=0

      jj=0
      isec=0
      ithird=0
      idtot=0

      iend=0

      do 70 j=1,icount+1

       if ( j .le. icount ) then
        if ( itype .eq. 1 ) then
         call readmask(jj,itemp2,iend)
        elseif ( itype .eq. 2 ) then
         call readmask2(jj,itemp2,iend,isec)
        elseif ( itype .eq. 3 ) then
         call readmask3(jj,itemp2,iend,isec,ithird)
        elseif ( itype .eq. 5 ) then
         call readcmask(jj,charu,itemp2,iend)
        endif
       endif

       ilast=0
       if ( j .eq. icount + 1 ) jj=-1
       if ( j .eq. 1 ) then
        jjlast=jj
        if ( itype .eq. 5 ) charulast=charu
        ilast=1
       endif

       if ( jj .eq. jjlast ) then

        ilast=1
        do 505 n3=1,idnum
         if ( isec .eq. idlev(n3,1) .and. ithird .eq.
     *        idlev(n3,2) ) then
          goto 70
         endif
505     continue

        idnum=idnum+1
        idlev(idnum,1)=isec
        idlev(idnum,2)=ithird
        levsort(idnum)=isec

       endif

       if ( ilast .eq. 0 ) then

        call uniqfind(jjlast,ju,jp,itx)
        jjlast=jj

c     sort secondary portion of array

        if ( itype .gt. 1 .and. itype .ne. 5 ) 
     * call sortarray(levsort,idnum)

        if ( ju .gt. 0 ) then

         icount2=0
         do 200 n=1,idnum

          if ( itype .eq. 1 ) then
           call writetomask(ju,icount2,ifilein)
          elseif ( itype .eq. 2 ) then
          call writetomask2(ju,icount2,ifilein,levsort(n))
          elseif ( itype .eq. 3 ) then

           do 201 nn=1,idnum

            if ( idlev(nn,1) .eq. levsort(n) ) then
             call writetomask3(ju,icount2,ifilein,idlev(nn,1),
     *                         idlev(nn,2))
             idlev(nn,1)=-1
            endif

201        continue

          elseif ( itype .eq. 5 ) then
           call writecmask(ju,charulast,ifilein)
           charulast=charu
          endif

200      continue

        endif

        idnum = 1
        idlev(idnum,1)=isec
        idlev(idnum,2)=ithird
        levsort(idnum)=isec

       endif

70    continue

c*********************************************************
c
c     Close temporary file, rewind unique station mask
c
c*********************************************************

      call onefilecloseft(itemp2)
      if ( itype .eq. 5 ) call onefilecloseft(itemp)
      call filerewind(ifilein)

      isilent=0

      return
      end
      SUBROUTINE MASTERLOCK(jp,maxprobe,npro,iaccesstype,
     * actionrec,ilocknum,iverb,ilockup)

C     MASTERLOCK CHECKS PRESENT LOCK STATUS FOR
C     GIVEN PROGRAM, INFORMS USER IF THEY DO NOT
C     HAVE ACCESS, OR NEED TO UPGRADE A LOCK, THEN
C     CHANGES THE LOCK INFORMATION ACCORDINGLY

      character*(*) actionrec
      character*11 ctype
      character*15 whoisit,printrec

      dimension jp(0:maxprobe)

      if ( iaccesstype .eq. 4 ) return
      call setlockowner(whoisit,15)
      if ( whoisit(1:4) .eq. 'root' ) return

      if ( ilocknum .gt. 0 .and. ilocknum .lt. npro ) then
       iloopx=ilocknum
      else
       iloopx=npro
      endif

      ilockstat=iaccesstype
      if ( ilockstat .eq. 3 ) ilockstat=0
      do 50 nn=1,iloopx

       call clearstring(ctype,11)
       call getprobename(jp(nn),ctype)

       call lockcheck(ctype,ilockstat,istatus,ilockup,iverb)

       if ( istatus .eq. -1 ) goto 50
       if ( istatus .eq. 9.and. ilockstat .gt. -1 ) then
        write(6,*)' '
        write(6,*)' Access to main database(s) is denied!'
        write(6,*) 'Good-bye'
        write(6,*)' '
        stop
       endif

       if ( ilockstat .gt. -1 ) then
        printrec=actionrec
       else
        call clearstring(printrec,15)
        istatus=-1
       endif

       call lockexec(ctype,istatus,printrec)

50    continue

      return
      end
      SUBROUTINE MATCHLOCKPROBE(icounter,probename,
     * ip,proberec,iprobe,maxprobe)

C     MATCHLOCKPROBE MATCHES THE GIVEN PROBE TO
C     THE APPROPRIATE PROBE FROM THE LOCK FILE

      character*(*) probename(maxprobe)
      character*(*) proberec

      iprobe=0

      call findlastchar(nsp,proberec,ip)
      do 50 nn=1,icounter
       call findlastchar(nsp2,probename(nn),ip)
       if ( nsp .eq. nsp2 .and.
     *  probename(nn)(1:nsp) .eq. proberec(1:nsp)) then
        iprobe=nn
        return
       endif

50    continue

      return
      end
       
      SUBROUTINE MERIDIANPOLERADIUS(i,idim)

C     MERIDIAN OVERPOLE COMPUTES THE LONGITUDE WITHIN
C     A RADIUS OF INFLUENCE WHICH CROSSES THE NORTH POLE

      idim2=idim/2

      if ( i .gt. idim2 ) then
       i=(idim-i)+idim2+1
      elseif ( i .lt. idim2 ) then
       i=idim2-i+1
      endif 

      return
      end
      SUBROUTINE MIXEDLAYERCHOICE(ivar,xgrad,xdel1,xdel2,
     * cmixname,nspmix)

C     MIXEDLAYERCHOICE CHOOSES MIXED LAYER CRITERIA
C     BASED ON USER INPUT

      parameter (maxchoice=20,icmax=20)
      character*16 firsttime
      character*80 filename,cmixname
      character*200 text
      dimension icomma(icmax,2)
 
      save firsttime
      save mixchoice
 
      if ( firsttime .ne. 'mixedlayerchoice' ) then
       firsttime='mixedlayerchoice'
       open(12,file='./mixedlayer_type',status='old',
     *  iostat=ios)
       if ( ios .eq. 0 ) then
        read(12,*) mixchoice
        close(12)
       else
        write(6,*) 'Enter mixed layer depth choice'
        read(5,*) mixchoice
       endif
      endif

      call clearstring(filename,80)
      call extraname('sys.inf'//CHAR(0),
     * 'mixed_layer_info.d'//CHAR(0),filename)
      open(12,file=filename,status='old')

      ifound=0
      read(12,'(a)') text
      do 30 nn=1,maxchoice
       call clearstring(text,200)
       read(12,'(a)',end=31) text
       call findlastchar(nsp,text,200)

       call spacefindl(nsp,icmax,ncomma,icomma,text)
       read(text(icomma(1,1):icomma(1,1)+icomma(1,2)-1),*)
     *  ichoice
       if ( mixchoice .eq. ichoice ) then 
        ifound=1
        read(text(icomma(2,1):icomma(2,1)+icomma(2,2)-1),*)
     *   ivar
        read(text(icomma(3,1):icomma(3,1)+icomma(3,2)-1),*)
     *   xgrad
        read(text(icomma(4,1):icomma(4,1)+icomma(4,2)-1),*)
     *   xdel1
        read(text(icomma(5,1):icomma(5,1)+icomma(5,2)-1),*)
     *   xdel2
        call clearstring(cmixname,80)
        cmixname=text(icomma(6,1):icomma(6,1)+icomma(6,2)-1)
        nspmix=icomma(6,2)
       endif
30    continue
31    continue
      close(12)
   
      if ( ifound .eq. 0 ) then
       write(6,*) 'Given choice:',mixchoice  
       write(6,*) 'Does not match any choices in mixed_layer_info.d'
      endif

      return
      end
      SUBROUTINE NAILUJt(iyear0,iyear,month,iday,time,itimesig,
     *                   xjulian,jsig)

C    COMPUTES CALENDAR DAY FROM JULIAN DAY, INCLUDING TIME, WITH RESPECTS
C    TO MIDNIGHT JANUARY 1 OF THE BASE YEAR

C    ADAPTED FROM ORIGINAL SUBROUTINE CREATED BY LINDA STATHOPOLIS

c*************************************************************
c
c    Passed variables
c
c     iyear0 - base year for calculating julian day
c     iyear - present year
c     month,iday - present month,day
c     time - present time
c     itimesig - number of significant figures in 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/

      if ( xjulian .le. bmiss ) then
       iyear=-9999
       month=-99
       iday=-99
       return
      endif

      xadd=0.
      iyearadd=0
      xjulian0=xjulian

      iyear=0
      month=0
      iday=0

      if ( (iyear0/4)*4 .eq. iyear0 ) xadd=1.
      if ( (iyear0/100)*100 .eq. iyear0 .and.
     *     (iyear0/400)*400 .ne. iyear0 ) xadd=0.
   
      xj0=xjulian
      ineg=0
      if ( xjulian .lt. 0 ) then
       ineg=1
       xj0=-xj0
      endif
      if ( xj0 .ge. zdays+xadd )
     * call reducejulian(iyear0,xjulian0,iyearadd)

c     Set year

      xadd=0.
      iyear=iyear0+iyearadd
      if ( (iyear/4)*4 .eq. iyear ) xadd=1.
      if ( (iyear/100)*100 .eq. iyear .and.
     *     (iyear/400)*400 .ne. iyear ) xadd=0.

c     Set month

      xj0=xjulian0
      if ( ineg .eq. 1 ) xj0=xjulian0+yrnorm(13)+xadd
      x1=0.
      do 30 mm=2,13

       if ( mm .eq. 3 ) x1=xadd
       if ( xj0 .lt. yrnorm(mm)+x1 ) then
        month=mm-1
        goto 31
       endif
30     continue
31     continue

c     Set day

      iday=xj0-yrnorm(month)+1.
      if ( month .ge. 3 .and. xadd .gt. 0. ) iday=iday-1

c     Set time

      ijulian=xj0
      xjuliant=ijulian
      time=(xj0-xjuliant)*24.

c     Set time significant figures

      call findprecone(itimesig,jsig,xjulian)

c     Round time

      call roundoff(-itimesig,time)
      if ( itimesig .eq. 0 ) time=tmiss
 
      return
      end
      SUBROUTINE CHARFINDl(iend,imax,ncomma,icomma,cl,ctext)

C     CHARFIND FINDS SPACINGS FOR CHARACTER DELINEATED DATA

c********************************************************
c   
c   Passed Variables:
c
c    ctext:  local array (regular commafind uses cheader)
c
c    iend - size of line
c    ncomma - number of character delineated parameters found
c    imax - maximum number of character delineated parameters
c    icomma - 1. starting point of each character delineated parameter
c             2. number of characters in each parameter
c
c********************************************************

      character*1 c,cl
      character*(*) ctext

      dimension icomma(imax,2)

      ncomma=0
      icomma(1,1)=1
      do 50 nn=1,iend

c      call extractc(1,nn,c) !- cheader
       c(1:1) = ctext(nn:nn) !- passed array

       if ( c .eq. cl) then

        ncomma=ncomma+1
        icomma(ncomma,2)=nn-icomma(ncomma,1)
        icomma(ncomma+1,1)=nn+1

       endif

50    continue

      if ( iend-icomma(ncomma+1,1) .ge. 0 ) then
       ncomma=ncomma+1
       icomma(ncomma,2)=(iend-icomma(ncomma,1))+1
      endif
 
      return
      end

      SUBROUTINE COMMAFINDx(iend,imax,ncomma,icomma,ctext)

C     COMMAFIND FINDS SPACINGS FOR COMMA DELINEATED DATA

c********************************************************
c   
c   Passed Variables:
c
c    ctext:  local array (regular commafind uses cheader)
c
c    iend - size of line
c    ncomma - number of comma delineated parameters found
c    imax - maximum number of comma delineated parameters
c    icomma - 1. starting point of each comma delineated parameter
c             2. number of characters in each parameter
c
c********************************************************

      character*1 c
      character*(*) ctext

      dimension icomma(imax,2)

      ncomma=0
      icomma(1,1)=1
      do 50 nn=1,iend

c      call extractc(1,nn,c) !- cheader
       c(1:1) = ctext(nn:nn) !- passed array

       if ( c .eq. ',') then

        ncomma=ncomma+1
        icomma(ncomma,2)=nn-icomma(ncomma,1)
        icomma(ncomma+1,1)=nn+1

       endif

50    continue

      if ( iend-icomma(ncomma+1,1) .ge. 0 ) then
       ncomma=ncomma+1
       icomma(ncomma,2)=(iend-icomma(ncomma,1))+1
      endif
 
      return
      end

      SUBROUTINE SPACEFINDl(iend,imax,ncomma,icomma,clocal)

C     SPACEFIND FINDS SPACINGS FOR SPACE DELINEATED DATA
C     THIS VERSION IS FOR A PASSED CHARACTER VARIABLE

c********************************************************
c   
c   Passed Variables:
c
c    iend - size of line
c    ncomma - number of space delineated parameters found
c    imax - maximum number of comma delineated parameters
c    icomma - 1. starting point of each space delineated parameter
c             2. number of characters in each parameter
c    clocal - local character array
c
c********************************************************

      character*1 c
      character*(*) clocal
      dimension icomma(imax,2)

      ncomma=0
c     nfirst=0
      icomma(1,1)=1

c    skip opening spaces

      ichar=0
      do 50 nn=1,iend

       c=clocal(nn:nn)
       if ( c .eq. ' ' ) then

        if ( ichar .gt. 0 ) then
         ichar=0
         ncomma=ncomma+1
         icomma(ncomma,2)=nn-icomma(ncomma,1)
         icomma(ncomma+1,1)=nn+1
        else
         icomma(ncomma+1,1)=icomma(ncomma+1,1)+1
        endif

       else
    
        ichar=1

       endif

50    continue

      if ( iend-icomma(ncomma+1,1) .ge. 0 ) then
       ncomma=ncomma+1
       icomma(ncomma,2)=(iend-icomma(ncomma,1))+1
      endif
 
      return
      end

      SUBROUTINE OPENDENSEFILES(npots,jpotlevs,ireqpars,ip2,
     *  maxlevel,ioutfile,maxparm,maxpot,inewfile,iposfile,m,
     *  ipressno)

C     OPENDENSEFILES OPENS FILES CONTAINING VARIABLES
C     ON GIVEN DENSITY SURFACES, ALWAYS INCLUDING
C     PRESSURE

      parameter (maxlevloc=6000)
      character*3 mtype
      character*5 cnew
      character*8 cpot
      character*80 filename,cfile
      
      common /parname1/ mtype(maxlevloc)

      dimension ip2(0:maxlevel),ioutfile(0:maxparm,maxpot)
      dimension iposfile(maxpot)
      dimension jpotlevs(maxpot)

c     set for new or old file open

      if ( inewfile .eq. 1 ) then
       cnew='w+'//CHAR(0)
      else
       cnew='rb+'//CHAR(0)
      endif

c     run through for each requested reference surface

      do 45 n=1,npots

c     create character representation of reference surface

       ipot=0
       if ( jpotlevs(n) .lt. 0 ) then
        cpot='insitu'
        ipot=6
       elseif ( jpotlevs(n) .lt. 1 ) then
        cpot='surf'
        ipot=4
       elseif ( jpotlevs(n) .lt. 1000 ) then
        cpot='500'
        ipot=3
       else
        write(cpot(1:4),'(i4)') jpotlevs(n)
        ipot=4
       endif

c     open position file

      cfile='pos'//cpot(1:ipot)//CHAR(0)
      call densesurffilename(cfile,m,filename)
      if ( iposfile(n) .eq. 0 ) iposfile(n)=-1
      call fileopen(filename,cnew,iposfile(n))

c     open variable files

       ipress=0
       do 50 i0=1,ireqpars
        if ( ip2(i0) .eq. 25 ) ipress=1
        cfile=mtype(ip2(i0))(1:1)//cpot(1:ipot)//
     * CHAR(0)
        call densesurffilename(cfile,m,filename)
        if ( ioutfile(ip2(i0),n) .eq. 0 ) ioutfile(ip2(i0),n)=-1
        call fileopen(filename,cnew,ioutfile(ip2(i0),n))
50     continue
       
       if ( ipress .eq. 0 .and. ipressno .eq. 0 ) then
        cfile=mtype(25)(1:1)//cpot(1:ipot)//CHAR(0)
        call densesurffilename(cfile,m,filename)
        if ( ioutfile(25,n) .eq. 0 ) ioutfile(25,n)=-1
        call fileopen(filename,cnew,ioutfile(25,n))
       endif
45    continue

      return
      end

      SUBROUTINE OPENER(isoor,m,ireqpars,ns,ih2)
 
C     OPENER DECIDES WHICH FILES NEED TO BE OPENED
C     BASED ON USER INPUT AND OPENS THEM.
C     THE BASIC FILE NAME CONFIGURATION IS AS FOLLOWS:
C     /MAIN DIRECTORY BRANCH/PROBETYPE/'OBSERVED' OR 'STANDARD'/
C      PARAMETERNAME.  THE MAIN DIRECTORY BRANCH IS HARDWIRED
C     IN C SUBROUTINE FILEOPEN, THE PROBETYPE AND PARAMETERNAME
C     ARE GLOBAL C VARIABLES, THE CORRECT ONE BEING ACCESSED
C     ACCORDING TO PROBE AND PARAMETER CODES.  OBSERVED OR 
C     STANDARD IS BASED ON PARAMETER ISOOR.  FILES ARE 
C     UNIFORMILY NUMBERED IN THE OCL SYSTEM. 0 IS FOR DEPTH
C     FILE, 1 IS FOR HEADER FILE, THE PARAMETER FILES ARE NUMBERED
C     BASED ON THE PARAMETER CODE.  IF TWO SETS OF FILES ARE
C     OPENED, THE NUMBERS ARE SEPERATED BY A FACTOR BASED ON 
C     THE NUMBER OF REQUESTED PARAMETERS. 

c-----------------------------------------------------------
c
c     Subroutine Steps:
c
c      1. calculate nselect, based on file set number and 
c         number of desired parameters
c      2. open depth file if observed levels are being
c         investigated
c      3. open parameter files
c      4. open header file
c      5. open second header file
c
c------------------------------------------------------------

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Passed Variables:
c
c      isoor - observed (0) or standard (1) levels
c      m - probe code
c      ireqpars - number of requested parameters
c      ns - set number, usually one, unless more than one
c           probe type (or the same probe type twice) are 
c           being investigated.
c      ih2 - special file opening instructions.
c            -2 - no second header, no header, no depth
c            -1 - second header, no header, no depth
c             0 - no second header, header, depth
c             1 - second header, header, depth
c             2 - no second header, header, no depth
c             3 - no second header, no header, depth
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Parameters:
c
c      maxlevel - maximum number of depth levels
c      nprobe - maximum number of proves the system can accomodate.
c      maxparm - maximum number of measured parameters
c      maxcalc - maximum number of measured and calculated parameters
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      parameter (maxlevel=6000, nprobe=100, maxparm=100, maxcalc=200)

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Character Variable:
c
c      filename - constructed file name
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      character*11 ctype(nprobe)
      character*80 filename
      
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Common Blocks:
c
c      reqps - contains ip2, the requested parameter codes
c      extra - contains ireqpars2 which is the number of 
c              requested calculated parameters.  Also contains
c              ireqsecond, which is number of second header
c              parameters, and ireqbio, which is number of
c              biological parameters
c      twoparm - contains itwo.  If itwo is greater than zero,
c                a special data type is associated with this
c                parameter.  An itwo of one is a second header,
c                of two is biological data.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      
      common /reqps/ ip2(0:maxlevel)
      common /extra/ ireqpars2,ireqsecond,ireqbio
      common /twoparm/ itwo(0:maxparm)
      common /probes/ ctype
 

      do iclr=1,80 !- LINUX clearing
       filename(iclr:iclr) = " "
      enddo      

      ifn=0
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Set the file set factor:  This factor seperates file numbers
c     for different sets of files being opened in the same 
c     program.  This is necessary since file numbers are set 
c     according to order of parameter requests.  The factor
c     (nselect) is twice the number of requested parameters 
c     ( to include observed and standard files ) * the set number + 
c     3* the set number to accomodate depth, header and
c     second header files.
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
 
      ireqtot = ireqpars
      nselect = (2 * ireqtot * (ns - 1)) + 3*( ns - 1)
 
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     If observed levels are being investigated  
c     then open depth file, (if either depth
c     is specifically requested by parameter code -1, or if 
c     more than just header information is being investigated
c     (ireqtots greater than zero)).
c
c     nameother sets the file name for headers and depth files
c     taking the name (with C end character array marker ('\0')
c     and the probe code and returning a constructed filename.
c
c     fileopen takes the constructed file name, an opener code
c     and the file number and opens the correct file
c
c     the prefered file code is rb+.  This opens a file for
c     binary reading and writing.
c
c     depth files are file number zero
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      if (isoor.lt.1) then
       if ( ireqtot .gt. 0 .or. ip2(1) .eq. -1) then
        
        if ( ih2 .ge. 0 .and. ih2.ne.2 ) then
         
         call nameother('depths'//CHAR(0),m,filename)
         call fileopen( filename,'rb+'//CHAR(0),nselect+0)
         
        endif
        
       endif
      endif
      

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Run through the same procedure for each parameter
c
c     Note that calculated parameters are only opened on
c     standard levels, since they only exist on standard
c     levels.
c
c     namefile is the basic parameter file naming subroutine.
c
c      inputs are:
c
c      isoor - either zero for observed levels
c      or one for standard levels.     
c      i0 - parameter code
c      i - parameter order
c      m - probe number
c      ireqtot - number of requested measured and calculated
c                 parameters.
c
c      outputs are:
c
c      ifn - calculated file number
c      filename - constructed file number 
c
c      If this is a special parameter (itwo greater than zero),
c      only standard level data files are opened, even if 
c      observed levels are being investigated.  This is because
c      special data is not depth dependent.
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      do 100 i=1,ireqtot

       i0 = ip2(i)
       
       if ( i0.lt.0 .or. itwo(i0).eq.1 ) goto 100
       
       if ( itwo(i0) .gt. 0 ) then
        iso=1
       else
        iso=isoor
       endif
       
       if ( i .le. ireqpars .or. isoor .eq. 1 ) then
        
        call namefile(iso,i0,i,m,ifn,ireqtot,filename)
        call fileopen( filename,'rb+'//CHAR(0),nselect+ifn)
        
       endif
       
 100  continue
 
ccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Open header file in the same manner as depth file
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
  
      if ( ih2 .ge. 0 .and. ih2.ne. 3 ) then

       call nameother('headers'//CHAR(0),m,filename)
       call fileopen( filename,'rb+'//CHAR(0),nselect+1)
      endif

ccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Open second header file in the same manner as depth file
c     if desired.  Header2 file number is fileset number (fselect)
c     + number of parameters *2 (for observed and standard) +
c     2
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      
      if ( abs(ih2) .eq.1 ) then

       call nameother('header2'//CHAR(0),m,filename)
       call fileopen( filename,'rb+'//CHAR(0),
     *  nselect+(2*ireqtot)+2)
       
      endif
      
      return
      end

      SUBROUTINE OVERMAX(maxlevel,nps,k0,np0,k,np)

C     OVERMAX CALCULATES THE POSITION OF A READING WHICH
C     HAS AN INDICES GREATER THAN MAXLEVEL

c*******************************************************
c
c     Passed Variables
c
c      maxlevel - maximum allowable index for data array
c      nps - parameter number for second header.  This is
c            the maximum parameter number (second elemen location).
c      k0 - original index
c      np0 - original second element location in data array
c      k - new index
c      np - new second element location in data array
c
c*******************************************************

c*******************************************************
c
c     ir2 is the number of requested calculated
c     parameters.  This is needed to figure out the
c     new second element location.  However, calculated
c     parameters are rarely used.  In most cases ir2=0
c
c*******************************************************

      common /extra/ ir2,ireqsecond,ireqbio

      np=0
      k=0

      k1=(k0-1)/maxlevel
      
      k= k0 - (k1*maxlevel)

      if ( k0 .gt. maxlevel ) then
       if ( ir2 .gt. maxlevel ) ir2=0
       np= ((nps+ir2+2)*k1)+ np0
      else
       np= np0
      endif

      return
      end

      SUBROUTINE readgournew1(maxyear,monthx,ntyp,thermal_bias,
     * nyearmin,nyearmax)
      parameter (icmax=10)
      character*80 text, filename

      dimension thermal_bias(maxyear,monthx,ntyp)
      dimension icomma(icmax,2)

      call extraname('sys.inf'//CHAR(0),
     * 'bias_thermal_t4t6_monthly.dat'//CHAR(0),filename)

       open(9,file=filename,status='old')
 
      nyearmin=maxyear
      nyearmax=0

      do 50 ny=1,3000
       call clearstring(text,80)
      read(9, '(a)', end=4) text
      call findlastchar(nsp,text,80)

      call commafindx(nsp,icmax,ncomma,icomma,text)
      if ( ncomma .lt. 2) goto 50
      read(text(icomma(3,1):icomma(3,1)+icomma(3,2)-1),*)
     * nyear
       if (nyear .lt. 1967) nyearmin=nyear
       if (nyear .gt. nyearmax) nyearmax=nyear
c      write(6,*)'nyearmin,nyearmax,t4',nyearmin,nyearmax
      read(text(icomma(4,1):icomma(4,1)+icomma(4,2)-1),*)
     * month
      read(text(icomma(5,1):icomma(5,1)+icomma(5,2)-1),*)
     * thermal_bias(nyear,month,1)

c       write(6,*) iyear,month,thermal_bias(iyear,month,1)
50    continue
4     continue
      close(9)

      return
      end
      SUBROUTINE readgournew2(maxyear,monthx,ntyp,thermal_bias,
     * nyearmin,nyearmax)
      parameter (icmax=10)
      character*80 text, filename

      dimension thermal_bias(maxyear,monthx,ntyp)
      dimension icomma(icmax,2)

      call extraname('sys.inf'//CHAR(0),
     * 'bias_thermal_t7db_monthly.dat'//CHAR(0),filename)

       open(9,file=filename,status='old')
      nyearmin=maxyear
      nyearmax=0

      do 50 ny=1,3000
       call clearstring(text,80)
      read(9, '(a)', end=4) text
      call findlastchar(nsp,text,80)

      call commafindx(nsp,icmax,ncomma,icomma,text)
      if ( ncomma .lt. 2) goto 50
      read(text(icomma(3,1):icomma(3,1)+icomma(3,2)-1),*)
     * nyear
       if (nyear .lt. 1967) nyearmin=nyear
       if (nyear .gt. nyearmax) nyearmax=nyear
c      write(6,*) 'nyearmax,nyearmin,t7',nyearmax,nyearmin
      read(text(icomma(4,1):icomma(4,1)+icomma(4,2)-1),*)
     * month
      read(text(icomma(5,1):icomma(5,1)+icomma(5,2)-1),*)
     * thermal_bias(nyear,month,2)

c       write(6,*) iyear,month,thermal_bias(iyear,month,2)
50    continue
4     continue
      close(9)

      return
      end
      SUBROUTINE readgournew3(maxyear,monthx,ntyp,thermal_bias,
     * myearmin,myearmax)
      parameter (icmax=10)
      character*80 text, filename

      dimension thermal_bias(maxyear,monthx,ntyp)
      dimension icomma(icmax,2)

      call extraname('sys.inf'//CHAR(0),
     * 'bias_thermal_t5_monthly.dat'//CHAR(0),filename)

       open(9,file=filename,status='old')
      myearmin=maxyear
      myearmax=0

      do 50 ny=1,3000
       call clearstring(text,80)
      read(9, '(a)', end=4) text
      call findlastchar(nsp,text,80)

      call commafindx(nsp,icmax,ncomma,icomma,text)
      if ( ncomma .lt. 2) goto 50
      read(text(icomma(3,1):icomma(3,1)+icomma(3,2)-1),*)
     * nyear
       if (nyear .lt. 1984) myearmin=nyear
       if (nyear .gt. myearmax) myearmax=nyear
c      write(6,*) 'myearmin,myearmax,t5',myearmin,myearmax
      read(text(icomma(4,1):icomma(4,1)+icomma(4,2)-1),*)
     * month
      read(text(icomma(5,1):icomma(5,1)+icomma(5,2)-1),*)
     * thermal_bias(nyear,month,3)

c       write(6,*) iyear,monthx,thermal_bias(iyear,monthx,3)
50    continue
4     continue
      close(9)

      return
      end
      SUBROUTINE readgournew4(maxyear,monthx,maxlevel,ntyp,dstretch,
     * nyearmin,nyearmax)
      parameter (icmax=10)
      character*80 text, filename
      dimension dstretch(maxyear,monthx,maxlevel,ntyp)
      dimension icomma(icmax,2)
      call extraname('sys.inf'//CHAR(0),
     * 'stretching_t4t6_monthly_1meter.dat'//CHAR(0),
     * filename)
       open(9,file=filename,status='old')
c       open(10,file='./gour_res.dat')
c      read(9,*,end=44) depth,iyear,xmonth,thermal_bias
c    read in headers
c      read(9,'(a)') text
      nyearmin=maxyear
      nyearmax=0
      do 50 ny=1,300000
       call clearstring(text,80)
      read(9, '(a)', end=4) text
      call findlastchar(nsp,text,80)

      call commafindx(nsp,icmax,ncomma,icomma,text)
      if ( ncomma .lt. 2) goto 50
      read(text(icomma(2,1):icomma(2,1)+icomma(2,2)-1),*)
     * nyear
       if (nyear .lt. 1967) nyearmin=nyear
       if (nyear .gt. nyearmax) nyearmax=nyear
c      write(6,*)'nyearmin,nyearmax,t4',nyearmin,nyearmax
      read(text(icomma(3,1):icomma(3,1)+icomma(3,2)-1),*)
     * month
      read(text(icomma(4,1):icomma(4,1)+icomma(4,2)-1),*)
     * idepth
      read(text(icomma(5,1):icomma(5,1)+icomma(5,2)-1),*)
     * dstretch(nyear,month,idepth,1)
c       write(6,*) iyear,monthx,idepth,dstretch(iyear,monthx,idepth,1)
50    continue
4     continue
      close(9)
      return
      end
      SUBROUTINE readgournew5(maxyear,monthx,maxlevel,ntyp,dstretch,
     * oyearmin,oyearmax)
      parameter (icmax=10)
      character*80 text, filename
c      parameter (dstretch=3000)
      dimension dstretch(maxyear,monthx,maxlevel,ntyp)
      dimension icomma(icmax,2)
      call extraname('sys.inf'//CHAR(0),
     * 'stretching_t7db_monthly_1meter.dat'//CHAR(0),
     * filename)
       open(9,file=filename,status='old')
c       open(10,file='./gour_res.dat')
c      read(9,*,end=44) depth,iyear,xmonth,thermal_bias
c    read in headers
c      read(9,'(a)') text
      oyearmin=maxyear
      oyearmax=0
      do 50 ny=1,500000
       call clearstring(text,80)
      read(9, '(a)', end=4) text
      call findlastchar(nsp,text,80)

      call commafindx(nsp,icmax,ncomma,icomma,text)
      if ( ncomma .lt. 2) goto 50
      read(text(icomma(2,1):icomma(2,1)+icomma(2,2)-1),*)
     * nyear
        if (nyear .lt. oyearmin) oyearmin =1970
        if (nyear .gt. oyearmax) oyearmax=nyear
c        write(6,*)'oyearmin,oyearmax,t7',oyearmin,oyearmax 
c       write(6,*) 'iyear,myearmin,myearmax',iyear,myearmin,myearmax
      read(text(icomma(3,1):icomma(3,1)+icomma(3,2)-1),*)
     * month
      read(text(icomma(4,1):icomma(4,1)+icomma(4,2)-1),*)
     * idepth
      read(text(icomma(5,1):icomma(5,1)+icomma(5,2)-1),*)
     * dstretch(nyear,month,idepth,2)
c       write(6,*) iyear,monthx,idepth,dstretch(iyear,monthx,idepth,2)
50    continue
4     continue
      close(9)
      return
      end
      SUBROUTINE readgournew6(maxyear,monthx,maxdepth,ntyp,dstretch,
     * myearmin,myearmax)
      parameter (icmax=10)
      character*80 text, filename
c      parameter (dstretch=3000)
      dimension dstretch(maxyear,monthx,maxdepth,ntyp)
      dimension icomma(icmax,2)
      call extraname('sys.inf'//CHAR(0),
     * 'stretching_t5_monthly_1meter.dat'//CHAR(0),
     * filename)
       open(9,file=filename,status='old')
c       open(10,file='./gour_res.dat')
c      read(9,*,end=44) depth,iyear,xmonth,thermal_bias
c    read in headers
c      read(9,'(a)') text
      myearmin=maxyear
      myearmax=0
      do 50 ny=1,500000
       call clearstring(text,80)
      read(9, '(a)', end=4) text
      call findlastchar(nsp,text,80)

      call commafindx(nsp,icmax,ncomma,icomma,text)
      if ( ncomma .lt. 2) goto 50
      read(text(icomma(2,1):icomma(2,1)+icomma(2,2)-1),*)
     * nyear
       if (nyear .lt. 1984) myearmin=nyear
       if (nyear .gt. myearmax) myearmax=nyear
c       write(6,*)'myearmin,myearmin,t5',myearmin,myearmin
      read(text(icomma(3,1):icomma(3,1)+icomma(3,2)-1),*)
     * month
      read(text(icomma(4,1):icomma(4,1)+icomma(4,2)-1),*)
     * idepth
      read(text(icomma(5,1):icomma(5,1)+icomma(5,2)-1),*)
     * dstretch(nyear,month,idepth,3)
c       write(6,*) iyear,monthx,idepth,dstretch(iyear,monthx,idepth,3)
50    continue
4     continue
      close(9)
      return
      end
      SUBROUTINE readgournew7(maxyear,ntyp,coeff1,coeff2,
     * t_bias,nyearmin,nyearmax)
      parameter (icmax=10)
      character*80 text, filename
c      parameter (dstretch=3000)
      dimension t_bias(maxyear,ntyp)
      dimension coeff1(maxyear,ntyp)
      dimension coeff2(maxyear,ntyp)
      dimension icomma(icmax,2)

      call extraname('sys.inf'//CHAR(0),
     * 'gour_depth_temp_bias_t10.dat'//CHAR(0),
     * filename)
       open(9,file=filename,status='old')
c       open(10,file='./gour_res.dat')
c      read(9,*,end=44) depth,iyear,xmonth,thermal_bias
c    read in headers
c      read(9,'(a)') text
      nyearmin=maxyear
      nyearmax=0
      do 50 ny=1,maxyear
       call clearstring(text,80)
      read(9, '(a)', end=4) text
      call findlastchar(nsp,text,80)

      call commafindx(nsp,icmax,ncomma,icomma,text)
      if ( ncomma .lt. 2) goto 50
      read(text(icomma(1,1):icomma(1,1)+icomma(1,2)-1),*)
     * nyear
       if (nyear .lt. 1967) nyearmin=nyear
       if (nyear .gt. nyearmax) nyearmax=nyear
c      write(6,*) 'nyearmin,nyearmax,t10',nyearmin,nyearmax
      read(text(icomma(2,1):icomma(2,1)+icomma(2,2)-1),*)
     * coeff1(nyear,4)
      read(text(icomma(3,1):icomma(3,1)+icomma(3,2)-1),*)
     * coeff2(nyear,4)
      read(text(icomma(4,1):icomma(4,1)+icomma(4,2)-1),*)
     * t_bias(nyear,4)
c       write(6,*)'iyear', iyear,coeff1(iyear,4),
c     * coeff2(iyear,4), t_bias(iyear,4)
50    continue
4     continue
      close(9)
      return
      end
      SUBROUTINE readhamontable1(maxyear,ntyp,toff)
c     readhamontable1 reads data from Hamon et al 2012
c     table 1 (temperture bias)

      parameter (icmax=10)
      character*80 text, filename

      dimension toff(maxyear,ntyp)
      dimension icomma(icmax,2)

      call extraname('sys.inf'//CHAR(0),
     *  'hamon_table1.txt'//CHAR(0),filename)
      open(9,file=filename,status='old')

c     read in headers
      
      read(9,'(a)') text
      read(9,'(a)') text
      read(9,'(a)') text
      nyearmin=maxyear
      nyearmax=0

      do 50 ny=1,maxyear
      
       call clearstring(text,80)
       read(9,'(a)',end=4) text
       call findlastchar(nsp,text,80)

       call commafindx(nsp,icmax,ncomma,icomma,text)
       if ( ncomma .lt. 2 ) goto 50
       read(text(icomma(1,1):icomma(1,1)+icomma(1,2)-1),*)
     * nyear
      if (nyear .lt. nyearmin ) nyearmin=nyear
      if (nyear .gt. nyearmax ) nyearmax=nyear
 
c      write(6,*) nyear,icomma(1,1),icomma(1,2),text(icomma(1,1):
c     *  icomma(1,1)+icomma(1,2)-1)
 
       read(text(icomma(2,1):icomma(2,1)+icomma(2,2)-1),*)
     * toff(nyear,1)
       read(text(icomma(3,1):icomma(3,1)+icomma(3,2)-1),*)
     * toff(nyear,3)
       if (icomma(4,2) .gt. 0) then
       if (ncomma .ge. 4) then
       read(text(icomma(4,1):icomma(4,1)+icomma(4,2)-1),*)
     * toff(nyear,5)
       
       toff(nyear,2)=toff(nyear,1)
       toff(nyear,4)=toff(nyear,3)
       toff(nyear,6)=toff(nyear,5)

c       write(6,*) nyear,toff(nyear,1),toff(nyear,2),toff(nyear,3),
c     *  toff(nyear,4),toff(nyear,5),toff(nyear,6)
       endif
       endif
50     continue
4      continue
       close(9)

       return
       end

       SUBROUTINE readhamontable2(maxyear,ntyp,doffDA,doffDB,doffZD,
     *  nyearmin,nyearmax)

c    readhamontable2 reads dats from hamon table 2 for deep probes
c    deployed in low and high temperature waters

      parameter (icmax=10)
      character*80 text,filename

      dimension doffDA(maxyear,ntyp)
      dimension doffDB(maxyear,ntyp)
      dimension doffZD(maxyear,ntyp)
      dimension icomma(icmax,2)

      call extraname('sys.inf'//CHAR(0),
     * 'hamon_table2.txt'//CHAR(0),filename)
      open(9,file=filename,status='old')

c     reading headers
      read(9,'(a)') text
      read(9,'(a)') text
      read(9,'(a)') text
c     read in data
c     column 1: year
c     column 2: ADL
c     column 3: BDL
c     column 4: ZoffDL
c     column 5: ADH
c     column 6: BDH
c     column 7: ZoffDH

      nyearmax=0
      nyearmin=maxyear
      do 50 ny=1,maxyear

      call clearstring(text,80)
      read(9,'(a)', end=4) text
      call findlastchar(nsp,text,80)

      call commafindx(nsp,icmax,ncomma,icomma,text)
       if (ncomma .lt. 2) goto 50

       read(text(icomma(1,1):icomma(1,1)+icomma(1,2)-1),*)
     * nyear
       if (nyear .lt. nyearmin ) nyearmin=nyear
       if (nyear .gt. nyearmax ) nyearmax=nyear
 
       read(text(icomma(2,1):icomma(2,1)+icomma(2,2)-1),*)
     * doffDA(nyear,1)
       read(text(icomma(3,1):icomma(3,1)+icomma(3,2)-1),*)
     * doffDB(nyear,1)
       read(text(icomma(4,1):icomma(4,1)+icomma(4,2)-1),*)
     * doffZD(nyear,1)

       read(text(icomma(5,1):icomma(5,1)+icomma(5,2)-1),*)
     * doffDA(nyear,2)
       read(text(icomma(6,1):icomma(6,1)+icomma(6,2)-1),*)
     * doffDB(nyear,2)
       read(text(icomma(7,1):icomma(7,1)+icomma(7,2)-1),*)
     * doffZD(nyear,2)

c      write(6,*) nyear,doffDA(nyear,1),doffDB(nyear,1),doffZD(nyear,1)
c     * ,doffDA(nyear,2),doffDB(nyear,2),doffZD(nyear,2)
50     continue
4      continue
       close(9)

       return
       end

       SUBROUTINE readhamontable3(maxyear,ntyp,doffDA,doffDB,doffZD,
     *  nyearmin,nyearmax)

c    readhamontable2 reads dats from hamon table 2 for deep probes
c    deployed in low and high temperature waters

      parameter (icmax=10)
      character*80 text,filename

      dimension doffDA(maxyear,ntyp)
      dimension doffDB(maxyear,ntyp)
      dimension doffZD(maxyear,ntyp)
      dimension icomma(icmax,2)

      call extraname('sys.inf'//CHAR(0),
     * 'hamon_table3.txt'//CHAR(0),filename)
      open(9,file=filename,status='old')

c     reading headers
      read(9,'(a)') text
      read(9,'(a)') text
c     read in data
c     column 1: year
c     column 2: ADL
c     column 3: BDL
c     column 4: ZoffDL
c     column 5: ADH
c     column 6: BDH
c     column 7: ZoffDH

      nyearmax=0
      nyearmin=maxyear
      do 50 ny=1,maxyear

      call clearstring(text,80)
      read(9,'(a)', end=4) text
      call findlastchar(nsp,text,80)

      call commafindx(nsp,icmax,ncomma,icomma,text)
       if (ncomma .lt. 2) goto 50

       read(text(icomma(1,1):icomma(1,1)+icomma(1,2)-1),*)
     * nyear
       if (nyear .lt. nyearmin ) nyearmin=nyear
       if (nyear .gt. nyearmax ) nyearmax=nyear
       
       read(text(icomma(2,1):icomma(2,1)+icomma(2,2)-1),*)
     * doffDA(nyear,3)
       read(text(icomma(3,1):icomma(3,1)+icomma(3,2)-1),*)
     * doffDB(nyear,3)
       read(text(icomma(4,1):icomma(4,1)+icomma(4,2)-1),*)
     * doffZD(nyear,3)

       read(text(icomma(5,1):icomma(5,1)+icomma(5,2)-1),*)
     * doffDA(nyear,4)
       read(text(icomma(6,1):icomma(6,1)+icomma(6,2)-1),*)
     * doffDB(nyear,4)
       read(text(icomma(7,1):icomma(7,1)+icomma(7,2)-1),*)
     * doffZD(nyear,4)

c      write(6,*) nyear,doffDA(nyear,3),doffDB(nyear,3),doffZD(nyear,3)
c     * ,doffDA(nyear,4),doffDB(nyear,4),doffZD(nyear,4)


50     continue
4      continue
       close(9)

       return
       end

       SUBROUTINE readhamontable4(maxyear,ntyp,doffDA,doffDB,doffZD,
     *  myearmin,myearmax)

c    readhamontable2 reads dats from hamon table 2 for deep probes
c    deployed in low and high temperature waters

      parameter (icmax=10)
      character*80 text,filename
     
      dimension doffDA(maxyear,ntyp)
      dimension doffDB(maxyear,ntyp)
      dimension doffZD(maxyear,ntyp)

      dimension icomma(icmax,2)

      call extraname('sys.inf'//CHAR(0),
     * 'hamon_table4.txt'//CHAR(0),filename)
      open(9,file=filename,status='old')

c     reading headers
      read(9,'(a)') text
      read(9,'(a)') text
c     read in data
c     column 1: year
c     column 2: ADWP
c     column 3: BDWP
c     column 4: ZoffDWP
c     column 5: ASWP
c     column 6: BSWP
c     column 7: ZoffSWP

      myearmax=0
      myearmin=maxyear
      do 50 ny=1,maxyear

      call clearstring(text,80)
      read(9,'(a)', end=4) text
      call findlastchar(nsp,text,80)

      call commafindx(nsp,icmax,ncomma,icomma,text)
       if (ncomma .lt. 2) goto 50

       read(text(icomma(1,1):icomma(1,1)+icomma(1,2)-1),*)
     * nyear
      if (nyear .lt. myearmin ) myearmin=nyear
      if (nyear .gt. myearmax ) myearmax=nyear

       doffDA(nyear,5)=0.0
       call checkifallspace(text,icomma(2,1),icomma(2,2),notspace)
       if ( notspace .eq. 0 ) 
     *  read(text(icomma(2,1):icomma(2,1)+icomma(2,2)-1),*)
     *  doffDA(nyear,5)

       doffDB(nyear,5)=0.0
       call checkifallspace(text,icomma(3,1),icomma(3,2),notspace)
       if ( notspace .eq. 0 ) 
     *  read(text(icomma(3,1):icomma(3,1)+icomma(3,2)-1),*)
     *  doffDB(nyear,5)

       doffZD(nyear,5)=0.0
       call checkifallspace(text,icomma(4,1),icomma(4,2),notspace)
       if ( notspace .eq. 0 ) 
     *  read(text(icomma(4,1):icomma(4,1)+icomma(4,2)-1),*)
     *  doffZD(nyear,5)

       doffDA(nyear,6)=0.0
       call checkifallspace(text,icomma(5,1),icomma(5,2),notspace)
       if ( notspace .eq. 0 ) 
     *  read(text(icomma(5,1):icomma(5,1)+icomma(5,2)-1),*)
     *  doffDA(nyear,6)

       doffDB(nyear,6)=0.0
       call checkifallspace(text,icomma(6,1),icomma(6,2),notspace)
       if ( notspace .eq. 0 ) 
     *  read(text(icomma(6,1):icomma(6,1)+icomma(6,2)-1),*)
     *  doffDB(nyear,6)

       doffZD(nyear,6)=0.0
       call checkifallspace(text,icomma(7,1),icomma(7,2),notspace)
       if ( notspace .eq. 0 ) 
     *  read(text(icomma(7,1):icomma(7,1)+icomma(7,2)-1),*)
     *  doffZD(nyear,6)
c      write(6,*) nyear,doffDA(nyear,1),doffDB(nyear,1),doffZD(nyear,1)
c     * ,doffDA(nyear,2),doffDB(nyear,2),doffZD(nyear,2),doffDA(nyear,3),
c     * doffDB(nyear,3),doffZD(nyear,3),doffDA(nyear,4),doffDB(nyear,4),
c     * doffZD(nyear,4),doffDA(nyear,5),doffDB(nyear,5),doffZD(nyear,5)
c     * ,doffDA(nyear,6),doffDB(nyear,6),doffZD(nyear,6)




50     continue
4      continue
       close(9)

       return
       end

      SUBROUTINE READINPARAM(ik)

C     GET VARIABLE FOR PRESENT RUN OF FINALSD

      open(9,file='./in.param',status='old')
      read(9,*) inparm
      close(9)

      open(9,file='./infinalsd.i',status='old')

      do 834 n=1,inparm-1
834    read(9,*) idumx

      read(9,*) ik
      close(9)

      return
      end

      SUBROUTINE READINTFROMCHAR(nout,nint,n1,n2,chardat)

C     SUBROUTINE TO EXTRACT AN INTEGER FROM A
C     CHARACTER STRING

      character*5 cform
      character*(*) chardat

      nout=0
      if ( nint .eq. 0 ) return
      cform='(i0X)'
      if ( nint .gt. 9 ) then
c      write(cform(3:4),'(i2)') nint
       return
      else
       write(cform(4:4),'(i1)') nint
      endif

c     write(6,*) cform,chardat,n1,n2,nint,
c    * chardat(n1:n2)
      read(chardat(n1:n2),cform,err=4) nout
c     write(6,*) 'read in'

      return
4     nout=0
c     write(6,*) 'not read in'
      return
      end 
      SUBROUTINE READLIJINGTABLE1(maxyear,ntyp,dcorr1,nyearmin,
     * nyearmax)

C     READLIJINGTABLE5 READS DATA FROM LIJING ET AL. 2014
C     TABLE 1  (DEPTH CORRECTION ).

      parameter (icmax=20)
      parameter (xdroph=6.691)
      parameter (xdropt5=6.828,xdropt10=6.301)
      character*200 text,filename
 
      dimension dcorr1(maxyear,ntyp)
      dimension icomma(icmax,2),xdrop(icmax)

      call extraname('sys.inf'//CHAR(0),
     * 'CH14_table1.txt'//CHAR(0),filename)
      open(9,file=filename,status='old')

c     read in headers

      do 20 n=1,1
20     read(9,'(a)') text

c     read in data
c    column 1: year
c    column 2: T7/DB
c    column 3: unk_deep
c    column 4: T4/T6
c    column 5: unk_shallow
c    column 6: T10
c    column 7: T5
c    column 8: TSK T4/T6
c    column 9: TSK T5
c    column 10: TSK T7

      xdrop(1)=xdroph
      xdrop(2)=xdroph
      xdrop(3)=xdroph
      xdrop(4)=xdroph
      xdrop(5)=xdropt10
      xdrop(6)=xdropt5
      xdrop(7)=xdroph
      xdrop(8)=xdropt5
      xdrop(9)=xdroph

      nyearmax=0
      nyearmin=maxyear
      do 50 ny=1,maxyear

       call clearstring(text,200)
       read(9,'(a)',end=4) text
       call findlastchar(nsp,text,200)

       call spacefindl(nsp,icmax,ncomma,icomma,text)
       if ( ncomma .lt. 2 ) goto 50

       read(text(icomma(1,1):icomma(1,1)+icomma(1,2)-1),*)
     *  nyear
c      xyear=xyear*1000.
c      nyear=xyear+0.1
c      write(6,*) 'xyear',nyear,xyear
       if ( nyear .gt. nyearmax ) nyearmax=nyear
       if ( nyear .lt. nyearmin ) nyearmin=nyear

       do 55 nx=1,ncomma-1
        nc=nx+1
        dcorr1(nyear,nx)=xdrop(nx)
        if ( text(icomma(nc,1):icomma(nc,1)+icomma(nc,2)-1)
     *      .ne. 'NaN' ) then
         read(text(icomma(nc,1):icomma(nc,1)+icomma(nc,2)-1),*)
     *    dcorr1(nyear,nx)
        endif
c       write(6,*) 'acorr',nyear,dcorr1(nyear,1)
55     continue

50    continue
4     continue
      close(9)

      return
      end
      SUBROUTINE READLIJINGTABLE2(maxyear,ntyp,tbias_1)

C     READLIJINGTABLE2 READS DATA FROM LIJING ET AL. 2014
C     TABLE 2  (TEMPERATURE BIAS ).

      parameter (icmax=20)
      character*200 text,filename
 
      dimension tbias_1(maxyear,ntyp)
      dimension icomma(icmax,2)

      call extraname('sys.inf'//CHAR(0),
     * 'CH14_table2.txt'//CHAR(0),filename)
      open(9,file=filename,status='old')

c     read in headers

      do 20 n=1,1
20     read(9,'(a)') text

c     read in data
c    column 1: year
c    column 2: T7/DB
c    column 3: unk_deep
c    column 4: T4/T6
c    column 5: unk_shallow
c    column 6: T10
c    column 7: T5
c    column 8: TSK T4/T6
c    column 9: TSK T5
c    column 10: TSK T7

      do 50 ny=1,maxyear

       call clearstring(text,200)
       read(9,'(a)',end=4) text
       call findlastchar(nsp,text,200)

       call spacefindl(nsp,icmax,ncomma,icomma,text)
       if ( ncomma .lt. 2 ) goto 50

       read(text(icomma(1,1):icomma(1,1)+icomma(1,2)-1),*)
     *  nyear
c      nyear=(xyear*1000.)+0.1

       do 55 nx=1,ncomma-1
        nc=nx+1
        tbias_1(nyear,nx)=0.0
        if ( text(icomma(nc,1):icomma(nc,1)+icomma(nc,2)-1)
     *      .ne. 'NaN' ) then
         read(text(icomma(nc,1):icomma(nc,1)+icomma(nc,2)-1),*)
     *    tbias_1(nyear,nx)
c        write(6,*) 'xx',nc,nx,nyear,tbias_1(nyear,nx)
        endif

55     continue

50    continue
4     continue
      close(9)

      return
      end
      SUBROUTINE READLIJINGTABLE_COEFF(maxtype,a1,a2,b1,b2,at1,tt1,tt2)

C     READLIJINGTABLE_COEFF READS COEFF DATA FROM LIJING ET AL. 2014

      parameter (icmax=20)
      character*80 text,filename
 
      dimension a1(maxtype),a2(maxtype)
      dimension b1(maxtype),b2(maxtype)
      dimension at1(maxtype),tt1(maxtype)
      dimension tt2(maxtype)
      dimension icomma(icmax,2)

      call extraname('sys.inf'//CHAR(0),
     * 'CH14_coeff.txt'//CHAR(0),filename)
      open(9,file=filename,status='old')

c     read in headers

      do 30 nn=1,2
30     read(9,'(a)') text

c     read in data
c    column 1: Type
c     row1 = T4/T6 - SX - T10
c     row2 = T7/DB - DX - T5
c     row3 = all TSK
c    column 2: a1
c    column 3: a2
c    column 4: b1
c    column 5: b2

c     put in arrays as
c    1: T7/DB
c    2: unk_deep
c    3: T4/T6
c    4: unk_shallow
c    5: T10
c    6: T5
c    7: TSK T4/T6
c    8: TSK T5
c    9: TSK T7

      do 50 ny=1,4

       call clearstring(text,80)
       read(9,'(a)',end=4) text
       call findlastchar(nsp,text,80)

       call commafindx(nsp,icmax,ncomma,icomma,text)

       read(text(icomma(2,1):icomma(2,1)+icomma(2,2)-1),*) a1in
       read(text(icomma(3,1):icomma(3,1)+icomma(3,2)-1),*) a2in
       read(text(icomma(4,1):icomma(4,1)+icomma(4,2)-1),*) b1in
       read(text(icomma(5,1):icomma(5,1)+icomma(5,2)-1),*) b2in
       if ( ncomma .gt. 5 ) then
        read(text(icomma(6,1):icomma(6,1)+icomma(6,2)-1),*) atx
        read(text(icomma(7,1):icomma(7,1)+icomma(7,2)-1),*) tta
        read(text(icomma(8,1):icomma(8,1)+icomma(8,2)-1),*) ttb
       endif

       if ( ny .eq. 1 ) then
        a1(3)=a1in
        a2(3)=a2in
        a1(4)=a1in
        a2(4)=a2in
        a1(5)=a1in
        a2(5)=a2in
        b1(3)=b1in
        b2(3)=b2in
        b1(4)=b1in
        b2(4)=b2in
        b1(5)=b1in
        b2(5)=b2in
        at1(3)=atx
        tt1(3)=tta
        tt2(3)=ttb
        at1(4)=atx
        tt1(4)=tta
        tt2(4)=ttb
        at1(5)=atx
        tt1(5)=tta
        tt2(5)=ttb
        at1(5)=atx
        tt1(5)=tta
        tt2(5)=ttb
        at1(7)=atx
        tt1(7)=tta
        tt2(7)=ttb
       elseif ( ny .eq. 2 ) then
        a1(1)=a1in
        a2(1)=a2in
        a1(2)=a1in
        a2(2)=a2in
        b1(1)=b1in
        b2(1)=b2in
        b1(2)=b1in
        b2(2)=b2in
        at1(1)=atx
        tt1(1)=tta
        tt2(1)=ttb
        at1(2)=atx
        tt1(2)=tta
        tt2(2)=ttb
        at1(9)=atx
        tt1(9)=tta
        tt2(9)=ttb
       elseif ( ny .eq. 3 ) then
        a1(6)=a1in
        a2(6)=a2in
        b1(6)=b1in
        b2(6)=b2in
        at1(6)=atx
        tt1(6)=tta
        tt2(6)=ttb
        at1(8)=atx
        tt1(8)=tta
        tt2(8)=ttb
       else
        a1(7)=a1in
        a2(7)=a2in
        a1(8)=a1in
        a2(8)=a2in
        a1(9)=a1in
        a2(9)=a2in
        b1(7)=b1in
        b2(7)=b2in
        b1(8)=b1in
        b2(8)=b2in
        b1(9)=b1in
        b2(9)=b2in
       endif
50    continue
4     continue

      close(9)

      return
      end
      SUBROUTINE READLOCKFILE(icounter,maxprobe,
     * probelockrec,ip,lockstat,il,wholockrec,iw,
     * timerec,it,whatrec,iw2,iLOCK,ilockfile)

C     READLOCKFILE READS IN MERGELOCK FILE

      character*80 filename
      character*120 usrrec
      character*(*) probelockrec(maxprobe)
      character*(*) lockstat(maxprobe)
      character*(*) wholockrec(maxprobe)
      character*(*) timerec(maxprobe)
      character*(*) whatrec(maxprobe)
      dimension iLOCK(maxprobe)

      call clearstring(filename,80)
      call extraname('sys.inf'//CHAR(0),
     * 'mergeLOCK.log'//CHAR(0),filename)
      open(ilockfile,file=filename,status='old')

      icounter=0
      call clearstring(usrrec,120)

c     read header lines

      read(ilockfile,'(a)') usrrec
      read(ilockfile,'(a)') usrrec

c     read in probes 

      do 50 nn=1,maxprobe

       call clearstring(usrrec,120)
       iLOCK(nn)=0
       read(ilockfile,'(a)',END=2000) usrrec
       if ( usrrec(3:5) .eq. '   ' ) goto 2000
       icounter=icounter+1

       call readmergeline(usrrec,120,probelockrec(nn),ip,
     *  lockstat(nn),il,wholockrec(nn),iw,timerec(nn),it,
     *  whatrec(nn),iw2)
   
       iLOCK(nn)=0
       if ( lockstat(nn)(1:4) .eq. '*REA' ) iLOCK(nn)=1
       if ( lockstat(nn)(1:4) .eq. '*EXC' ) iLOCK(nn)=2
       if ( lockstat(nn)(1:4) .eq. 'OV_R' ) iLOCK(nn)=3
       if ( lockstat(nn)(1:4) .eq. 'OV_E' ) iLOCK(nn)=4

50    continue
2000  continue

      close(ilockfile,iostat=ios)

      return
      end 
       SUBROUTINE READMAINPROBES(ctypemain,maxmain,nmain)

C      READMAINPROBES READS MAIN PROBE NAMES FROM SYSTEM FILE

       parameter (icmax=50)
       character*(*) ctypemain(maxmain)
       character*80 filename,text
       dimension icomma(icmax,2)

       call extraname('system/infofiles.dir'//CHAR(0),
     *  'probefile.d'//CHAR(0),filename)
  
       open(9,file=filename,status='old')
       read(9,'(a1)') text
       read(9,'(a1)') text
       read(9,*) nmain
       read(9,*) nparm

      do 10 nn=1,9
10     read(9,'(a1)') text

      do 15 nn=1,nparm
15     read(9,'(a1)') text

      do 20 nn=1,5
20     read(9,'(a1)') text

      do 25 nn=1,nmain
       call clearstring(text,80)
       read(9,'(a80)') text
       if ( text(1:1) .eq. 'x' ) text(1:1)=' '

       call spacefindl(80,icmax,ncomma,icomma,text)
       call clearstring(ctypemain(nn),11)
       i1=icomma(1,1)
       i2=icomma(1,1)+icomma(1,2)-1
       ctypemain(nn)(1:icomma(1,2))=text(i1:i2)

25    continue
      close(9)

      return
      end
      SUBROUTINE READMERGELINE(cline,lsize,probelockrec,ip,
     * lockstat,il,wholockrec,iw,timerec,it,whatrec,iw2)

C     READMERGELINE READS IN A LINE FROM
C     THE MERGELOCK FILE AND PLACES THE
C     INFORMATION IN THE APPROPRIATE FIELDS

      parameter (icmax=10)
      character*(*) probelockrec
      character*(*) cline
      character*(*) lockstat
      character*(*) wholockrec
      character*(*) timerec
      character*(*) whatrec
      dimension icomma(icmax,2)

      call spacefindl(lsize,icmax,ncomma,icomma,cline)

      call clearstring(probelockrec,ip)
      call clearstring(lockstat,il)
      call clearstring(wholockrec,iw)
      call clearstring(timerec,it)
      call clearstring(whatrec,iw2)
      probelockrec(1:icomma(1,2))=
     * cline(icomma(1,1):icomma(1,1)+icomma(1,2)-1)
      lockstat(1:icomma(2,2))=
     * cline(icomma(2,1):icomma(2,1)+icomma(2,2)-1)
      if ( ncomma .gt. 2 ) then
       wholockrec(1:icomma(3,2))=
     *  cline(icomma(3,1):icomma(3,1)+icomma(3,2)-1)
       timerec(1:icomma(4,2))=
     *  cline(icomma(4,1):icomma(4,1)+icomma(4,2)-1)
       if ( ncomma .gt. 4 ) then
        whatrec(1:icomma(5,2))=
     *   cline(icomma(5,1):icomma(5,1)+icomma(5,2)-1)
       endif
      endif

      return
      end
      SUBROUTINE READPROBEINFO(n,cparm,cchoice,ctype,nprm,nopas,
     *  npatot,nprec,numpar,isetadd)
      
C     READPROBEINFO READS PROBE INFORMATION FROM A LINE OF TEXT
      
      parameter (maxlevel=6000, maxparm=100, maxprobe=100)
      parameter (maxcalc=200)
      
      character*1 cchoice(maxlevel)
      character*11 ctype(maxprobe)
      character*80 cparm

      dimension nopas(maxprobe), nprm(maxprobe,maxparm)
      dimension  nprec(maxcalc,maxprobe), npatot(maxparm)



      ispace = 0
      imiddle = 0


      cchoice(n)=cparm(1:1)
      
      ctype(n)=cparm(2:12)
      read(cparm(20:21),'(i2)') nopas(n)
      
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c      The parameters which a probe measures are listed by
c      code number, separated either by a ',', a space, or
c      a '-'.  A comma or a space just seperate two code numbers,
c      A hyphen means the probe measures each parameter whose
c      code number falls between the two values, including the
c      values themselves.
c
c      Since a code may be 1-3 digits, these digits must all
c      be read together to form a code.  So, the code is only read
c      when a comma, a space, or a hyphen is encountered.  The
c      number of digits read is dependent on the distance between
c      hyphen, comma, and/or spaces.
c
c      Reading the codes continues until the number of parameters
c      measured by a probe (nopas) is reached.
c
c      Reset number of parameters (m) to zero
c
c      nspace is set to 24 because this is the space of the first
c      digit of parameter code in cparm.  nspace will be increased
c      as cparm is read.
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      m=0
      nspace=24
      
 56   if ( cparm(nspace+1:nspace+1).eq.',' .or.
     *  cparm(nspace+1:nspace+1).eq.' ') then
       
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c      If a space or a comma is encountered, add one to the
c      parameter counter.  Read the parameter code according
c      to how many digits since the last comma or space (ispace).
c
c      Also increase nspace to the beginning of the next digit.
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

       m=m+1
       
       if ( ispace.eq.0 ) then
        
        read(cparm(nspace:nspace),'(i1)') nprm(n,m)
        
       elseif ( ispace.eq.1 ) then
        
        read(cparm(nspace-1:nspace),'(i2)') nprm(n,m)
        
       elseif ( ispace.eq.2 ) then
        
        read(cparm(nspace-2:nspace),'(i3)') nprm(n,m)
        
       endif
       
       nspace=nspace+2
       
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c      If this digit is to the right of a hyphen (imiddle=2),
c      set nprm (parameter codes by probe) for each number
c      between the last code read in and the latest code
c      read in successively, including these outside code
c      values.
c 
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
       
       if ( imiddle.eq.2 ) then
        
        npholds=nprm(n,m-1)
        npholde=nprm(n,m)
        
        m=m-1
        
        do 60 i=npholds+1,npholde
         
         m=m+1
         nprm(n,m)=i
         
 60     continue
        
       endif
       
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Reinitialize ispace.
c     If the last code read in was to the left of a hyphen,
c     (imiddle=1), set imiddle to 2, since the next entered
c     code will be to the right of the hyphen.
c     Otherwise reinitialize imiddle.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
       
       ispace=0
       if ( imiddle.eq.1 ) then
        imiddle=2
       else
        imiddle=0
       endif
       
      elseif ( cparm(nspace+1:nspace+1).eq.'-' ) then
       
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     If the code to be entered is to the left of a hyphen,
c     record this information by making imiddle=1.  Also
c     change the hyphen to a comma so the code can be entered.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

       imiddle=1
       cparm(nspace+1:nspace+1)=','
       
      else

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Bump ispace and nspace up one since this code must have
c     more digits.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
       
       ispace=ispace+1
       nspace=nspace+1
       
      endif

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     If all codes have not been read, read the next code.
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      if ( m.lt.nopas(n)) goto 56

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c      Add one to counter npatot, which counts how many probes
c      measure each parameter, for each parameter measured.
c
c      Also, invert nprm, that is, for each parameter, record
c      the order in which it was recorded.
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      do 58 i=1,nopas(n)
       
       nprm(n,i) = nprm(n,i) + isetadd
       
       npatot(nprm(n,i))=npatot(nprm(n,i))+1
       
       nprec(nprm(n,i),n)=i
       
 58   continue

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Set nprec and nprm for the second header
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      
      nprec(numpar+1,n)=nopas(n)+1
      nprm(n,nopas(n)+1)=numpar+1
      
      return
      end
      
      SUBROUTINE READWILLISTABLES(ntypemax,nyearmax,xcorr,
     * filein,ntyp,iyearmin,iyearmax)

C     READWILLISTABLES READS WIJFFELS TABLE 2 INFORMATION
C     (WILLIS CORRECTIONS)

      parameter (icmax=5,maxyear=3000)
      character*80 filein,filename,text
      dimension icomma(icmax,2),xcorr(nyearmax,ntypemax,0:12)
      dimension iyearmin(ntypemax),iyearmax(ntypemax) 
      call extraname('sys.inf'//CHAR(0),filein,filename)

      open(10,file=filename,status='old')

      iyearmin(ntyp)=maxyear
      read(10,'(a)') text
      do 50 iy=1,maxyear
       call clearstring(text,80)

       read(10,'(a)',end=4) text
       call findlastchar(nsp,text,80)
       call spacefindl(nsp,icmax,ncomma,icomma,text)

       read(text(icomma(1,1):icomma(1,1)+icomma(1,2)-1),*) inyear
       read(text(icomma(2,1):icomma(2,1)+icomma(2,2)-1),*,
     * end=50,err=50) xcorr0

       if ( iyearmin(ntyp) .eq. maxyear ) iyearmin(ntyp)=inyear
       iyearmax(ntyp)=inyear

       xcorr(inyear,ntyp,0)=xcorr0

50    continue
4     continue

      close(10)

      do 60 iy=iyearmin(ntyp),iyearmax(ntyp)-1
       xdiff=(xcorr(iy+1,ntyp,0)-xcorr(iy,ntyp,0))/12.

       do 65 mon=1,12
        xmon=mon
        xcorr(iy,ntyp,mon)=xcorr(iy,ntyp,0)+((xmon-1)*xdiff)
65     continue

60    continue

      do 75 mon=1,12
       xcorr(iyearmax(ntyp),ntyp,mon)=xcorr(iyearmax(ntyp),ntyp,0)
75    continue

      return
      end 
      SUBROUTINE REDUCEJULIAN(iyear,rjul,iyearadd)

C     REDUCEJULIAN REDUCES A MULTIYEAR JULIAN DATE TO 
C     YEAR AND SINGLE YEAR JULIAN DATE

      parameter (xdays=366.)

      iyearx=iyear
      ineg=0
      if ( rjul .lt. 0. ) then
       ineg=1
       iyearx=iyearx-1
      endif

      do 500 nz=1,300

       xsub=1.
       if ( (iyearx/4)*4 .eq. iyearx) xsub=0.
       if ( (iyearx/100)*100 .eq. iyearx .and.
     *      (iyearx/400)*400 .ne. iyearx ) xsub=1.
       if ( ineg .eq. 0 ) then
        if ( rjul .ge. xdays-xsub ) then
         iyearx=iyearx+1
         rjul=rjul-(xdays-xsub)
        else
         goto 450
        endif
      else
       if ( -rjul .ge. xdays-xsub ) then
        iyearx=iyearx-1
        rjul=rjul+(xdays-xsub)
       else
        goto 450
       endif
       endif

500   continue
450   continue

      iyearadd=iyearx-iyear

      return
      end

      SUBROUTINE RESHUFFLE(x,x2,iddif,jddif,idstart,idend,
     * jdstart,jdend,idim,jdim)

C     RESHUFFLE SHUFFLES A DATA ARRAY TO ALIGN THE DATA WITH
C     THE BEGINNING AND ENDING LONGITUDES.  THIS VERSION IS
C     FOR REAL DATA

c********************************************************
c
c     Passed Arrays
c      x - original data array
c      x2 - shuffled data array
c      iddif - number of horizontal spacings
c      jddif - number of vertical spacings
c      idstart - starting horizontal value
c      idend - ending horizontal value
c      jdstart - starting vertical value
c      jdend - ending vertical value
c      idim - total horizontal spacings
c      jdim - total vertical spacings
c
c*********************************************************

      dimension x(idim,jdim), x2(iddif,jddif)

c*********************************************************
c
c    i2 is the shuffled horizontal position
c    j2 is the shuffled vertical position
c
c    Reset j2 to start and reset i2 every time through
c    the vertical loop
c
c*********************************************************

      j2=0

      do 25 j=jdstart,jdend

       i2=0
       j2=j2+1

c*********************************************************
c
c    If the starting horizontal idices is less than the
c    ending value, simply substitute in values in output
c    array.
c
c*********************************************************

       if ( idstart .lt. idend ) then

        do 34 i=idstart,idend

         i2= i2+1
         x2(i2,j2) = x(i,j)

34      continue

       else

c**********************************************************
c
c   If idstart is greater than idend, the values must rap around.
c   Run through all values from idstart to idim, placing
c   the values in their shuffled position in the temporary
c   array
c
c**********************************************************

        do 26 i=idstart,idim

         i2=i2+1
         x2(i2,j2) = x(i,j)

26      continue

c***********************************************************
c
c   Run through all values from 1 to idend
c
c***********************************************************

        do 27 i=1,idend

         i2=i2+1
         x2(i2,j2) = x(i,j)

27      continue

       endif

25    continue

      return
      end

      SUBROUTINE ROUNDOFF(ipower,value)

C     ROUNDOFF ROUNDS OFF A GIVEN VALUE TO A GIVEN POWER OF TEN

      i=abs(ipower)

      x=1.
      y=.1
      do 50 ii=1,i
       x=x*10.
       y=y/10.
50    continue

      if ( ipower .lt. 0 ) then       

       val2=value*x
       val3=val2*10.

       ival2=val2
       val2=ival2

       res=mod(val3,10.)
       if ( res .ge. 5. ) val2=val2+1.

       value2=val2/x

       if ( value-value2 .ge. y ) then
        value2=value2+y
       elseif ( value-value2 .le. -y ) then
        value2=value2-y
       endif

       value=value2

      else

       value = value - mod(value,x)

      endif

      return
      end

      SUBROUTINE SETDENSESURFS(nsurfs,densesurf,npots,jpotlev,
     * maxpot,maxsurf)

C     SETDENSESURFS SETS DESIRED DENSITY SURFACES AND
C     REFERENCE LEVELS TO BE INVESTIGATED

      dimension jpotlev(maxpot),densesurf(maxsurf)

c     -1=insitu density
c     npots=1
c     jpotlev(1)=-1

c     reference levels surface to 3000 meters
c     by 500 meter intervals
c     do 50 n=0,3000,500
c      npots=npots+1
c      jpotlev(npots)=n
c50    continue
      npots=1
      jpotlev(npots)=0

c     density surfaces from 21.00 to 55.00 by 0.05
      nsurfs=0
c     do 55 n=2100,5500,5
      do 55 n=2750,2770
       nsurfs=nsurfs+1
       xn=n
       densesurf(nsurfs)=xn/100.
55    continue

      return
      end
      SUBROUTINE SETGLOBAL(iptotal,ireqex,nprotot)
 
C     SETGLOBAL IS A ROUTINE TO SET ALL CHARACTER VARIABLES
C     GLOBALLY IN C.  THIS ELIMINATES THE NEED (IN MOST CASES)
C     TO CARRY THESE VARIABLES INTO THE MAIN BODY OF THE
C     FORTRAN PROGRAM.
 
c------------------------------------------------------------
c
c     Subroutine Steps:
c
c      1. Set 'other' character variables (C subroutine cname)
c      2. Add C character array end notation '\0', to the
c         end of all character variables and then set these
c         three variables (parameter name (citf), parameter
c         abbreviation (citf2), and parameter code (mtype)
c         (C subroutines findchar and cname)
c      3. Do the same for probe identifier (ctype)
c         (C subroutines findchar and cname2)
c
c------------------------------------------------------------

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c    Passed Variables:
c
c     iptotal - total number of requested parameters 
c               (measured and calculated)
c     nprotot - total number of  probes
c     ireqex - number of non-requested measured parameters
c              which are related to a calculated parameter
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Parameters:
c
c      nprobe - maximum number of probes in the OCL system.
c      maxlevel - maximum number of depth levels
c      maxparm - maximum number of measured parameters
c      maxcalc - maximum number of calculated parameters
c      noffset - offset between bio and sec headers and
c                their set data
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      parameter (nprobe=100, maxlevel=6000, maxparm=100)
      parameter (maxcalc=200, maxkdim=137,noffset=200)

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Character Variables:
c
c      citf - 1-15 letter name of parameter, is used as the 
c             actual file name where parameter data is stored
c      ctype - 1-11 letter probe name, is used as the directory
c              under which data is stored
c      mtype - 1 to 3 letter code for parameter.  Used for
c              auxilary file naming, such as analyzed data.
c      citf2 - 1-6 letter parameter abbreviation.  Used for
c              identifying output in ASCII profiles.
c
c      xcitf,xctype,xmtype,xcitf2 - same as similiarly named
c      variables above, but with two extra spaces for the C
c      end of character array marker '\0'.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      character citf*15,ctype*11,citf2*6,mtype*3
      character xcitf(maxlevel)*17,xctype(nprobe)*13
      character xcitf2(maxlevel)*8,xmtype(maxlevel)*5
 
c***********************************************************
c
c    Array:
c
c     ip2 - parameter codes of requested parameters
c
c***********************************************************

      dimension ip2(0:maxlevel)
 
      common /parnames/ citf(maxlevel)
      common /parname1/ mtype(maxlevel)
      common /parname4/ citf2(maxlevel)
      common /probes/ ctype(nprobe)

      common /reqps/ ip2
      common /extra/ ireqpars2,ireqsec,ireqbio
      common /reflevs/ nlevs,dz2(maxkdim)
      common /calctype/ ipx(maxcalc)

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     eachparm contains numeach, which holds the number of
c     parameters in each type of category:
c      1. measured parameters
c      2. calculated parameters
c      3. second header parameters
c      4. biological parameters
c      5. taxonomic parameters
c      6. second header variable specific parameters
c
c      numtotx - starting number (minus one) for second header
c                parameters
c      numtotz - starting number (minus one) for biological 
c                parameters
c      ntax - number of taxa in individual profiles
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      common /eachparm/ numeach(6),numtotx,numtotz,ntax,numsecset
 
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Call cname to name 'other' parameter.  Other parameter
c     pertains to masks that deal with either all parameters
c     or special subsets (such as density masks for salinity
c     and temperature) or depth.
c
c     Cname sets 3 global variables, a 15 letter code, a three
c     letter code, and a four letter code (maximums).  The
c     last passed variable is the parameter number code which
c     corresponds to the passed character variables.  
c
c     Usually, the fifteen letter name is citf, the one letter
c     name is mtype and the four letter name is citf2. Mtype is
c     always a one letter code except for some calculated 
c     parameters.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      call cname('other'//CHAR(0),'o'//CHAR(0),'oth'//CHAR(0),0)
      call cname('header2'//CHAR(0),'h2'//CHAR(0),'h2'//CHAR(0),
     *      numeach(1))

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c    Start requested parameters loop. 
c
c    Set i to the correct parameter code (ip2)
c
c    Set xcitf equal to citf.
c
c    Call findend to find the last letter in citf (actually the
c    first space).
c     nx - the number corresponding to the placement of the 
c     first space in xcitf
c     xcitf - the character variable being examined
c     - the next number is the maximum number of letters in citf
c     - the last variable is the character, in this case a space
c     which the subroutine is looking for the first occurrance of.
c     add the C end of character array notation ('\0') to the end
c     of xcitf.
c
c    Repeat for citf2 and mtype
c
c    Assign global C parameter variables in cname as described above.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

c     do 90 i0=1,iptotal-ireqpars2-ireqex
      do 90 i0=1,numeach(1)-1

c      i=ip2(i0)
       i=i0

       xcitf(i)=citf(i)
       call findchar(nx,citf(i),15,' ')

       if ( nx .lt. 2 .or. nx .gt. 15 ) write(6,*) 'cname error 1'
       xcitf(i)(nx:nx)=CHAR(0)

       xcitf2(i)=citf2(i)
       call findchar(nx,citf2(i),6,' ')
       xcitf2(i)(nx:nx)=CHAR(0)
       if ( nx .lt. 2 .or. nx .gt. 6 ) write(6,*) 'cname error 2'

       xmtype(i)=mtype(i)
       call findchar(nx,mtype(i),3,' ')
       xmtype(i)(nx:nx)=CHAR(0)
       if ( nx .lt. 2 .or. nx .gt. 3 ) write(6,*) 'cname error 3'
       
       call cname(xcitf(i),xmtype(i),xcitf2(i),i)
 
90    continue

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c    Assign global variables for calculated parameters
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      do 81 i0=iptotal-(ireqpars2+ireqex)+1,iptotal

       i=ip2(i0)
       i2=i
c      i2=numeach(1)+i0-(iptotal-ireqpars2-ireqex)
c      ip2(i0)=i2
       i3=0
c      ipx(i2-numeach(1))=i-numeach(1)
       ipxx=ipx(i2-numeach(1))

       if ( ipxx .le. nlevs ) then
c       ix=numeach(1)+1
        i3=i - numeach(1)
       elseif ( ipxx .le. 2*nlevs+1 ) then
c       ix=numeach(1)+2
        i3=i - (numeach(1)+nlevs)
       else
c       ix=numeach(1)+ (i - 2*nlevs)
       endif

       xcitf(i2)=citf(i)
       call findchar(n1,citf(i2),15,' ')
       xcitf2(i2)=citf2(i2)
       call findchar(n2,citf2(i2),6,' ')
       xmtype(i2)=mtype(i2)
       call findchar(n3,mtype(i2),3,' ')

       if ( i3 .gt. 0 .and. i3.lt.10 ) then
        write(xcitf(i2)(n1:n1),'(i1)') i3
        write(xcitf2(i2)(n2:n2),'(i1)') i3
        write(xmtype(i2)(n3:n3),'(i1)') i3
        n1=n1+1
        n2=n2+1
        n3=n3+1
       elseif ( i3 .ge. 10 ) then
        write(xcitf(i2)(n1:n1+1),'(i2)') i3
        write(xcitf2(i2)(n2:n2+1),'(i2)') i3
        write(xmtype(i2)(n3:n3+1),'(i2)') i3
        n1=n1+2
        n2=n2+2
        n3=n3+2
       endif

       xcitf(i2)(n1:n1)=CHAR(0)
       xcitf2(i2)(n2:n2)=CHAR(0)
       xmtype(i2)(n3:n3)=CHAR(0)
       if ( n1 .lt. 2 .or. n1 .gt. 15 ) write(6,*) 'cname error 4'
       if ( n2 .lt. 2 .or. n2 .gt. 6 ) write(6,*) 'cname error 5'
       if ( n3 .lt. 2 .or. n3 .gt. 3 ) write(6,*) 'cname error 6'
       if ( i2 .lt. 1 .or. i2 .gt. maxlevel )
     *  write(6,*) 'cname error 7'
       
       call cname(xcitf(i2),xmtype(i2),xcitf2(i2),i2)
 
81    continue

c**********************************************************
c
c   Do the same for non-requested measured parameters
c   necessary for calculated parameters
c
c**********************************************************

      do 93 i0=iptotal-ireqex+1,iptotal

       i=ip2(i0)

       xcitf(i)=citf(i)
       call findchar(nx,citf(i),15,' ')
       xcitf(i)(nx:nx+1)=CHAR(0)

       xcitf2(i)=citf2(i)
       call findchar(nx,citf2(i),6,' ')
       xcitf2(i)(nx:nx+1)=CHAR(0)

       xmtype(i)=mtype(i)
       call findchar(nx,mtype(i),3,' ')
       xmtype(i)(nx:nx+1)=CHAR(0)
       
       call cname(xcitf(i),xmtype(i),xcitf2(i),i)
 
93    continue

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Do the same procedure for second header data and
c     biological data.
c 
c     numtot2 is the first possible second header parameter-1
c     numtot3 is the last possible second header parameter
c     numtot4 is the first possible biological parameter-1
c     numtot5 is the last possible biological parameter
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      numtot2=maxparm+maxcalc+1
      numtot3=numtot2+numeach(3)
      numtot4=(2*maxparm)+maxcalc+noffset+1
      numtot5=numtot4+numeach(4)
      numtot6=(2*maxparm)+maxcalc+(2*noffset)+1
      numtot7=numtot6+numeach(5)
      numtot8=maxparm+maxcalc+noffset+1
      numtot9=numtot8+numeach(6)

      do 91 nn=1,4

       if ( nn.eq.2) then
        i1=numtot2
        i2=numtot3
       elseif ( nn.eq.1) then
        i1=numtot4
        i2=numtot5
       elseif ( nn .eq. 4 ) then
        i1=numtot8
        i2=numtot9
       else
        i1=numtot6
        i2=numtot7
       endif

       do 92 i=i1,i2

        xcitf(i)=citf(i)
        call findchar(nx,citf(i),15,' ')
        xcitf(i)(nx:nx+1)=CHAR(0)

        xcitf2(i)=citf2(i)
        call findchar(nx,citf2(i),6,' ')
        xcitf2(i)(nx:nx+1)=CHAR(0)

        xmtype(i)=mtype(i)
        call findchar(nx,mtype(i),3,' ')
        xmtype(i)(nx:nx+1)=CHAR(0)
       
        call cname(xcitf(i),xmtype(i),xcitf2(i),i)
 
92     continue
91    continue

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     Do the same procedure for probe character array ctype,
c     which is set in cname2.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      do 55 j=1,nprotot

       xctype(j)=ctype(j)
       call findlastchar(nx,ctype(j),11)
       ctype(j)(nx+1:nx+1)=CHAR(0)

       call cname2(ctype(j),j)

55    continue
 
      return
      end
 
      SUBROUTINE SETLAYERS(kmax,xlayer,maxlayer)

C     SETLAYERS SETS LAYER BOUNDS SURROUNDING A STANDARD DEPTH LAYER

      parameter (kdim=137)
      dimension xlayer(maxlayer,2),dz(kdim)
      call setstandepsfromfile(kmax,dz)

      xlayer(1,1)=dz(1)
      xlayer(1,2)=xlayer(1,1)+0.5*(dz(2)-dz(1))
      do 30 k=2,kmax-1

       xlayer(k,1)=dz(k)- (0.5*(dz(k)-dz(k-1)))
       xlayer(k,2)=dz(k)+ (0.5*(dz(k+1)-dz(k)))

30    continue
      xlayer(kmax,1)=dz(kmax)+ (0.5*(dz(kmax)-dz(kmax-1)))
      xlayer(kmax,2)=dz(kmax)

      return
      end

      SUBROUTINE SETLOCKOWNER(wholockrec,iw)

C     SET OWNER FOR LOCK

      character*(*) wholockrec
      character*15 WHOrec

      call clearstring(WHOrec,15)
      call getuser(WHOrec)
      call findlastchar(nsp,WHOrec,15)

      call clearstring(wholockrec,iw)
      wholockrec(1:nsp)=WHOrec(1:nsp)

      return
      end

      SUBROUTINE SETLOCKWHAT(whatrec,iw,actionrec,ic)

C     SETLOCKWHAT SETS WHAT IS BEING DONE TO PROBE IN
C     WHATREC FOR WRITING TO LOCK INFORMATION

      character*(*) whatrec
      character*(*) actionrec

      call clearstring(whatrec,iw)
      call findlastchar(nsp,actionrec,ic)
      whatrec(1:nsp)=actionrec(1:nsp)

      return
      end
      SUBROUTINE SORTFILE(itype,ifile,icounts)

C     SORTFILE ALLOCATES SPACE FOR SORTING PROCEDURE, THEN
C     SORTS A FILE BY RECORD NUMBER, REWRITES THE FILE
C     WITH THE SORTED VALUES AND REWINDS IT TO THE BEGINNING.

c***********************************************************
c
c    Passed Variables:
c
c      itype - structure indicator
c          0 - one real value
c          1 - two integer values
c          2 - one integer one real value
c          3 - one integer value
c          4 - three integer values
c      ifile - file identification number
c      icounts - number of structures to free space for
c***********************************************************

c***********************************************************
c
c    Array:
c     iallset - set to one if a structure has already had
c               space allocated
c
c***********************************************************

      character*8 firsttime
      dimension iallset(4)

      save iallset
      save firsttime
 
      if ( firsttime .ne. 'sortfile' ) then
       call arrayinit(iallset,1,4)
       firsttime='sortfile'
      endif

      if ( icounts.le.0 ) return

c***********************************************************
c
c     Rewind file
c
c     Allocate space for sorting file
c
c     allocator:
c      itype - structure indicator
c
c          0 - one real value
c          1 - two integer values
c          2 - one integer one real value
c          3 - one integer value
c          4 - three integer values
c      icounts - number of structures to free space for
c
c     Sort  file by record number
c
c     jsort:
c      ifile - file identification number
c
c     Free up allocated space
c
c     freeup:
c      itype - structure indicator (see above)
c
c     Rewind  file
c
c************************************************************

      call filerewind(ifile)

      itype0=itype
      if ( itype .eq. 5 ) itype0=1
      if ( iallset(itype0) .eq. 0 ) then
       call allocator(itype0,icounts+1)
       iallset(itype0)= icounts+1
      elseif ( iallset(itype0) .lt. icounts+1 ) then
       call reallocator(itype0,icounts+1)
       iallset(itype0)= icounts+1
      endif

      if ( itype.eq. 3 ) then
       call jsort(ifile)
      elseif ( itype.eq. 1 ) then
       call djsort(ifile)
      elseif ( itype.eq. 4 ) then
       call threejsort(ifile)
      elseif ( itype .eq. 5 ) then
       call newcmask(icounts,ifile+1,ifile)
      endif

c     call freeup(itype)

      call filerewind(ifile)

      return
      end

      SUBROUTINE SPACEFIX(cinput,nsp0,nsps,nspf,nsp)

C     SPACEFIX REVEALS BEGINNING AND ENDING SPACES

      character*(*) cinput

      nsps=1
      icharfound=0
      do 55 n0=1,nsp0
       if ( cinput(n0:n0) .eq. ' ' .and. icharfound .ne. 1 ) then
        nsps=nsps+1
       elseif ( cinput(n0:n0) .ne. ' ' ) then
        icharfound=1
       endif
55    continue

      nspf=nsp0
      icharfound=0

      do 65 n0=nsp0,nsps,-1
       if ( cinput(n0:n0) .eq. ' ' .and. icharfound .ne. 1 ) then
        nspf=nspf-1
       elseif ( cinput(n0:n0) .ne. ' ' ) then
        icharfound=1
       endif
65    continue
      nsp=nspf-nsps+1

      return
      end
      real function cpsw(s,t,p0)
CC JA: 4/8/4 from http://sam.ucsd.edu/sio210/propseawater/ppsw_fortran/ppsw.f
c ****************************
c units:
c       pressure        p0       decibars
c       temperature     t        deg celsius (ipts-68)
c       salinity        s        (ipss-78)
c       specific heat   cpsw     j/(kg deg c)
c********************************************************
c ref: millero et al,1973,jgr,78,4499-4507
c       millero et al, unesco report no. 38 1981 pp. 99-188.
c pressure variation from least squares polynomial
c developed by fofonoff 1980.
c check value: cpsw = 3849.500 j/(kg deg. c) for s = 40 (ipss-78),
c t = 40 deg c, p0= 10000 decibars
c   scale pressure to bars
      p=p0/10.
c**************************
c sqrt salinity for fractional terms
      sr = sqrt(abs(s))
c specific heat cp0 for p=0 (millero et al ,unesco 1981)
      a = (-1.38385e-3*t+0.1072763)*t-7.643575
      b = (5.148e-5*t-4.07718e-3)*t+0.1770383
      c = (((2.093236e-5*t-2.654387e-3)*t+0.1412855)*t
     x    -3.720283)*t+4217.4
      cp0 = (b*sr + a)*s + c
c cp1 pressure and temperature terms for s = 0
      a = (((1.7168e-8*t+2.0357e-6)*t-3.13885e-4)*t+1.45747e-2)*t
     x   -0.49592
      b = (((2.2956e-11*t-4.0027e-9)*t+2.87533e-7)*t-1.08645e-5)*t
     x   +2.4931e-4
      c = ((6.136e-13*t-6.5637e-11)*t+2.6380e-9)*t-5.422e-8
      cp1 = ((c*p+b)*p+a)*p
c cp2 pressure and temperature terms for s > 0
      a = (((-2.9179e-10*t+2.5941e-8)*t+9.802e-7)*t-1.28315e-4)*t
     x   +4.9247e-3
      b = (3.122e-8*t-1.517e-6)*t-1.2331e-4
      a = (a+b*sr)*s
      b = ((1.8448e-11*t-2.3905e-9)*t+1.17054e-7)*t-2.9558e-6
      b = (b+9.971e-8*sr)*s
      c = (3.513e-13*t-1.7682e-11)*t+5.540e-10
      c = (c-1.4300e-12*t*sr)*s
      cp2 = ((c*p+b)*p+a)*p
c specific heat return
      cpsw = cp0 + cp1 + cp2
      return
      end
      SUBROUTINE SUBSURF(iyear,iyears,iyeare,months,monthe,
     *                   idays,idaye,lons,lone,lats,late,
     *                   depth,temp,nlevs,nlevout,nparams,ireqpars,
     *                   ip2,latindex,lonindex,itimeindex,xgrid,
     *                   imple)

C     SUBSURF EXTRACTS ONLY THAT PORTION OF A SURFACE CRUISE
C     (STATION) WHICH A USER REQUESTS

c     imple - set to 1 to implement change in temp array

      parameter (maxlevel=6000, maxcalc=200,bmiss=-1E10)
      parameter (ndays=366,idim0=360,jdim0=180)

      parameter (masknum=100,idimax=1440,jdimax=720)

      dimension depth(maxlevel),temp(maxlevel,maxcalc)
      dimension ip2(0:maxlevel)
      dimension monthend(12)
      data monthend/31,29,31,30,31,30,31,31,30,31,31,31/

      common /geog/ m1(idimax,jdimax), mtot(masknum), mex(idimax,jdimax)
      common /geopnt/ igpnt,xlon,xlat,xdist

      j1=0
      j2=0
      i1=0
      i2=0
      i3=0
      i4=0

      idim=float(idim0)/xgrid
      jdim=float(jdim0)/xgrid

c     Figure julian days to look for

      iy1=iyear
      iy2=iyear
      idatecheck=1

      if ( iyears .eq. 0 .and. iyeare .eq. 0 .and.
     *     months .eq. 0 .and. months .eq. 0 .and.
     *     idays .eq. 0 .and. idaye .eq. 0 ) idatecheck=0

      if ( idatecheck .eq. 1 ) then
       if ( iyears .gt. 0 .and. iyeare .gt. 0 ) then

        iy1=iyears
        iy2=iyeare

       endif

c     set months

       if ( months .gt. 0 .and. monthe .gt. 0  ) then
        im1=months
        im2=monthe
       else
        im1=1
        im2=12
       endif 

c     set days

       if ( idays .gt. 0 .and. idaye .gt. 0 ) then
        id1=idays
        id2=idaye
       else
        id1=1
        id2=monthend(im2)
        if ( im2 .eq. 2 .and. (iy2/4)*4 .ne. iy2 ) id2=id2-1
       endif

c     calculate beginning and ending julian days

       call juliant(iyear,iy1,im1,id1,0.0,0,
     *              xjdays,jsigs)
       call juliant(iyear,iy2,im2,id2,0.0,0,
     *              xjdaye,jsigs)
       xjdaye=xjdaye+1.
      endif

c    Set latitudes, longitudes

      iposcheck=1
      if ( lats .eq. 0 .and. late .eq. 0 .and. lons .eq. 0 .and.
     *     lone .eq. 0 .and. igpnt .eq. 0 ) iposcheck=0

      if ( iposcheck .gt. 0 .and. lons .gt. 0 ) then

       if ( lats .gt. 0 .and. late .gt. 0 ) then
        j1=lats
        j2=late
       else
        j1=1
        j2=jdim
       endif

       if ( lons .gt. 0 .and. lone .gt. 0 ) then
        if ( lons .le. lone ) then
         i1=lons
         i2=lone
         i3=0
         i4=0
        else
         i1=1
         i2=lone
         i3=lons
         i4=idim
        endif

       endif

      endif
         
       
c    Remove levels not within user requested positions/dates

      nend=nlevs
c     nlevs=0
      nlevout=0

      do 50 n=1,nend

       iyes=0

       if ( n .le. maxlevel ) then
        d1=depth(n)
        ic=n
        np=0
       else
        call overmax(maxlevel,nparams,n,0,ic,np)
        d1=temp(ic,np)
       endif

c     check position

       if ( iposcheck .eq. 1 .or. igpnt .eq. 1 ) then
       
        rlat=temp(ic,np+latindex)
        rlon=temp(ic,np+lonindex)
        if ( rlon .gt. bmiss .and. rlat .gt. bmiss ) then

         if ( iposcheck .eq. 1 .and. lons .gt. 0) then
          call grid(rlat,rlon,lat,lon,xgrid)

          if ( lat .ge. j1 .and. lat .le. j2 .and.
     *         (lon .ge. i1 .and. lon .le. i2 .or.
     *          lon .ge. i3 .and. lon .le. i4 ) ) 
     *     iyes=1
         elseif ( igpnt .eq. 1 ) then
          call distance(xlat,rlat,xlon,rlon,xd)
          if ( xd .le. xdist ) iyes=1
         elseif ( lons .lt. 0 ) then
          call grid(rlat,rlon,lat,lon,xgrid)
          if ( m1(lon,lat) .eq. lone ) iyes=1
         endif

        endif
     
       else
        iyes=1
       endif

c      check date

c      if ( iyes .eq. 1 ) write(6,*) 'yes',
c    * idatecheck,temp(ic,np+latindex),
c    * temp(ic,np+lonindex)
       if ( idatecheck .eq. 1 .and. iyes .eq. 1) then

        rjul=temp(ic,np+itimeindex)
        if ( rjul .gt. bmiss ) then

c      if a specific month/day is desired, but not a
c      specific year, reduce the julian day to the 
c      year specified in the header (iyear)

         if ( iyears .eq. 0 .and. iyeare .eq. 0 ) then
          call reducejulian(iyear,rjul,iyearadd)
         endif

        endif

c       write(6,*) 'rjul',rjul,xjdays,xjdaye
        if ( rjul .ge. xjdays .and. rjul .lt. xjdaye ) iyes=2

       else

        iyes=iyes+1

       endif

       if ( iyes .ne. 2 ) then

        if ( n .le. maxlevel ) then
         depth(n)=bmiss
        else
         temp(ic,np)=bmiss
        endif
      
        do 305 ii=1,ireqpars
305      if ( ip2(ii) .ne. 14 )
     *    temp(ic,np+ip2(ii))=bmiss

c    Keep information from within user prescribed positions/dates

       elseif ( imple .eq. 1 ) then

        nlevout=nlevout+1
        
        if ( nlevout .le. maxlevel ) then
         depth(nlevout)=d1
         ic2=nlevout
         np2=0
        else
         call overmax(maxlevel,nparams,nlevout,0,ic2,np2)
         temp(ic2,np2)=d1
        endif
      
        do 300 ii=1,ireqpars
300      if ( ip2(ii) .ne. 14 )
     *    temp(ic2,np2+ip2(ii))=temp(ic,np+ip2(ii))

       else

        nlevout=nlevout+1

       endif

50    continue

      return
      end
      SUBROUTINE TIMEFROMDEPTH(nlevels,t0,maxlevel,ihanawa,depth)

C     BACKS OUT TIME FROM GIVEN XBT DEPTH BASED ON HANAWA DROP RATE

      dimension t0(maxlevel),depth(maxlevel)
      if ( ihanawa .eq. 1 ) then
c      Sippican equation
       t1=444.44423
       t2=2210838.36
       t3=1486.88882
      elseif ( ihanawa .eq. 2 ) then
c      ?
       t1=1388.8888
       t2=12425525.9
       t3=3524.98594
      elseif ( ihanawa .eq. 3 ) then
c      Fast Deep
       t1=549.450523
       t2=3081760.67
       t3=1755.49442
      elseif ( ihanawa .eq. 4 ) then
c      T11 XBT
       t1=3921.56844
       t2=12167784.3
       t3=3488.23513
      elseif ( ihanawa .eq. 5 ) then
c      T10 XBT
       t1=462.962941
       t2=2127411.12
       t3=1458.56475
      elseif ( ihanawa .eq. 6 ) then
c     T5 XBT
       t1=549.450523
       t2=3518716.
       t3=1875.82409
      else
c      Hanawa equation
       t1=462.962941
       t2=2244447.66
       t3=1498.14808
      endif

      do 50 n=1,nlevels
       xn=depth(n)
       t0(n)=t3 - sqrt(t2 - (t1*xn))
c      write(6,*) 'xn',n,xn,t0(n)
50    continue

      return
      end
      SUBROUTINE UCHECK(m,iuniqn)

C     UCHECK CHECKS TO SEE IF A PROBE HAS BEEN SET UP WITH UNIQUE 
C     STATION NUMBERS YET
C     THE THREE POSSIBILITIES ARE IUNIQN > 1 = UNIQUE STATION #S
C                                 IUNIQN =0,1 = NO UNIQUE STATION #S
C                                 IUNIQN < 0 = TEMP UNIQUE STATS

      parameter (iufile=510)

      character*80 filename

      ifst=0
      iend=0
      iuniqn=0

      call maskname('uniq.s'//CHAR(0),0,filename,m)
      call fileopen(filename,'rb+'//CHAR(0),iufile)
      call fileend(iufile)
      call filepos(iufile,0,1,iuniqn)

      if ( iuniqn .gt. 1 ) then
       call filerewind(iufile)
       call readmask(ifst,iufile,iend)
       if ( ifst .lt. 0 ) iuniqn=-iuniqn
      endif

      call onefileclose(iufile)

      return
      end

      SUBROUTINE UNGRID(rlat,rlon,j,i,grid)

C     UNGRID CONVERTS FROM GRID NUMBER TO LAT,LON

      parameter (idim1=360,jdim1=180)

c     get geographic dimensional variables
      idim=idim1/grid
      jdim=jdim1/grid

      gridinv=1./grid
      grid2=grid/2.
      idim2=idim/2
      yjdim2=jdim1/2
      xidim1=idim1

      yj=j
      xi=i
      rlat=((yj/gridinv)-grid2)-(yjdim2)
      rlon=((xi/gridinv)-grid2)
      if ( i .gt. idim2 ) rlon=rlon-xidim1

      return
      end

      SUBROUTINE UNIQFIND(jj,ju,jp,itime)

C     UNIQFIND RETURNS THE UNIQUE STATION NUMBER FOR A GIVEN
C     PROFILE NUMBER (ORDER IN FILE)

c**************************************
c
c    Passed Variables
c
c     jj - order of profile in file
c     ju - unique station ID
c     jp - probe type
c     itime - set to one if file has been opened, zero to open
c             file and -1 to close file
c
c*************************************

      parameter (iufile=508,maxprobe=100)
      character*80 filename

      dimension iopenp(maxprobe),nuniq(maxprobe)

      save nuniq,inumprobes,iopenp

c******************************************
c
c    Open unique station file if this is
c    the first time through subroutine
c
c******************************************

      if ( iopenp(jp) .gt. 0  ) then
c      call filerewind(iopenp(jp))
      else
       inumprobes=inumprobes+1
       iopenp(jp)=iufile-inumprobes
       if (iopenp(jp) .lt. 501 ) iopenp(jp)=-1
       call maskname('uniq.s'//CHAR(0),0,filename,jp)
       call fileopen(filename,'rb+'//CHAR(0),iopenp(jp))
       call fileend(iopenp(jp))
       call filepos(iopenp(jp),0,1,nuniq(jp))
       call filerewind(iopenp(jp))
       itime=1
      endif

c*********************************************c
c
c    Read proper station id
c
c*********************************************

      if ( jj .le. nuniq(jp) ) then
       call posfile(jj,iopenp(jp))
       call readmask(ju,iopenp(jp),iend)
      else
       ju=0
      endif

      if ( itime .eq. -1 ) call onefileclose(iopenp(jp))

      return
      end
      SUBROUTINE UNIQTHERE(iorder,istat,jp)

C     UNIQTHERE CHECKS IF THE UNIQUE STATION NUMBER IS FOUND
C     IN THIS PARTICULAR DATA SET

      common /silent/ isilent

      itx2=1
      call uorderfind(iorder,istat,jp)
      istat2=-10
      if ( iorder .gt. 0 ) then
       call uniqfind(iorder,istat2,jp,itx2)

      if ( istat2 .ne. istat ) then
       if ( isilent .eq. 0 ) write(6,*)
     * 'Unique station number is not found in this data set: ',istat
       iorder=-1
      endif
      endif

      return
      end

      SUBROUTINE UNIQTOORDER(nmask,ifn,ipro2,maxmask,m,npro,jp,
     * mskcode)

C     UNIQTOORDER TAKES ALL MASK FILES AND CONVERTS THE NUMBERS FROM
C     UNIQUE STATION NUMBER TO THE POSITION NUMBER OF THE STATION
C     IN THE FILE AND WRITES THIS NUMBER TO TEMPORARY MASKS

c     nmask - number of each type of mask
c     ifn - file ID number for each mask
c     ipro2 - probe type of each mask (negative=unique stat#s
c             instead of order numbers)
c     maxmask - maximum number of masks
c     m - probe type order 
c     npro - number of probes
c     jp - probe code

      character*17 charu
      dimension ifn(maxmask),ipro2(maxmask),nmask(5)

c     mskcode - Code of what type of mask each present mask is
c                1 - (.s,index,.p) sequential mask
c                2 - (.d, .2) two integer mask
c                3 - (.3) three integer
c                4 - (.4) four integer
c                5 - (.c) one string
c                6 - (.c2) two string
c                7 - (2ri) two reals, one integer
c                8 - (2r2i) two reals, two integers
c                9 - (c2i) one string, two integers

      dimension mskcode(maxmask)

      do 50 mm=m,nmask(5),npro
       if ( ipro2(mm) .lt. 0 ) then

        if ( ipro2(mm) .eq. -1000 ) then
         ipro2(mm)=0
        else
         ipro2(mm)=-ipro2(mm)
        endif

        itemp=-1

        call tempfile(itemp)

        idone=0
        icount=0
        do 55 nn=1,200000000

         if ( mskcode(mm) .eq. 1) then
          call readmask(ju,ifn(mm),idone)
         elseif ( mskcode(mm) .eq. 2 ) then
          call readmask2(ju,ifn(mm),idone,isecond)
         elseif ( mskcode(mm) .eq. 3 ) then
          call readmask3(ju,ifn(mm),idone,isecond,ithird)
         elseif ( mskcode(mm) .eq. 4 ) then
          call readmask4(ju,ifn(mm),idone,isecond,ithird,ifourth)
         elseif ( mskcode(mm) .eq. 5 ) then
          call readcmask(ju,charu,ifn(mm),idone)
         endif

         if ( idone .gt. 0 ) then
          call onefilecloseft(ifn(mm))
          ifn(mm)=itemp
          idone=0
          call filerewind(itemp)
          goto 50
         endif

         call uniqthere(jj,ju,jp)
         if ( jj .gt. -1 ) then
          if ( mskcode(mm) .eq. 1 ) then
           call writetomask(jj,icount,itemp)
          elseif ( mskcode(mm) .eq. 2 ) then
           call writetomask2(jj,icount,itemp,isecond)
          elseif ( mskcode(mm) .eq. 3 ) then
           call writetomask3(jj,icount,itemp,isecond,ithird)
          elseif ( mskcode(mm) .eq. 4 ) then
           call writetomask4(jj,icount,itemp,isecond,ithird,ifourth)
          elseif ( mskcode(mm) .eq. 5 ) then
           call writecmask(jj,charu,itemp)
           icount=icount+1
          endif
         endif

55      continue

       endif
50    continue

      return
      end
      SUBROUTINE UNIQTOORDER1MASK(ifn,jp,mskcode)

C     UNIQTOORDER TAKES ONE MASK FILE AND CONVERTS THE NUMBERS FROM
C     UNIQUE STATION NUMBER TO THE POSITION NUMBER OF THE STATION
C     IN THE FILE AND WRITES THIS NUMBER TO A TEMPORARY MASK

c     ifn - file ID number for mask
c     jp - probe code
c     mskcodes - Code of what type of mask each present mask is
c                1 - (.s,index,.p) sequential mask
c                2 - (.d, .2) two integer mask
c                3 - (.3) three integer
c                4 - (.4) four integer
c                5 - (.c) one string
c                6 - (.c2) two string
c                7 - (2ri) two reals, one integer
c                8 - (2r2i) two reals, two integers
c                9 - (c2i) one string, two integers

      character*17 charu

      itemp=-1
      idone=0
      icount=0

      call tempfile(itemp)

      do 55 nn=1,20000000

       if ( mskcode .eq. 1) then
        call readmask(ju,ifn,idone)
       elseif ( mskcode .eq. 2 ) then
        call readmask2(ju,ifn,idone,isecond)
       elseif ( mskcode .eq. 3 ) then
        call readmask3(ju,ifn,idone,isecond,ithird)
       elseif ( mskcode .eq. 4 ) then
        call readmask4(ju,ifn,idone,isecond,ithird,ifourth)
       elseif ( mskcode .eq. 5 ) then
        call readcmask(ju,charu,ifn,idone)
       endif

       if ( idone .gt. 0 ) then
        call onefilecloseft(ifn)
        ifn=itemp
        idone=0
        call filerewind(itemp)
        goto 4
       endif

       call uniqthere(jj,ju,jp)
       if ( jj .gt. -1 ) then
        if ( mskcode .eq. 1 ) then
         call writetomask(jj,icount,itemp)
        elseif ( mskcode .eq. 2 ) then
         call writetomask2(jj,icount,itemp,isecond)
        elseif ( mskcode .eq. 3 ) then
         call writetomask3(jj,icount,itemp,isecond,ithird)
        elseif ( mskcode .eq. 4 ) then
         call writetomask4(jj,icount,itemp,isecond,ithird,ifourth)
        elseif ( mskcode .eq. 5 ) then
         call writecmask(jj,charu,itemp)
         icount=icount+1
        endif
       endif

55    continue
4     continue

      return
      end
      SUBROUTINE UORDERFIND(jj,ju,jp)

C     UORDERFIND RETURNS THE ORDER OF A STATION GIVEN THE UNIQUE
C     STATION NUMBER

c**************************************
c
c    Passed Variables
c
c     jj - order of profile in file
c     ju - unique station ID
c     jp - probe code number
c     itime - set to one if file has been opened, 0 to open,
c           -1 to close
c
c*************************************

      parameter (iufile=509)
      parameter (maxprobe=100)

      dimension itime(0:maxprobe),nuniq(0:maxprobe)
      dimension iufilen(0:maxprobe)

      character*11 ctype(maxprobe)
      character*80 filename

      common /silent/ isilent
      common /probes/ ctype

      save itime
      save nuniq
      save iufilen

c******************************************
c
c    Check if this is permanent or temporary
c    unique station numbers
c
c******************************************

      jpx=0
      juu=ju
      if ( ju .lt. 0 ) then
       juu=-ju
       jpx=jp
      endif

c******************************************
c
c    Open unique station file if this is
c    the first time through subroutine
c
c******************************************

      if ( itime(jpx) .eq. 1) then
c      call filerewind(iufilen(jpx))
      else
       if ( jpx .eq. 0 ) then
        call extraname('sys.inf'//CHAR(0),'uniqall.s'//CHAR(0),filename)
        iufilen(0)=iufile
       else
        call maskname('uniqallt.s'//CHAR(0),0,filename,jp)
        iufilen(jpx)=250+jp
       endif
       call fileopen(filename,'rb+'//CHAR(0),iufilen(jpx))
       call fileend(iufilen(jpx))
       call filepos(iufilen(jpx),0,1,nuniq(jpx))
       call filerewind(iufilen(jpx))
       itime(jpx)=1
      endif

c*********************************************c
c
c    Read mask until proper station id is found
c
c*********************************************


      if ( juu .le. nuniq(jpx) ) then
       call posfile(juu,iufilen(jpx))
       call readmask(jj,iufilen(jpx),iend)
      endif

      if ( jj .eq. 0 .or. juu .gt. nuniq(jpx) ) then
       if ( isilent .eq. 0 ) 
     * write(6,*) 'Unique station number not found:',ju
       jj=-1
      endif

      return
      end
      SUBROUTINE UPDATEACTIONLOG(jp,maxprobe,npro,actionrec,
     * iaccesstype,ilocknum)

C    UPDATEACTIONLOG UPDATES ACTION LOG FILE
C    IN SYS.INF 

      parameter (maxline=10000)
      character*(*) actionrec
      character*11 callrelease,proberec
      character*15 whorec,logrec
      character*25 actionstring
      character*30 tdate
      character*80 text(maxline),filename,logstring

      dimension jp(0:maxprobe)

      ilockact=iaccesstype
      if ( ilockact .eq. 3 ) ilockact=0

c     Make sure this is a main probe

      if ( ilocknum .eq. 0 .or. ilocknum .ge. npro ) then
       iloop=npro
      else
       iloop=ilocknum
      endif

c     Get present user
      call setlockowner(whorec,15)

c     Get program being run
      if ( actionrec(1:1) .ne. ' ' ) then
       ispam=1
       logrec=actionrec
      else
       ispam=0
       logrec='- unknown -    '
      endif

c     Get date
      call clearstring(tdate,30)
      call fdate(tdate)

c     Set call/release
      call clearstring(callrelease,11)
      if ( iaccesstype .gt. -1 .and. ispam .eq. 1) then
       callrelease='  (call)   '
      elseif ( ispam .eq. 1 ) then
       callrelease='  (release)'
      endif

c    Create log string
      call clearstring(logstring,80)
      logstring=tdate(1:19)//' '//whorec//' '//logrec//
     * ' '//callrelease

      do 40 n=1,iloop

       call clearstring(proberec,11)
       call getprobename(jp(n),proberec)

       icheck=ismainprobe(proberec)
       if ( icheck .eq. 0 ) goto 40
        
c    Open appropriate action log
       call findlastchar(nsp,proberec,11)
       call clearstring(actionstring,25)
       actionstring='actionlog.'//proberec(1:nsp)//CHAR(0)
       call clearstring(filename,80)
       call extraname('sys.inf'//CHAR(0),actionstring,filename)
       open(9,file=filename,status='unknown')

c    Read in all actions presently in actionlog

       nlines=0
       do 50 nn=1,maxline

        call clearstring(text(nn),80)
        read(9,'(a80)',END=4) text(nn) 
        nlines=nlines+1
   
50     continue
4      continue

c    Write actions out to file, with present action listed first

       close(9)
       open(9,file=filename,status='unknown')

       write(9,'(a80)') logstring
       do 60 nn=1,nlines

        write(9,'(a80)') text(nn)

60     continue

       close(9)

40    continue

      return
      end
      SUBROUTINE UPDATELOCKTIME(timerec,it)

C     SET NEW LOCK TIME IN TIME CHARACTER ARRAY

      character*(*) timerec
      character*30 whodate

      call clearstring(timerec,it)
      call fdate(whodate)

      timerec(1:8)=whodate(12:19)

      return
      end

      SUBROUTINE UPGRADELOCKPROMPT(iwant,istatus)

C    UPGRADELOCKPROMPT PROMPTS USER TO UPGRADE LOCK STATUS

      character*1 yesno
      character*9 clock

      if ( iwant .eq. 2 ) then
       clock='EXCL-LOCK'
      else
       clock='READ-ONLY'
      endif
      write(6,*) 'Running this program requires lock status: ',
     * clock
      write(6,*) 'Should I secure this status? (y/n)'
      read(5,'(a1)') yesno

      if ( yesno .eq. 'Y' .or. yesno .eq. 'Y' ) then
       istatus=iwant
      endif

      return
      end
      SUBROUTINE WRITELOCKFILE(icounter,maxprobe,
     * probelockrec,ip,lockstat,il,wholockrec,iw,
     * timerec,it,whatrec,iw2,ilockfile)

C     WRITELOCKFILE WRITES OUT MERGELOCK FILE

      character*80 usrrec,filename,chead1,chead2
      character*100 usrrecout
      character*(*) probelockrec(maxprobe)
      character*(*) lockstat(maxprobe)
      character*(*) wholockrec(maxprobe)
      character*(*) timerec(maxprobe)
      character*(*) whatrec(maxprobe)

      if ( ilockfile .ne. 6 ) then
       call extraname('sys.inf'//CHAR(0),'mergeLOCK.log'//CHAR(0),
     * filename)
       open(ilockfile,file=filename,status='unknown')
      endif

c     write header lines

      call clearstring(chead1,80)
      chead1='     PROBE            STATUS     USER             TIME'
      call writecharline(chead1,80,ilockfile)

      call clearstring(chead2,80) 
      chead2='-------'//
     * '-------------------------------------------------------'
      call writecharline(chead2,80,ilockfile)

c     write out probes 

      do 50 nn=1,icounter

       call makemergeline(usrrec,probelockrec(nn),ip,
     *  lockstat(nn),il,wholockrec(nn),iw,timerec(nn),it,
     *  whatrec(nn),iw2)
        
       call clearstring(usrrecout,100)
       if ( ilockfile .eq. 6 ) then
        usrrecout='##> '//usrrec
        call insertnumsp('#',nn,usrrecout,5)
       else
        usrrecout=usrrec
       endif
       call writecharline(usrrecout,80,ilockfile)
   
50    continue

      if ( ilockfile .ne. 6 ) close(ilockfile)

      return
      end 

      SUBROUTINE WRITECHARLINE(string,maxlength,ifile)

      character*5 cform1
      character*(*) string
      call findlastchar(nsp,string,maxlength)
      cform1='(aXX)'
      call insertnum('X',nsp,cform1,5)
      write(ifile,cform1) string

      return
      end
      SUBROUTINE XBTSHALLOWDEEP(ishallow,ixbttype,xdepth,xshallow,
     * iplat)

C    XBTSHALLOWDEEP CHECKS IF AN XBT IS SHALLOW (T4/T6 OR
C    UNKNOWN =< 550. M DEPTH), DEEP (T7, DEEP BLUE OR
C    > 550. M DEPTH UNKNOW TYPE ) OR NON OR DIFFERENTLY
C    CORRECTED TYPES (T5, AIR-DROP, SUBMARINE LAUNCH)

c    T4 , T6, T10, T11, Sparton XBT1,3,4,6,10

      ishallow=-1

      if ( ixbttype .eq. 2 ) then

       if ( xdepth .le. xshallow ) then
        ishallow=1
       else
        ishallow=0
       endif
       if ( iplat .eq. 183 ) ishallow=-1

      elseif ( ixbttype .eq. 208 .or. ixbttype .eq. 202
     *    .or. ixbttype .eq. 203 .or. ixbttype .eq. 205
     *    .or. ixbttype .eq. 209 .or. ixbttype .eq. 211  
     *    .or. ixbttype .eq. 211 .or. ixbttype .eq. 212  
     *    .or. ixbttype .eq. 215 .or. ixbttype .eq. 216  
     *    .or. ixbttype .eq. 216 .or. ixbttype .eq. 221  
     *    .or. ixbttype .eq. 222 .or. ixbttype .eq. 223  
     *    .or. ixbttype .eq. 226 .or. ixbttype .eq. 229  
     *    .or. ixbttype .eq. 220 .or. ixbttype .eq. 206  
     * ) then

       ishallow=1

c    T5

      elseif ( ixbttype .eq. 204 .or. ixbttype .eq. 210
     *    .or. ixbttype .eq. 210 .or. ixbttype .eq. 224
     *    .or. ixbttype .eq. 225 .or. ixbttype .eq. 219)
     *  then
      ishallow=-1

c   Air drop

      elseif ( ixbttype .eq. 233 .or. ixbttype .eq. 234
     *   .or.  ixbttype .eq. 238 .or. ixbttype .eq. 239
     *   .or. iplat .eq. 183) then
       ishallow= -1

c   Submarine

      elseif ( ixbttype .eq. 237 ) then
       ishallow=-1 

c   Strange types : MHI, Sparton 20, 20DB

      elseif ( ixbttype .eq. 218 .or. ixbttype .eq. 230
     *    .or. ixbttype .eq. 231 ) then
       ishallow=-1

c  Deep types: T7, Deep Blue, Fast Deep

      elseif ( ixbttype .eq. 201 .or. ixbttype .eq. 207
     *    .or. ixbttype .eq. 213 .or. ixbttype .eq. 214
     *    .or. ixbttype .eq. 217 .or. ixbttype .eq. 227
     *    .or. ixbttype .eq. 228 .or. ixbttype .eq. 232
     *    .or. ixbttype .eq. 235 .or. ixbttype .eq. 236
     * ) then

      ishallow= 0

      elseif ( ixbttype .gt. 2 ) then

       write(6,*) 'Type unaccounted for: ',ixbttype

      endif

      return
      end
      SUBROUTINE xbtwestpacocean(iwestpacific,rlat,rlon)
   
c       write(6,*) rlat,rlon 
       if (rlon .ge. 120 .and. rlon .le. 180  .and. 
     *   rlat .ge. -20) then
       iwestpacific=1
       else
       iwestpacific=0
       endif
       return
       end
 
