          program gridELC
c
c   December 24, 1999
c
c   This is an optimizer code based on the 'grid search' technique
c   discussed in Bevington (1969).  This program will call the
c   subroutines contained within 'lcsubs.for' and 'optimizesubs.for'.
c
c   UPDATE January 15, 2002
c
c   Update the code so that alb1 and alb2 can be adjusted (albedos of
c   star 1 and star 2).  Update subroutines assignvar, varassign,
c   newwritevar, and writevar
c
          implicit double precision (a-h,o-z)
c
          parameter(Nmaxphase=750000,Ndatamax=200000)
          parameter(Nvmax=60)
          parameter(Nmaxeclipse=1000)
c
c   UPDATE September 11, 2001
c
c   Change the dimension of obsparm,obv,eobv,sobv to 9.
c
c
c   UPDATE September 21, 2008
c
c   Change the dimension of obsparm, obv, sobv, and eobv  to 11
c
c
c   UPDATE October 10, 2008
c
c   change the dimensions of obsparm, obv, sobv, and eobv to 17
c
c
c   UPDATE March 15, 2011
c
c   Make the dimensions of obsparm, obs, sobv, eobv 18
c
          dimension obsparm(19),obv(19),eobv(19)
          character*40 sobv(19)
          dimension xmod(Nmaxphase),ymodU(Nmaxphase),ymodB(Nmaxphase),
     $      ymodV(Nmaxphase),ymodR(Nmaxphase),ymodI(Nmaxphase),
     $      ymodJ(Nmaxphase),ymodH(Nmaxphase),ymodK(Nmaxphase),
     &      ymods1(Nmaxphase),ymods2(Nmaxphase),ymodd(Nmaxphase),
     &      RV1(Nmaxphase),RV2(Nmaxphase),ymods3(Nmaxphase),
     @      RV3(Nmaxphase)
          dimension xdataU(Ndatamax),ydataU(Ndatamax),errU(Ndatamax),
     &      ydataB(Ndatamax),errB(Ndatamax),ydataV(Ndatamax),
     @      errV(Ndatamax),ydataR(Ndatamax),errR(Ndatamax),
     @      ydataI(Ndatamax),errI(Ndatamax),ydataJ(Ndatamax),
     @      errJ(Ndatamax),ydataH(Ndatamax),errH(Ndatamax),
     $      ydataK(Ndatamax),errK(Ndatamax),yRV1(Ndatamax),
     @      errRV1(Ndatamax),yRV2(Ndatamax),errRV2(Ndatamax),
     @      xdataB(Ndatamax),xdataV(Ndatamax),xdataR(Ndatamax),
     @      xdataI(Ndatamax),xdataJ(Ndatamax),xdataH(Ndatamax),
     @      xdataK(Ndatamax),xRV1(Ndatamax),xRV2(Ndatamax),
     @      xRV3(Ndatamax),yRV3(Ndatamax),
     @      errRV3(Ndatamax)
          dimension wave(8),dbolx(8,2),dboly(8,2),dwavex(8,3),
     @         dwavey(8,3)
          dimension var(Nvmax),vstart(Nvmax),vstep(Nvmax),Nstep(Nvmax),
     %      sigvar(Nvmax),stepsave(Nvmax),
     $      drv1(Nmaxphase),drv2(Nmaxphase)
          dimension xRVmod(Nmaxphase)
          dimension resU(Ndatamax),resB(Ndatamax),resV(Ndatamax)
          dimension resR(Ndatamax),resI(Ndatamax),resJ(Ndatamax)
          dimension resH(Ndatamax),resK(Ndatamax),resRV1(Ndatamax)
          dimension resRV2(Ndatamax),resRV3(Ndatamax)
c
          character*40 Udatafile,svar(Nvmax),Hdatafile,Kdatafile,RV1file,
     @                 RV2file
          character*40 Bdatafile,Vdatafile,Rdatafile,Idatafile,Jdatafile
c
          character*1000 parmstring
          character*2000 planetparm
          character*1700 dynparm,line
c
c   Dimension the variables needed for the model atmospheres here.
c
          parameter (maxlines=1300,maxmu=115)
          dimension atmT(maxlines),atmg(maxlines),atmmu(maxlines,maxmu),
     %       Nmu(maxlines)
          dimension atmint1(maxlines,maxmu),atmint2(maxlines,maxmu)
          dimension atmint3(maxlines,maxmu),atmint4(maxlines,maxmu)
          dimension atmint5(maxlines,maxmu),atmint6(maxlines,maxmu)
          dimension atmint7(maxlines,maxmu),atmint8(maxlines,maxmu)
c
c   Define variables for the spots
c
          dimension spotdparm(2,4),spot1parm(2,4),spot2parm(2,4)
c
c   New variables are needed to allow for the fitting of period and T0.
c
          dimension savxdataU(Ndatamax),savydataU(Ndatamax),
     @      saverrU(Ndatamax),savydataB(Ndatamax),saverrB(Ndatamax),
     @      savydataV(Ndatamax),saverrV(Ndatamax),savydataR(Ndatamax),
     @      saverrR(Ndatamax),savydataI(Ndatamax),saverrI(Ndatamax),
     &      savydataJ(Ndatamax),saverrJ(Ndatamax),savydataH(Ndatamax),
     &      saverrH(Ndatamax),savydataK(Ndatamax),saverrK(Ndatamax),
     @      savyRV1(Ndatamax),saverrRV1(Ndatamax),savyRV2(Ndatamax),
     @      saverrRV2(Ndatamax),savxdataB(Ndatamax),savxdataV(Ndatamax),
     &      savxdataR(Ndatamax),savxdataI(Ndatamax),savxdataJ(Ndatamax),
     &      savxdataH(Ndatamax),savxdataK(Ndatamax),savxRV1(Ndatamax),
     @      savxRV2(Ndatamax)
c
c   UPDATE OCTOBER 10, 2007
c
c   Add this array to keep track of the light curves of the individual
c   components in all band passes.
c
          dimension compfracs(8,3),ochidisk(8)
c
          dimension fracs1(Nmaxphase,4),fracs2(Nmaxphase,4)
          dimension fracs3(Nmaxphase,4),fracs4(Nmaxphase,4)
          dimension fracs5(Nmaxphase,4),fracs6(Nmaxphase,4)
          dimension fracs7(Nmaxphase,4),fracs8(Nmaxphase,4)
c
c   This array is needed for the sub-random Sobel sequence, used in
c   place of ran9
c
          dimension xsob(2)
c
c   UPDATE May 8, 2006
c
c   Add this array for power-law limb darkening coefficients.
c   8=filter index, 9=coefficient c1,c2,c3 ...
c
          dimension powercoeff(8,9)
c
          dimension gaplow(9999),gaphigh(9999)
c
          dimension sss(Nvmax)
c
          dimension Ncycle(34),Ttimes(34,Nmaxeclipse)
          dimension Tseps(34,Nmaxeclipse),Tdur1(34,Nmaxeclipse)
          dimension Nobscycle(34),obsTtimes(34,Nmaxeclipse)
          dimension obsTerr(34,Nmaxeclipse),Tdur2(34,Nmaxeclipse)
          dimension icnarray(34)
          dimension xSC(9999),ySC(9999)

c          common /stringblock/ parmstring,planetparm,dynparm,line
cc
c          common /realblock/ fill1,fill2,omega1,omega2,dphase,Q,finc,
c     @      Teff1,Teff2,Tgrav1,Tgrav2,betarim,rinner,router,tdisk,xi,
c     @      alb1,alb2,rLx,Period,fm,separ,gamma,wave,dbolx,dboly,dwavex,
c     @      dwavey,t3,g3,SA3,density,sw1,sw2,sw3,T0,ecc,argper,pshift,
c     @      sw5,sw6,sw7,sw8,sw9,primmass,primK,primrad,ratrad,frac1,
c     @      frac2,ecosw,temprat,bigI,bigbeta,sw23,sw24,powercoeff,sw25,
c     @      sw26,sw27,sw28,sw29,sw30,contam,Tconj,beam1,beam2,ocose,
c     @      osine,omegadot,contamS0,contamS1,contamS2,contamS3,sw47,
c     @      sw48,sw49,gaplow,gaphigh,
c     @         P2tconj,P2period,P2T0,P2ecos,P2esin,P2incl,P2Omega,P2Q,
c     @         P2ratrad,
c     @         P3tconj,P3period,P3T0,P3ecos,P3esin,P3incl,P3Omega,P3Q,
c     @         P3ratrad,
c     @         P4tconj,P4period,P4T0,P4ecos,P4esin,P4incl,P4Omega,P4Q,
c     @         P4ratrad,
c     @         P5tconj,P5period,P5T0,P5ecos,P5esin,P5incl,P5Omega,P5Q,
c     @         P5ratrad,
c     @         P6tconj,P6period,P6T0,P6ecos,P6esin,P6incl,P6Omega,P6Q,
c     @         P6ratrad,
c     @         P7tconj,P7period,P7T0,P7ecos,P7esin,P7incl,P7Omega,P7Q,
c     @         P7ratrad,
c     @         P8tconj,P8period,P8T0,P8ecos,P8esin,P8incl,P8Omega,P8Q,
c     @         P8ratrad,xSC,ySC
cc
c          common /spotblock/ spot1parm,spot2parm,spotdparm
cc
c          common /intblock/ Nalph1,Nbet1,Nalph2,Nbet2,Ntheta,Nradius,
c     @      Nref,idraw,iecheck,iidint,iatm,ism1,ilaw,icnU,icnB,icnV,
c     @      icnR,icnI,icnJ,icnH,icnK,icnRV1,icnRV2,iRVfilt,isw1,isw2,
c     @      isw3,isw4,ikeep,isynch,isw5,isw6,isw7,isw8,isw9,idark1,
c     @      idark2,isw12,isw13,isw21,isw22,isw23,isw24,isw25,isw26,
c     @      isw27,isw28,isw29,isw30,isw31,isw32,isw33,isw34,NSC
cc
c          common /fracblock/ compfracs
cc
c          common /thirdblock/ tertperiod,tertt0,tertecos,tertesin,
c     @        tertincl,tertOmega,tertQ,tertconj,tertratrad,hh,sw72,sw73
cc
          common /realatm/ atmT,atmg,atmmu,atmint1,atmint2,atmint3,
     @      atmint4,atmint5,atmint6,atmint7,atmint8,Tmax,Tmin,gmax,gmin

          common /intatm/  Nlines,Nmu,Nalph3,Nbet3,itconj,it1,it2,it3,
     @      it4
c
         common /medblock/ rmed
c
c   Disable median fitting (if selected by sw6 > 0)
c
          rmed=0.0d0
c
          ifastflag=0   !disable fast genetic mode
c
          call getinput(Nalph1,Nbet1,Nalph2,Nbet2,fill1,fill2,omega1,
     $       omega2,dphase,Q,finc,Teff1,Teff2,Tgrav1,Tgrav2,betarim,
     $       rinner,router,tdisk,xi,Ntheta,Nradius,alb1,alb2,Nref,rLx,
     @       Period,fm,separ,gamma,t3,g3,SA3,density,sw1,sw2,sw3,T0,
     $       idraw,iecheck,iidint,iatm,ism1,icnU,icnB,icnV,icnR,icnI,
     @       icnJ,icnH,icnK,iRVfilt,isw1,isw2,isw3,isw4,ilaw,wave,dbolx,
     @       dboly,dwavex,dwavey,ecc,argper,pshift,sw5,sw6,sw7,sw8,sw9,
     $       ikeep,isynch,isw5,isw6,isw7,isw8,isw9,spot1parm,spot2parm,
     %       spotdparm,primmass,primK,primrad,ratrad,frac1,frac2,ecosw,
     &       temprat,idark1,idark2,isw12,isw13,isw21,isw22,isw23,isw24,
     @       bigI,bigbeta,sw23,sw24,powercoeff, sw25,sw26,sw27,sw28,
     @       sw29,sw30,contam,Tconj,beam1,beam2,isw25,isw26,isw27,isw28,
     @       isw29,isw30,isw31,isw32,isw33,isw34,ocose,osine,omegadot,
     @       contamS0,contamS1,contamS2,contamS3,sw47,sw48,sw49)
c
c   Set the threshold to record models in files
c
          thresh=sw48
c
c  disable threshold for gridELC
c
          thresh=0.0d0
c
c  If the flag iatm>0, then load the model atmosphere table.
c
          if(iatm.ge.1)then
            call loadtable(maxlines,maxmu,Nlines,atmT,atmg,atmmu,Nmu,
     &      atmint1,atmint2,atmint3,atmint4,atmint5,atmint6,atmint7,atmint8,
     &      Tmax,Tmin,gmax,gmin)
          endif
c
c   November 17, 2012
c
c   If isw30 >= 1, then load the third body parameters
c
          if((isw30.ge.1).and.(isw7.ge.2))then
            call getbody3(Nalph3,Nbet3,tertperiod,tertt0,tertecos,
     @         tertesin,tertincl,tertOmega,tertQ,dwavex,dwavey,itconj,
     @         it1,it2,it3,it4,tertconj,tertratrad,hh,sw72,sw73,P2tconj,
     @         P2period,P2T0,P2ecos,P2esin,P2incl,P2Omega,P2Q,
     @         P2ratrad,
     @         P3tconj,P3period,P3T0,P3ecos,P3esin,P3incl,P3Omega,P3Q,
     @         P3ratrad,
     @         P4tconj,P4period,P4T0,P4ecos,P4esin,P4incl,P4Omega,P4Q,
     @         P4ratrad,
     @         P5tconj,P5period,P5T0,P5ecos,P5esin,P5incl,P5Omega,P5Q,
     @         P5ratrad,
     @         P6tconj,P6period,P6T0,P6ecos,P6esin,P6incl,P6Omega,P6Q,
     @         P6ratrad,
     @         P7tconj,P7period,P7T0,P7ecos,P7esin,P7incl,P7Omega,P7Q,
     @         P7ratrad,
     @         P8tconj,P8period,P8T0,P8ecos,P8esin,P8incl,P8Omega,P8Q,
     @         P8ratrad)

          endif
c
c   disable the dynamics output file
c
          it2=0
c
c   UPDATE December 15, 2012
c
c   if isw31 >= 1, load the gap parameters
c
          if(isw31.ge.1)call getgap(isw31,gaplow,gaphigh)
c
          NSC=0
          call getSC(NSC,xSC,ySC)

c
c   Use these flags when fitting for the period and/or T0
c
          itime=isw7
c
c   Do we force the gamma to be the input value?
c
          ifixgamma=isw4
c
c   Initialize the Sobel sequence here.
c
          nnn=-11
          call sobseq(nnn,xsob)
c
          gamma1=gamma
c
c   Disable the draw option
c
          idraw=0
c
c   Fix the inner disk radius at fill2.
c
          if(teff2.gt.0.0d0)rinner=fill2
c
c   if isw28 is greater than 0, then set the value of T0 based
c   on the time of transit Tconj.
c
          if(isw28.gt.0)then
            call getT0(finc,period,ecc,argper,T0,Tconj)
          endif
c
          call initNdata(NdataU,NdataB,NdataV,NdataR,
     &        NdataI,NdataJ,NdataH,NdataK,
     %        NRV1,NRV2,Nobv,NRV3)
c
c   Initialize the steps.
c
          do  i=1,nvmax
            Nstep(i)=1
            var(i)=0.0d0
            svar(i)='none'
            sss(i)=0.0d0
          enddo
c
c   Get the parameters for the grid search.
c
          call getloopopt(Udatafile,Bdatafile,Vdatafile,Rdatafile,
     $      Idatafile,Jdatafile,Hdatafile,Kdatafile,RV1file,RV2file,
     @      Nvmax,Nvar,svar,var,vstart,vstep,Nstep,Nobv,sobv,obv,eobv)

c   UPDATE FEBRUARY 5, 2005
c
c   Add also the ability to include the luminosity ratio in the total chi^2
c
          ifrac=-99
          ilum=-99
          do 111 i=1,Nobv
            icn=icnvrt(sobv(i)(1:2))
            if((icn.eq.104).and.(iidint.ge.1))ifrac=99 ! disk fraction = yes
            if((icn.eq.1112).and.(iidint.ge.1))ifrac=99 ! disk fraction = yes
            if((icn.eq.1113).and.(iidint.ge.1))ifrac=99 ! disk fraction = yes
            if((icn.eq.1114).and.(iidint.ge.1))ifrac=99 ! disk fraction = yes
            if((icn.eq.1115).and.(iidint.ge.1))ifrac=99 ! disk fraction = yes
            if((icn.eq.1116).and.(iidint.ge.1))ifrac=99 ! disk fraction = yes
            if((icn.eq.1117).and.(iidint.ge.1))ifrac=99 ! disk fraction = yes
            if((icn.eq.1118).and.(iidint.ge.1))ifrac=99 ! disk fraction = yes
            if((icn.eq.1119).and.(iidint.ge.1))ifrac=99 ! disk fraction = yes
            if((icn.eq.369))ilum=99 ! luminosity ratio = yes
 111      continue
c
c   Figure out which data files were specified.
c
          icnU=icnvrt(Udatafile(1:2))
          icnB=icnvrt(Bdatafile(1:2))
          icnV=icnvrt(Vdatafile(1:2))
          icnR=icnvrt(Rdatafile(1:2))
          icnI=icnvrt(Idatafile(1:2))
          icnJ=icnvrt(Jdatafile(1:2))
          icnH=icnvrt(Hdatafile(1:2))
          icnK=icnvrt(Kdatafile(1:2))
          icnRV1=icnvrt(RV1file(1:2))
          icnRV2=icnvrt(RV2file(1:2))
c
c   icn? = 430 indicates that no file was specified.  Load the files listed.
c
          if(icnU.ne.430)call loaddata(Ndatamax,Udatafile,
     &        NdataU,xdataU,ydataU,errU)
          if(icnB.ne.430)call loaddata(Ndatamax,Bdatafile,
     &        NdataB,xdataB,ydataB,errB)
          if(icnV.ne.430)call loaddata(Ndatamax,Vdatafile,
     &        NdataV,xdataV,ydataV,errV)
          if(icnR.ne.430)call loaddata(Ndatamax,Rdatafile,
     &        NdataR,xdataR,ydataR,errR)
          if(icnI.ne.430)call loaddata(Ndatamax,Idatafile,
     &        NdataI,xdataI,ydataI,errI)
          if(icnJ.ne.430)call loaddata(Ndatamax,Jdatafile,
     &        NdataJ,xdataJ,ydataJ,errJ)
          if(icnH.ne.430)call loaddata(Ndatamax,Hdatafile,
     &        NdataH,xdataH,ydataH,errH)
          if(icnK.ne.430)call loaddata(Ndatamax,Kdatafile,
     &        NdataK,xdataK,ydataK,errK)
          if(icnRV1.ne.430)call loaddata(Ndatamax,RV1file,
     &        NRV1,xRV1,yRV1,errRV1)
          if(icnRV2.ne.430)call loaddata(Ndatamax,RV2file,
     &        NRV2,xRV2,yRV2,errRV2)
c
c   If we are fitting for the period and/or T0, we have to make copies
c   of the arrays.
c
          if(icnU.ne.430)call kopydata(Ndatamax,NdataU,
     $       xdataU,ydataU,errU,isavNU,
     $       savxdataU,savydataU,saverrU)
          if(icnB.ne.430)call kopydata(Ndatamax,NdataB,
     $       xdataB,ydataB,errB,isavNB,
     $       savxdataB,savydataB,saverrB)
          if(icnV.ne.430)call kopydata(Ndatamax,NdataV,
     $       xdataV,ydataV,errV,isavNV,
     $       savxdataV,savydataV,saverrV)
          if(icnI.ne.430)call kopydata(Ndatamax,NdataI,
     $       xdataI,ydataI,errI,isavNI,
     $       savxdataI,savydataI,saverrI)
          if(icnJ.ne.430)call kopydata(Ndatamax,NdataJ,
     $       xdataJ,ydataJ,errJ,isavNJ,
     $       savxdataJ,savydataJ,saverrJ)
          if(icnH.ne.430)call kopydata(Ndatamax,NdataH,
     $       xdataH,ydataH,errH,isavNH,
     $       savxdataH,savydataH,saverrH)
          if(icnK.ne.430)call kopydata(Ndatamax,NdataK,
     $       xdataK,ydataK,errK,isavNK,
     $       savxdataK,savydataK,saverrK)
          if(icnR.ne.430)call kopydata(Ndatamax,NdataR,
     $       xdataR,ydataR,errR,isavNR,
     $       savxdataR,savydataR,saverrR)
          if(icnRV1.ne.430)call kopydata(Ndatamax,NRV1,
     $       xRV1,yRV1,errRV1,isavRV1,
     $       savxRV1,savyRV1,saverrRV1)
          if(icnRV2.ne.430)call kopydata(Ndatamax,NRV2,
     $       xRV2,yRV2,errRV2,isavRV2,
     $       savxRV2,savyRV2,saverrRV2)
c
c   Sort the data files by phase just to be on the safe side.
c
c   Put an if-then clause to cover the case when Ndata=1
c
          if((icnU.ne.430).and.(NdataU.gt.1))
     @         call sort3(NdataU,xdataU,ydataU,errU)
          if((icnB.ne.430).and.(NdataB.gt.1))
     @         call sort3(NdataB,xdataB,ydataB,errB)
          if((icnV.ne.430).and.(NdataV.gt.1))
     @         call sort3(NdataV,xdataV,ydataV,errV)
          if((icnR.ne.430).and.(NdataR.gt.1))
     @         call sort3(NdataR,xdataR,ydataR,errR)
          if((icnI.ne.430).and.(NdataI.gt.1))
     @         call sort3(NdataI,xdataI,ydataI,errI)
          if((icnJ.ne.430).and.(NdataJ.gt.1))
     @         call sort3(NdataJ,xdataJ,ydataJ,errJ)
          if((icnH.ne.430).and.(NdataH.gt.1))
     @         call sort3(NdataH,xdataH,ydataH,errH)
          if((icnK.ne.430).and.(NdataK.gt.1))
     @         call sort3(NdataK,xdataK,ydataK,errK)
          if((icnRV1.ne.430).and.(NRV1.gt.1))
     @         call sort3(NRV1,xRV1,yRV1,errRV1)
          if((icnRV2.ne.430).and.(NRV2.gt.1))
     @         call sort3(NRV2,xRV2,yRV2,errRV2)
c
c
c  If we are fitting eclipse times ((isw30.ge.3).and.(isw23.ge.1))
c  then load the data
c
          icnRV3=430
          if((isw30.ge.3).and.(isw23.ge.1))then
            call loadtimes(icnarray,Nobscycle,obsTtimes,obsTerr,
     @        NRV3,xRV3,yRV3,errRV3,Ndatamax,icnRV3,Nmaxeclipse)
          endif
c
          isvel1=0
          isvel2=0
          if(icnRV1.ne.430)isvel1=299
          if(icnRV2.ne.430)isvel2=299
c
          gamma1=gamma
          gamma2=gamma
c
c   Define the variables whose values will be printed on the screen at the
c   end of the iteration.
c
          open(unit=55,file='chi.0000',status='unknown')
          open(unit=45,file='generation.0000',status='unknown')
          open(unit=46,file='ELCparm.0000',status='unknown')
          if(isw24.ge.1)open(unit=47,file='ELCratio.0000',
     $      status='unknown')
          if(isw30.ge.1)open(unit=48,file='ELCbody3parm.0000',
     @      status='unknown')
          if(isw30.ge.3)open(unit=49,file='ELCdynparm.0000',
     @      status='unknown')
c
c   Start the grid search here.  This code is more or less from Bevington
c   (1969).
c
          chi1=0.0
          chi2=0.0
          chi3=0.0
          chilimb=0.0d0
          small=1.0d33
          Ndattot=NdataU+NdataB+NdataV+NdataR+NdataI+NdataJ+NdataH+
     @       NdataK+NRV1+NRV2+Nobv+NRV3
c
          Nterms=0
c
c   UPDATE May 30, 2002
c
c   Change the upper loop limit to max(1,Nvar)
c
          do 699 i7=1,max(1,Nvar)
            var(i7)=vstart(i7)     !initialize the variables
            kkk=icnvrt(svar(i7)(1:2))
            stepsave(i7)=vstep(i7)
            if(kkk.ne.430)then
              Nterms=Nterms+1
            endif
 699      continue
c
c   UPDATE May 30, 2002
c
c   Change the if-then statement to Nvar.eq.0
c
 749      if(Nvar.eq.0)go to 69   !no valid variables specified
c
          write(*,*)'Nterms, Nvar, Ndattot',Nterms,Nvar,Ndattot
          i16=0
          do 750 ijk=1,Nstep(1)
            do 700 i7=1,Nvar     !Nterms
              kkk=icnvrt(svar(i7)(1:2))
              if(kkk.eq.430)go to 700
c
              ibest=0
              ichilabel=1
              call monster(Nphase,Nmaxphase,xmod,ymodU,ymodB,ymodV,
     @           ymodR,ymodI,ymodJ,ymodH,ymodK,ymods1,ymods2,ymods3,
     @           ymodd,RV1,RV2,drv1,drv2,obsparm,ifastflag,NRVphase,
     @           xRVmod,fracs1,fracs2,fracs3,fracs4,fracs5,fracs6,
     &           fracs7,fracs8,chisqU,chisqB,chisqV,chisqR,chisqI,
     &           chisqJ,chisqH,chisqK,chisqRV1,chisqRV2,chilimb,chi1,
     @           NdataU,xdataU,ydataU,errU,zeroU,resU,NdataB,xdataB,
     @           ydataB,errB,zeroB,resB,NdataV,xdataV,ydataV,errV,zeroV,
     @           resV,NdataR,xdataR,ydataR,errR,zeroR,resR,NdataI,
     @           xdataI,ydataI,errI,zeroI,resI,NdataJ,xdataJ,ydataJ,
     @           errJ,zeroJ,resJ,NdataH,xdataH,ydataH,errH,zeroH,resH,
     @           NdataK,xdataK,ydataK,errK,zeroK,resK,NRV1,xRV1,yRV1,
     @           errRV1,NRV2,xRV2,yRV2,errRV2,ggamma1,ggamma2,Nobv,sobv,
     @           obv,eobv,ochi,ochidisk,ochilr,Nvmax,svar,var,saveasini,
     @           savxdataU,savydataU,saverrU,savxdataB,savydataB,
     @           saverrB,savxdataV,savydataV,saverrV,savxdataR,
     @           savydataR,saverrR,savxdataI,savydataI,saverrI,
     @           savxdataJ,savydataJ,saverrJ,savxdataH,savydataH,
     @           saverrH,savxdataK,savydataK,saverrK,savxRV1,savyRV1,
     @           saverrRV1,savxRV2,savyRV2,saverrRV2,ifrac,ilum,i16,
     @           isavNU,isavNB,isavNV,isavNR,isavNI,isavNJ,isavNH,
     @           isavNK,isavRV1,isavRV2,isvel1,isvel2,Ndatamax,ibest,
     @           ifixgamma,savesep,ichilabel,resRV1,resRV2,thresh,
     @           small,Ncycle,Ttimes,Tseps,Nobscycle,obsTtimes,obsTerr,
     &           icnarray,RV3,xRV3,yRV3,errRV3,icnRV3,resRV3,ggamma3,
     @           NRV3,
     @     parmstring,planetparm,dynparm,line,fill1,fill2,omega1,
     @    omega2,dphase,Q,finc,Teff1,Teff2,Tgrav1,Tgrav2,betarim,
     @    rinner,router,tdisk,xi,alb1,alb2,rLx,Period,fm,separ,
     @    gamma,wave,dbolx,dboly,dwavex,dwavey,t3,g3,SA3,density,
     @    sw1,sw2,sw3,T0,ecc,argper,pshift,sw5,sw6,sw7,sw8,sw9,
     @    primmass,primK,primrad,ratrad,frac1,frac2,ecosw,temprat,
     @    bigI,bigbeta,sw23,sw24,powercoeff,sw25,sw26,sw27,sw28,
     @    sw29,sw30,contam,Tconj,beam1,beam2,ocose,osine,omegadot,
     @    contamS0,contamS1,contamS2,contamS3,sw47,sw48,sw49,gaplow,
     @    gaphigh,P2tconj,P2period,P2T0,P2ecos,P2esin,P2incl,P2Omega,
     @    P2Q,P2ratrad,P3tconj,P3period,P3T0,P3ecos,P3esin,P3incl,
     @    P3Omega,P3Q,P3ratrad,P4tconj,P4period,P4T0,P4ecos,P4esin,
     @    P4incl,P4Omega,P4Q,P4ratrad,P5tconj,P5period,P5T0,P5ecos,
     @    P5esin,P5incl,P5Omega,P5Q,P5ratrad,P6tconj,P6period,P6T0,
     @    P6ecos,P6esin,P6incl,P6Omega,P6Q,P6ratrad,P7tconj,P7period,
     @    P7T0,P7ecos,P7esin,P7incl,P7Omega,P7Q,P7ratrad,P8tconj,
     @    P8period,P8T0,P8ecos,P8esin,P8incl,P8Omega,P8Q,P8ratrad,
     @    xSC,ySC,spot1parm,spot2parm,spotdparm,Nalph1,Nbet1,Nalph2,
     @    Nbet2,Ntheta,Nradius,Nref,idraw,iecheck,iidint,iatm,ism1,
     @    ilaw,icnU,icnB,icnV,icnR,icnI,icnJ,icnH,icnK,icnRV1,icnRV2,
     @    iRVfilt,isw1,isw2,isw3,isw4,ikeep,isynch,isw5,isw6,isw7,
     @    isw8,isw9,idark1,idark2,isw12,isw13,isw21,isw22,isw23,isw24,
     @    isw25,isw26,isw27,isw28,isw29,isw30,isw31,isw32,isw33,isw34,
     @    NSC,compfracs,tertperiod,tertt0,tertecos,tertesin,
     @    tertincl,tertOmega,tertQ,tertconj,tertratrad,hh,sw72,sw73,
     @    Nmaxeclipse,Tdur1,Tdur2)
c
              call printgriditer(i16+1,'model number = ',ijk,
     @          'iteration number = ',svar(i7),isw29)
c
              if(Ndattot-Nterms.ge.1)then
                chi1=chi1/dabs(dble(Ndattot-Nterms))
              endif

              if(chi1.lt.small)then
                small=chi1
                do mmm=1,Nvmax
                  sss(mmm)=var(mmm)
                enddo
              endif

              i16=i16+1
              fn=0.0
              delta=vstep(i7)
              var(i7)=var(i7)+delta
c
              ibest=0
              ichilabel=2
              call monster(Nphase,Nmaxphase,xmod,ymodU,ymodB,ymodV,
     @           ymodR,ymodI,ymodJ,ymodH,ymodK,ymods1,ymods2,ymods3,
     @           ymodd,RV1,RV2,drv1,drv2,obsparm,ifastflag,NRVphase,
     @           xRVmod,fracs1,fracs2,fracs3,fracs4,fracs5,fracs6,
     &           fracs7,fracs8,chisqU,chisqB,chisqV,chisqR,chisqI,
     &           chisqJ,chisqH,chisqK,chisqRV1,chisqRV2,chilimb,chi2,
     @           NdataU,xdataU,ydataU,errU,zeroU,resU,NdataB,xdataB,
     @           ydataB,errB,zeroB,resB,NdataV,xdataV,ydataV,errV,zeroV,
     @           resV,NdataR,xdataR,ydataR,errR,zeroR,resR,NdataI,
     @           xdataI,ydataI,errI,zeroI,resI,NdataJ,xdataJ,ydataJ,
     @           errJ,zeroJ,resJ,NdataH,xdataH,ydataH,errH,zeroH,resH,
     @           NdataK,xdataK,ydataK,errK,zeroK,resK,NRV1,xRV1,yRV1,
     @           errRV1,NRV2,xRV2,yRV2,errRV2,ggamma1,ggamma2,Nobv,sobv,
     @           obv,eobv,ochi,ochidisk,ochilr,Nvmax,svar,var,saveasini,
     @           savxdataU,savydataU,saverrU,savxdataB,savydataB,
     @           saverrB,savxdataV,savydataV,saverrV,savxdataR,
     @           savydataR,saverrR,savxdataI,savydataI,saverrI,
     @           savxdataJ,savydataJ,saverrJ,savxdataH,savydataH,
     @           saverrH,savxdataK,savydataK,saverrK,savxRV1,savyRV1,
     @           saverrRV1,savxRV2,savyRV2,saverrRV2,ifrac,ilum,i16,
     @           isavNU,isavNB,isavNV,isavNR,isavNI,isavNJ,isavNH,
     @           isavNK,isavRV1,isavRV2,isvel1,isvel2,Ndatamax,ibest,
     @           ifixgamma,savesep,ichilabel,resRV1,resRV2,thresh,
     @           small,Ncycle,Ttimes,Tseps,Nobscycle,obsTtimes,obsTerr,
     &           icnarray,RV3,xRV3,yRV3,errRV3,icnRV3,resRV3,ggamma3,
     @           NRV3,parmstring,planetparm,dynparm,line,fill1,
     @    fill2,omega1,
     @    omega2,dphase,Q,finc,Teff1,Teff2,Tgrav1,Tgrav2,betarim,
     @    rinner,router,tdisk,xi,alb1,alb2,rLx,Period,fm,separ,
     @    gamma,wave,dbolx,dboly,dwavex,dwavey,t3,g3,SA3,density,
     @    sw1,sw2,sw3,T0,ecc,argper,pshift,sw5,sw6,sw7,sw8,sw9,
     @    primmass,primK,primrad,ratrad,frac1,frac2,ecosw,temprat,
     @    bigI,bigbeta,sw23,sw24,powercoeff,sw25,sw26,sw27,sw28,
     @    sw29,sw30,contam,Tconj,beam1,beam2,ocose,osine,omegadot,
     @    contamS0,contamS1,contamS2,contamS3,sw47,sw48,sw49,gaplow,
     @    gaphigh,P2tconj,P2period,P2T0,P2ecos,P2esin,P2incl,P2Omega,
     @    P2Q,P2ratrad,P3tconj,P3period,P3T0,P3ecos,P3esin,P3incl,
     @    P3Omega,P3Q,P3ratrad,P4tconj,P4period,P4T0,P4ecos,P4esin,
     @    P4incl,P4Omega,P4Q,P4ratrad,P5tconj,P5period,P5T0,P5ecos,
     @    P5esin,P5incl,P5Omega,P5Q,P5ratrad,P6tconj,P6period,P6T0,
     @    P6ecos,P6esin,P6incl,P6Omega,P6Q,P6ratrad,P7tconj,P7period,
     @    P7T0,P7ecos,P7esin,P7incl,P7Omega,P7Q,P7ratrad,P8tconj,
     @    P8period,P8T0,P8ecos,P8esin,P8incl,P8Omega,P8Q,P8ratrad,
     @    xSC,ySC,spot1parm,spot2parm,spotdparm,Nalph1,Nbet1,Nalph2,
     @    Nbet2,Ntheta,Nradius,Nref,idraw,iecheck,iidint,iatm,ism1,
     @    ilaw,icnU,icnB,icnV,icnR,icnI,icnJ,icnH,icnK,icnRV1,icnRV2,
     @    iRVfilt,isw1,isw2,isw3,isw4,ikeep,isynch,isw5,isw6,isw7,
     @    isw8,isw9,idark1,idark2,isw12,isw13,isw21,isw22,isw23,isw24,
     @    isw25,isw26,isw27,isw28,isw29,isw30,isw31,isw32,isw33,isw34,
     @    NSC,compfracs,tertperiod,tertt0,tertecos,tertesin,
     @    tertincl,tertOmega,tertQ,tertconj,tertratrad,hh,sw72,sw73,
     @    Nmaxeclipse,Tdur1,Tdur2)
c
              if(Ndattot-Nterms.ge.1)then
                chi2=chi2/dabs(dble(Ndattot-Nterms))
              endif

              call printgriditer(i16+1,'model number = ',ijk,
     @          'iteration number = ',svar(i7),isw29)
c
              if(chi2.lt.small)then
                small=chi2
                do mmm=1,Nvmax
                  sss(mmm)=var(mmm)
                enddo
              endif
c
              i16=i16+1
c
              diff=chi1-chi2
              if(diff.gt.0.0)go to 5061
c
              delta=-delta
              var(i7)=var(i7)+delta
c
              csave=chi1
              chi1=chi2
              chi2=csave
c
c   incriment the variable var(i7) until chi square increases
c
 5061         fn=fn+1.0
c
              var(i7)=var(i7)+delta
c
              ibest=0
              ichilabel=3
              call monster(Nphase,Nmaxphase,xmod,ymodU,ymodB,ymodV,
     @           ymodR,ymodI,ymodJ,ymodH,ymodK,ymods1,ymods2,ymods3,
     @           ymodd,RV1,RV2,drv1,drv2,obsparm,ifastflag,NRVphase,
     @           xRVmod,fracs1,fracs2,fracs3,fracs4,fracs5,fracs6,
     &           fracs7,fracs8,chisqU,chisqB,chisqV,chisqR,chisqI,
     &           chisqJ,chisqH,chisqK,chisqRV1,chisqRV2,chilimb,chi3,
     @           NdataU,xdataU,ydataU,errU,zeroU,resU,NdataB,xdataB,
     @           ydataB,errB,zeroB,resB,NdataV,xdataV,ydataV,errV,zeroV,
     @           resV,NdataR,xdataR,ydataR,errR,zeroR,resR,NdataI,
     @           xdataI,ydataI,errI,zeroI,resI,NdataJ,xdataJ,ydataJ,
     @           errJ,zeroJ,resJ,NdataH,xdataH,ydataH,errH,zeroH,resH,
     @           NdataK,xdataK,ydataK,errK,zeroK,resK,NRV1,xRV1,yRV1,
     @           errRV1,NRV2,xRV2,yRV2,errRV2,ggamma1,ggamma2,Nobv,sobv,
     @           obv,eobv,ochi,ochidisk,ochilr,Nvmax,svar,var,saveasini,
     @           savxdataU,savydataU,saverrU,savxdataB,savydataB,
     @           saverrB,savxdataV,savydataV,saverrV,savxdataR,
     @           savydataR,saverrR,savxdataI,savydataI,saverrI,
     @           savxdataJ,savydataJ,saverrJ,savxdataH,savydataH,
     @           saverrH,savxdataK,savydataK,saverrK,savxRV1,savyRV1,
     @           saverrRV1,savxRV2,savyRV2,saverrRV2,ifrac,ilum,i16,
     @           isavNU,isavNB,isavNV,isavNR,isavNI,isavNJ,isavNH,
     @           isavNK,isavRV1,isavRV2,isvel1,isvel2,Ndatamax,ibest,
     @           ifixgamma,savesep,ichilabel,resRV1,resRV2,thresh,
     @           small,Ncycle,Ttimes,Tseps,Nobscycle,obsTtimes,obsTerr,
     @           icnarray,RV3,xRV3,yRV3,errRV3,icnRV3,resRV3,ggamma3,
     @           NRV3,parmstring,planetparm,dynparm,line,fill1,
     @    fill2,omega1,
     @    omega2,dphase,Q,finc,Teff1,Teff2,Tgrav1,Tgrav2,betarim,
     @    rinner,router,tdisk,xi,alb1,alb2,rLx,Period,fm,separ,
     @    gamma,wave,dbolx,dboly,dwavex,dwavey,t3,g3,SA3,density,
     @    sw1,sw2,sw3,T0,ecc,argper,pshift,sw5,sw6,sw7,sw8,sw9,
     @    primmass,primK,primrad,ratrad,frac1,frac2,ecosw,temprat,
     @    bigI,bigbeta,sw23,sw24,powercoeff,sw25,sw26,sw27,sw28,
     @    sw29,sw30,contam,Tconj,beam1,beam2,ocose,osine,omegadot,
     @    contamS0,contamS1,contamS2,contamS3,sw47,sw48,sw49,gaplow,
     @    gaphigh,P2tconj,P2period,P2T0,P2ecos,P2esin,P2incl,P2Omega,
     @    P2Q,P2ratrad,P3tconj,P3period,P3T0,P3ecos,P3esin,P3incl,
     @    P3Omega,P3Q,P3ratrad,P4tconj,P4period,P4T0,P4ecos,P4esin,
     @    P4incl,P4Omega,P4Q,P4ratrad,P5tconj,P5period,P5T0,P5ecos,
     @    P5esin,P5incl,P5Omega,P5Q,P5ratrad,P6tconj,P6period,P6T0,
     @    P6ecos,P6esin,P6incl,P6Omega,P6Q,P6ratrad,P7tconj,P7period,
     @    P7T0,P7ecos,P7esin,P7incl,P7Omega,P7Q,P7ratrad,P8tconj,
     @    P8period,P8T0,P8ecos,P8esin,P8incl,P8Omega,P8Q,P8ratrad,
     @    xSC,ySC,spot1parm,spot2parm,spotdparm,Nalph1,Nbet1,Nalph2,
     @    Nbet2,Ntheta,Nradius,Nref,idraw,iecheck,iidint,iatm,ism1,
     @    ilaw,icnU,icnB,icnV,icnR,icnI,icnJ,icnH,icnK,icnRV1,icnRV2,
     @    iRVfilt,isw1,isw2,isw3,isw4,ikeep,isynch,isw5,isw6,isw7,
     @    isw8,isw9,idark1,idark2,isw12,isw13,isw21,isw22,isw23,isw24,
     @    isw25,isw26,isw27,isw28,isw29,isw30,isw31,isw32,isw33,isw34,
     @    NSC,compfracs,tertperiod,tertt0,tertecos,tertesin,
     @    tertincl,tertOmega,tertQ,tertconj,tertratrad,hh,sw72,sw73,
     @    Nmaxeclipse,Tdur1,Tdur2)
c
              if(Ndattot-Nterms.ge.1)then
                chi3=chi3/dabs(dble(Ndattot-Nterms))
              endif
              call printgriditer(i16+1,'model number = ',ijk,
     @        'iteration number = ',svar(i7),isw29)
c
              if(chi3.lt.small)then
                small=chi3
                do mmm=1,Nvmax
                  sss(mmm)=var(mmm)
                enddo
              endif
c
              i16=i16+1
c
              diff23=chi3-chi2
              if(diff23.lt.0)then
                chi1=chi2
                chi2=chi3
                go to 5061
              endif
c
c  Find the minimum of parabola defined by the last three points.
c
              if(chi3-chi2.eq.0.0)go to 700
              delta=delta*(1.0/(1.0+(chi1-chi2)/(chi3-chi2))+0.5)
              var(i7)=var(i7)-delta
              free=dabs(dble(Ndattot-Nterms))
              sigvar(i7)=vstep(i7)*sqrt(2.0/(free*(chi3-2.0*chi2+chi1)))
              vstep(i7)=vstep(i7)*fn/3.0
c
              if((Nterms.eq.1).or.(i7.eq.Nvar))then   ! (i7.eq.Nterms))then
c
                ibest=0
                ichilabel=4
                call monster(Nphase,Nmaxphase,xmod,ymodU,ymodB,ymodV,
     @           ymodR,ymodI,ymodJ,ymodH,ymodK,ymods1,ymods2,ymods3,
     @           ymodd,RV1,RV2,drv1,drv2,obsparm,ifastflag,NRVphase,
     @           xRVmod,fracs1,fracs2,fracs3,fracs4,fracs5,fracs6,
     &           fracs7,fracs8,chisqU,chisqB,chisqV,chisqR,chisqI,
     &           chisqJ,chisqH,chisqK,chisqRV1,chisqRV2,chilimb,chi4,
     @           NdataU,xdataU,ydataU,errU,zeroU,resU,NdataB,xdataB,
     @           ydataB,errB,zeroB,resB,NdataV,xdataV,ydataV,errV,zeroV,
     @           resV,NdataR,xdataR,ydataR,errR,zeroR,resR,NdataI,
     @           xdataI,ydataI,errI,zeroI,resI,NdataJ,xdataJ,ydataJ,
     @           errJ,zeroJ,resJ,NdataH,xdataH,ydataH,errH,zeroH,resH,
     @           NdataK,xdataK,ydataK,errK,zeroK,resK,NRV1,xRV1,yRV1,
     @           errRV1,NRV2,xRV2,yRV2,errRV2,ggamma1,ggamma2,Nobv,sobv,
     @           obv,eobv,ochi,ochidisk,ochilr,Nvmax,svar,var,saveasini,
     @           savxdataU,savydataU,saverrU,savxdataB,savydataB,
     @           saverrB,savxdataV,savydataV,saverrV,savxdataR,
     @           savydataR,saverrR,savxdataI,savydataI,saverrI,
     @           savxdataJ,savydataJ,saverrJ,savxdataH,savydataH,
     @           saverrH,savxdataK,savydataK,saverrK,savxRV1,savyRV1,
     @           saverrRV1,savxRV2,savyRV2,saverrRV2,ifrac,ilum,i16,
     @           isavNU,isavNB,isavNV,isavNR,isavNI,isavNJ,isavNH,
     @           isavNK,isavRV1,isavRV2,isvel1,isvel2,Ndatamax,ibest,
     @           ifixgamma,savesep,ichilabel,resRV1,resRV2,thresh,
     @           small,Ncycle,Ttimes,Tseps,Nobscycle,obsTtimes,obsTerr,
     &           icnarray,RV3,xRV3,yRV3,errRV3,icnRV3,resRV3,ggamma3,
     @           NRV3,parmstring,planetparm,dynparm,line,fill1,
     @    fill2,omega1,
     @    omega2,dphase,Q,finc,Teff1,Teff2,Tgrav1,Tgrav2,betarim,
     @    rinner,router,tdisk,xi,alb1,alb2,rLx,Period,fm,separ,
     @    gamma,wave,dbolx,dboly,dwavex,dwavey,t3,g3,SA3,density,
     @    sw1,sw2,sw3,T0,ecc,argper,pshift,sw5,sw6,sw7,sw8,sw9,
     @    primmass,primK,primrad,ratrad,frac1,frac2,ecosw,temprat,
     @    bigI,bigbeta,sw23,sw24,powercoeff,sw25,sw26,sw27,sw28,
     @    sw29,sw30,contam,Tconj,beam1,beam2,ocose,osine,omegadot,
     @    contamS0,contamS1,contamS2,contamS3,sw47,sw48,sw49,gaplow,
     @    gaphigh,P2tconj,P2period,P2T0,P2ecos,P2esin,P2incl,P2Omega,
     @    P2Q,P2ratrad,P3tconj,P3period,P3T0,P3ecos,P3esin,P3incl,
     @    P3Omega,P3Q,P3ratrad,P4tconj,P4period,P4T0,P4ecos,P4esin,
     @    P4incl,P4Omega,P4Q,P4ratrad,P5tconj,P5period,P5T0,P5ecos,
     @    P5esin,P5incl,P5Omega,P5Q,P5ratrad,P6tconj,P6period,P6T0,
     @    P6ecos,P6esin,P6incl,P6Omega,P6Q,P6ratrad,P7tconj,P7period,
     @    P7T0,P7ecos,P7esin,P7incl,P7Omega,P7Q,P7ratrad,P8tconj,
     @    P8period,P8T0,P8ecos,P8esin,P8incl,P8Omega,P8Q,P8ratrad,
     @    xSC,ySC,spot1parm,spot2parm,spotdparm,Nalph1,Nbet1,Nalph2,
     @    Nbet2,Ntheta,Nradius,Nref,idraw,iecheck,iidint,iatm,ism1,
     @    ilaw,icnU,icnB,icnV,icnR,icnI,icnJ,icnH,icnK,icnRV1,icnRV2,
     @    iRVfilt,isw1,isw2,isw3,isw4,ikeep,isynch,isw5,isw6,isw7,
     @    isw8,isw9,idark1,idark2,isw12,isw13,isw21,isw22,isw23,isw24,
     @    isw25,isw26,isw27,isw28,isw29,isw30,isw31,isw32,isw33,isw34,
     @    NSC,compfracs,tertperiod,tertt0,tertecos,tertesin,
     @    tertincl,tertOmega,tertQ,tertconj,tertratrad,hh,sw72,sw73,
     @    Nmaxeclipse,Tdur1,Tdur2)
c
                if(Ndattot-Nterms.ge.1)then
                  chi4=chi4/dabs(dble(Ndattot-Nterms))
                endif

                call printgriditer(i16+1,'model number = ',ijk,
     @           'iteration number = ',svar(i7),isw29)
c
                if(chi4.lt.small)then
                  small=chi4
                  do mmm=1,Nvmax
                    sss(mmm)=var(mmm)
                  enddo
                endif
c
                i16=i16+1
              endif

 700        continue  !loop over the 7 terms
c
            write(*,*)' '
c
            do 7749 iq=1,Nvar      !Nterms
              write(*,1001)var(iq),sigvar(iq),svar(iq)(1:15)
 7749       continue
c
            call printS(small)

            if((isw30.ge.3).and.(isw23.ge.1))then
              call writeeclipse(Ncycle,Ttimes,Tseps,isw30,Nmaxeclipse,
     @           Tdur1,Tdur2)
            endif
c
            if(icnU.ne.430)call wlinmod(Nphase,xmod,ymodU,
     @          'modelU.linear',isw7)
            if(icnB.ne.430)call wlinmod(Nphase,xmod,ymodB,
     @          'modelB.linear',isw7)
            if(icnV.ne.430)call wlinmod(Nphase,xmod,ymodV,
     @          'modelV.linear',isw7)
            if(icnR.ne.430)call wlinmod(Nphase,xmod,ymodR,
     @          'modelR.linear',isw7)
            if(icnI.ne.430)call wlinmod(Nphase,xmod,ymodI,
     @          'modelI.linear',isw7)
            if(icnJ.ne.430)call wlinmod(Nphase,xmod,ymodJ,
     @          'modelJ.linear',isw7)
            if(icnH.ne.430)call wlinmod(Nphase,xmod,ymodH,
     @          'modelH.linear',isw7)
            if(icnK.ne.430)call wlinmod(Nphase,xmod,ymodK,
     @          'modelK.linear',isw7)
            call wRVmod(NRVphase,xRVmod,RV1,'star1.RV',isw7,ggamma1)
            call wRVmod(NRVphase,xRVmod,RV2,'star2.RV',isw7,ggamma2)
            call wRVmod(NRVphase,xRVmod,RV3,'star3.RV',isw7,ggamma1)
c
            if(icnU.ne.430)call wmagmod(Nphase,xmod,ymodU,'modelU.mag',
     @         isw7,zeroU)
            if(icnB.ne.430)call wmagmod(Nphase,xmod,ymodB,'modelB.mag',
     @         isw7,zeroB)
            if(icnV.ne.430)call wmagmod(Nphase,xmod,ymodV,'modelV.mag',
     @         isw7,zeroV)
            if(icnR.ne.430)call wmagmod(Nphase,xmod,ymodR,'modelR.mag',
     @         isw7,zeroR)
            if(icnI.ne.430)call wmagmod(Nphase,xmod,ymodI,'modelI.mag',
     @         isw7,zeroI)
            if(icnJ.ne.430)call wmagmod(Nphase,xmod,ymodJ,'modelJ.mag',
     @         isw7,zeroJ)
            if(icnH.ne.430)call wmagmod(Nphase,xmod,ymodH,'modelH.mag',
     @         isw7,zeroH)
            if(icnK.ne.430)call wmagmod(Nphase,xmod,ymodK,'modelK.mag',
     @         isw7,zeroK)
c
            if(itime.gt.0)then
              if(icnU.ne.430)call wELCdata(Ndatamax,NdataU,xdataU,
     @           ydataU,errU,'ELCdataU.fold')
              if(icnB.ne.430)call wELCdata(Ndatamax,NdataB,xdataB,
     @           ydataB,errB,'ELCdataB.fold')
              if(icnV.ne.430)call wELCdata(Ndatamax,NdataV,xdataV,
     @           ydataV,errV,'ELCdataV.fold')
              if(icnR.ne.430)call wELCdata(Ndatamax,NdataR,xdataR,
     @           ydataR,errR,'ELCdataR.fold')
              if(icnI.ne.430)call wELCdata(Ndatamax,NdataI,xdataI,
     @           ydataI,errI,'ELCdataI.fold')
              if(icnJ.ne.430)call wELCdata(Ndatamax,NdataJ,xdataJ,
     @           ydataJ,errJ,'ELCdataJ.fold')
              if(icnH.ne.430) call wELCdata(Ndatamax,NdataH,xdataH,
     @           ydataH,errH,'ELCdataH.fold')
              if(icnK.ne.430)call wELCdata(Ndatamax,NdataK,xdataK,
     @           ydataK,errK,'ELCdataK.fold')
              if(icnRV1.ne.430) call wELCdata(Ndatamax,NRV1,xRV1,yRV1,
     %              errRV1,'ELCdataRV1.fold')
              if(icnRV2.ne.430) call wELCdata(Ndatamax,NRV2,xRV2,yRV2,
     %              errRV2,'ELCdataRV2.fold')
              if(icnRV3.ne.430) call wELCdata(Ndatamax,NRV3,xRV3,yRV3,
     %              errRV3,'ELCdataRV3.fold')
            endif
c
            if(icnU.ne.430)call wELCdata(Ndatamax,NdataU,xdataU,resU,
     %              errU,'ELCresidualsU.fold')
            if(icnB.ne.430)call wELCdata(Ndatamax,NdataB,xdataB,resB,
     %              errB,'ELCresidualsB.fold')
            if(icnV.ne.430)call wELCdata(Ndatamax,NdataV,xdataV,resV,
     %              errV,'ELCresidualsV.fold')
            if(icnR.ne.430)call wELCdata(Ndatamax,NdataR,xdataR,resR,
     %              errR,'ELCresidualsR.fold')
            if(icnI.ne.430)call wELCdata(Ndatamax,NdataI,xdataI,resI,
     %              errI,'ELCresidualsI.fold')
            if(icnJ.ne.430)call wELCdata(Ndatamax,NdataJ,xdataJ,resJ,
     %              errJ,'ELCresidualsJ.fold')
            if(icnH.ne.430)call wELCdata(Ndatamax,NdataH,xdataH,resH,
     %              errH,'ELCresidualsH.fold')
            if(icnK.ne.430)call wELCdata(Ndatamax,NdataK,xdataK,resK,
     %              errK,'ELCresidualsK.fold')
            if(icnRV1.ne.430) call wELCdata(Ndatamax,NRV1,xRV1,resRV1,
     %              errRV1,'ELCresidualsRV1.fold')
            if(icnRV2.ne.430) call wELCdata(Ndatamax,NRV2,xRV2,resRV2,
     %              errRV2,'ELCresidualsRV2.fold')
            if(icnRV3.ne.430) call wELCdata(Ndatamax,NRV3,xRV3,resRV3,
     %              errRV3,'ELCresidualsRV3.fold')
c
c   Reset the variables at their best values.
c
          do mmm=1,Nvmax
            var(mmm)=sss(mmm)
          enddo
c
 750      continue  ! loop over grid searches
c
          continue                  ! come here when delta chi is small
c
c   reset the variables at their best values and print the chi^2
c
          do mmm=1,Nvmax
            var(mmm)=sss(mmm)
          enddo
c
 69       ibest=0
          ichilabel=1
          call monster(Nphase,Nmaxphase,xmod,ymodU,ymodB,ymodV,
     @       ymodR,ymodI,ymodJ,ymodH,ymodK,ymods1,ymods2,ymods3,
     @       ymodd,RV1,RV2,drv1,drv2,obsparm,ifastflag,NRVphase,
     @       xRVmod,fracs1,fracs2,fracs3,fracs4,fracs5,fracs6,
     &       fracs7,fracs8,chisqU,chisqB,chisqV,chisqR,chisqI,
     &       chisqJ,chisqH,chisqK,chisqRV1,chisqRV2,chilimb,chiall,
     @       NdataU,xdataU,ydataU,errU,zeroU,resU,NdataB,xdataB,
     @       ydataB,errB,zeroB,resB,NdataV,xdataV,ydataV,errV,zeroV,
     @       resV,NdataR,xdataR,ydataR,errR,zeroR,resR,NdataI,
     @       xdataI,ydataI,errI,zeroI,resI,NdataJ,xdataJ,ydataJ,
     @       errJ,zeroJ,resJ,NdataH,xdataH,ydataH,errH,zeroH,resH,
     @       NdataK,xdataK,ydataK,errK,zeroK,resK,NRV1,xRV1,yRV1,
     @       errRV1,NRV2,xRV2,yRV2,errRV2,ggamma1,ggamma2,Nobv,sobv,
     @       obv,eobv,ochi,ochidisk,ochilr,Nvmax,svar,var,saveasini,
     @       savxdataU,savydataU,saverrU,savxdataB,savydataB,
     @       saverrB,savxdataV,savydataV,saverrV,savxdataR,
     @       savydataR,saverrR,savxdataI,savydataI,saverrI,
     @       savxdataJ,savydataJ,saverrJ,savxdataH,savydataH,
     @       saverrH,savxdataK,savydataK,saverrK,savxRV1,savyRV1,
     @       saverrRV1,savxRV2,savyRV2,saverrRV2,ifrac,ilum,i16,
     @       isavNU,isavNB,isavNV,isavNR,isavNI,isavNJ,isavNH,
     @       isavNK,isavRV1,isavRV2,isvel1,isvel2,Ndatamax,ibest,
     @       ifixgamma,savesep,ichilabel,resRV1,resRV2,thresh,
     @       small,Ncycle,Ttimes,Tseps,Nobscycle,obsTtimes,obsTerr,
     &       icnarray,RV3,xRV3,yRV3,errRV3,icnRV3,resRV3,ggamma3,NRV3,
     @    parmstring,planetparm,dynparm,line,fill1,fill2,omega1,
     @    omega2,dphase,Q,finc,Teff1,Teff2,Tgrav1,Tgrav2,betarim,
     @    rinner,router,tdisk,xi,alb1,alb2,rLx,Period,fm,separ,
     @    gamma,wave,dbolx,dboly,dwavex,dwavey,t3,g3,SA3,density,
     @    sw1,sw2,sw3,T0,ecc,argper,pshift,sw5,sw6,sw7,sw8,sw9,
     @    primmass,primK,primrad,ratrad,frac1,frac2,ecosw,temprat,
     @    bigI,bigbeta,sw23,sw24,powercoeff,sw25,sw26,sw27,sw28,
     @    sw29,sw30,contam,Tconj,beam1,beam2,ocose,osine,omegadot,
     @    contamS0,contamS1,contamS2,contamS3,sw47,sw48,sw49,gaplow,
     @    gaphigh,P2tconj,P2period,P2T0,P2ecos,P2esin,P2incl,P2Omega,
     @    P2Q,P2ratrad,P3tconj,P3period,P3T0,P3ecos,P3esin,P3incl,
     @    P3Omega,P3Q,P3ratrad,P4tconj,P4period,P4T0,P4ecos,P4esin,
     @    P4incl,P4Omega,P4Q,P4ratrad,P5tconj,P5period,P5T0,P5ecos,
     @    P5esin,P5incl,P5Omega,P5Q,P5ratrad,P6tconj,P6period,P6T0,
     @    P6ecos,P6esin,P6incl,P6Omega,P6Q,P6ratrad,P7tconj,P7period,
     @    P7T0,P7ecos,P7esin,P7incl,P7Omega,P7Q,P7ratrad,P8tconj,
     @    P8period,P8T0,P8ecos,P8esin,P8incl,P8Omega,P8Q,P8ratrad,
     @    xSC,ySC,spot1parm,spot2parm,spotdparm,Nalph1,Nbet1,Nalph2,
     @    Nbet2,Ntheta,Nradius,Nref,idraw,iecheck,iidint,iatm,ism1,
     @    ilaw,icnU,icnB,icnV,icnR,icnI,icnJ,icnH,icnK,icnRV1,icnRV2,
     @    iRVfilt,isw1,isw2,isw3,isw4,ikeep,isynch,isw5,isw6,isw7,
     @    isw8,isw9,idark1,idark2,isw12,isw13,isw21,isw22,isw23,isw24,
     @    isw25,isw26,isw27,isw28,isw29,isw30,isw31,isw32,isw33,isw34,
     @    NSC,compfracs,tertperiod,tertt0,tertecos,tertesin,
     @    tertincl,tertOmega,tertQ,tertconj,tertratrad,hh,sw72,sw73,
     @    Nmaxeclipse,Tdur1,Tdur2)
c
          call printgriditer(i16+1,'model number = ',ijk,
     @        'iteration number = ',svar(i7),isw29)
c
          write(*,*)' '
          do 3749 iq=1,Nvar      !Nterms
            write(*,1001)var(iq),sigvar(iq),svar(iq)(1:15)
 3749     continue
c
          call printS(chiall)
c
          i16=i16+1

          if((isw30.ge.3).and.(isw23.ge.1))then
            call writeeclipse(Ncycle,Ttimes,Tseps,isw30,Nmaxeclipse,
     @           Tdur1,Tdur2)
          endif
c
          if(icnU.ne.430)call wlinmod(Nphase,xmod,ymodU,'modelU.linear',
     @       isw7)
          if(icnB.ne.430)call wlinmod(Nphase,xmod,ymodB,'modelB.linear',
     @       isw7)
          if(icnV.ne.430)call wlinmod(Nphase,xmod,ymodV,'modelV.linear',
     @       isw7)
          if(icnR.ne.430)call wlinmod(Nphase,xmod,ymodR,'modelR.linear',
     @       isw7)
          if(icnI.ne.430)call wlinmod(Nphase,xmod,ymodI,'modelI.linear',
     @       isw7)
          if(icnJ.ne.430)call wlinmod(Nphase,xmod,ymodJ,'modelJ.linear',
     @       isw7)
          if(icnH.ne.430)call wlinmod(Nphase,xmod,ymodH,'modelH.linear',
     @       isw7)
          if(icnK.ne.430)call wlinmod(Nphase,xmod,ymodK,'modelK.linear',
     @       isw7)
c
          if(icnU.ne.430)call wmagmod(Nphase,xmod,ymodU,'modelU.mag',
     @       isw7,zeroU)
          if(icnB.ne.430)call wmagmod(Nphase,xmod,ymodB,'modelB.mag',
     @       isw7,zeroB)
          if(icnV.ne.430)call wmagmod(Nphase,xmod,ymodV,'modelV.mag',
     @       isw7,zeroV)
          if(icnR.ne.430)call wmagmod(Nphase,xmod,ymodR,'modelR.mag',
     @       isw7,zeroR)
          if(icnI.ne.430)call wmagmod(Nphase,xmod,ymodI,'modelI.mag',
     @       isw7,zeroI)
          if(icnJ.ne.430)call wmagmod(Nphase,xmod,ymodJ,'modelJ.mag',
     @       isw7,zeroJ)
          if(icnH.ne.430)call wmagmod(Nphase,xmod,ymodH,'modelH.mag',
     @       isw7,zeroH)
          if(icnK.ne.430)call wmagmod(Nphase,xmod,ymodK,'modelK.mag',
     @       isw7,zeroK)
c
          call wlinmod(Nphase,xmod,ymods1,'lcstar1.linear',isw7)
          call wlinmod(Nphase,xmod,ymods2,'lcstar2.linear',isw7)
          call wlinmod(Nphase,xmod,ymods3,'lcstar3.linear',isw7)
          if(iidint.ge.1)call wlinmod(Nphase,xmod,ymodd,'lcdisk.linear',
     @       isw7)
c
          call wRVmod(NRVphase,xRVmod,RV1,'star1.RV',isw7,ggamma1)
          call wRVmod(NRVphase,xRVmod,RV2,'star2.RV',isw7,ggamma2)
          if(isw30.ge.3)call wRVmod(NRVphase,xRVmod,RV3,'star3.RV',
     @          isw7,ggamma1)
c
          if(itime.gt.0)then
            if(icnU.ne.430)call wELCdata(Ndatamax,NdataU,xdataU,ydataU,
     %              errU,'ELCdataU.fold')
            if(icnB.ne.430)call wELCdata(Ndatamax,NdataB,xdataB,ydataB,
     %              errB,'ELCdataB.fold')
            if(icnV.ne.430)call wELCdata(Ndatamax,NdataV,xdataV,ydataV,
     %              errV,'ELCdataV.fold')
            if(icnR.ne.430)call wELCdata(Ndatamax,NdataR,xdataR,ydataR,
     %              errR,'ELCdataR.fold')
            if(icnI.ne.430)call wELCdata(Ndatamax,NdataI,xdataI,ydataI,
     %              errI,'ELCdataI.fold')
            if(icnJ.ne.430)call wELCdata(Ndatamax,NdataJ,xdataJ,ydataJ,
     %              errJ,'ELCdataJ.fold')
            if(icnH.ne.430) call wELCdata(Ndatamax,NdataH,xdataH,ydataH,
     %              errH,'ELCdataH.fold')
            if(icnK.ne.430)call wELCdata(Ndatamax,NdataK,xdataK,ydataK,
     %              errK,'ELCdataK.fold')
            if(icnRV1.ne.430) call wELCdata(Ndatamax,NRV1,xRV1,yRV1,
     %              errRV1,'ELCdataRV1.fold')
            if(icnRV2.ne.430) call wELCdata(Ndatamax,NRV2,xRV2,yRV2,
     %              errRV2,'ELCdataRV2.fold')
            if(icnRV3.ne.430) call wELCdata(Ndatamax,NRV3,xRV3,yRV3,
     %              errRV3,'ELCdataRV3.fold')
          endif
c
          if(icnU.ne.430)call wELCdata(Ndatamax,NdataU,xdataU,resU,
     %            errU,'ELCresidualsU.fold')
          if(icnB.ne.430)call wELCdata(Ndatamax,NdataB,xdataB,resB,
     %            errB,'ELCresidualsB.fold')
          if(icnV.ne.430)call wELCdata(Ndatamax,NdataV,xdataV,resV,
     %            errV,'ELCresidualsV.fold')
          if(icnR.ne.430)call wELCdata(Ndatamax,NdataR,xdataR,resR,
     %            errR,'ELCresidualsR.fold')
          if(icnI.ne.430)call wELCdata(Ndatamax,NdataI,xdataI,resI,
     %            errI,'ELCresidualsI.fold')
          if(icnJ.ne.430)call wELCdata(Ndatamax,NdataJ,xdataJ,resJ,
     %            errJ,'ELCresidualsJ.fold')
          if(icnH.ne.430)call wELCdata(Ndatamax,NdataH,xdataH,resH,
     %            errH,'ELCresidualsH.fold')
          if(icnK.ne.430)call wELCdata(Ndatamax,NdataK,xdataK,resK,
     %            errK,'ELCresidualsK.fold')
          if(icnRV1.ne.430) call wELCdata(Ndatamax,NRV1,xRV1,resRV1,
     %            errRV1,'ELCresidualsRV1.fold')
          if(icnRV2.ne.430) call wELCdata(Ndatamax,NRV2,xRV2,resRV2,
     %              errRV2,'ELCresidualsRV2.fold')
          if(icnRV3.ne.430) call wELCdata(Ndatamax,NRV3,xRV3,resRV3,
     %              errRV3,'ELCresidualsRV3.fold')
c
c   Finally, make a file similar to ELC.inp with the current parameters.
c
          call writegridout(Nalph1,Nbet1,Nalph2,Nbet2,fill1,fill2,
     @      omega1,omega2,dphase,Q,finc,Teff1,Teff2,Tgrav1,Tgrav2,
     %      betarim,rinner,router,tdisk,xi,Ntheta,Nradius,alb1,alb2,
     &      Nref,rLx,Period,fm,separ,gamma1,t3,g3,SA3,density,sw1,sw2,
     @      sw3,T0,idraw,iecheck,iidint,iatm,ism1,icnU,icnB,icnV,icnR,
     &      icnI,icnJ,icnH,icnK,iRVfilt,isw1,isw2,isw3,isw4,ilaw,wave,
     @      dbolx,dboly,dwavex,dwavey,ecc,argper,pshift,sw5,sw6,sw7,
     @      sw8,sw9,ikeep,isynch,isw5,isw6,isw7,isw8,isw9,spot1parm,
     @      spot2parm,spotdparm,primmass,primK,primrad,ratrad,frac1,
     @      frac2,ecosw,temprat,idark1,idark2,isw12,isw13,isw21,isw22,
     @      isw23,isw24,bigI,bigbeta,sw23,sw24,powercoeff,sw25,sw26,
     @      sw27,sw28,sw29,sw30,contam,Tconj,beam1,beam2,isw25,isw26,
     @      isw27,isw28,isw29,isw30,isw31,isw32,isw33,isw34,ocose,osine,
     @      omegadot,contamS0,contamS1,contamS2,contamS3,sw47,sw48,sw49)
c
          if(isw30.gt.0)call writebody3grid(Nalph3,Nbet3,tertperiod,
     @       tertt0,tertecos,tertesin,tertincl,tertOmega,tertQ,dwavex,
     @       dwavey,itconj,it1,it2,it3,it4,tertconj,tertratrad,hh,sw72,
     @       sw73,
     @         P2tconj,P2period,P2T0,P2ecos,P2esin,P2incl,P2Omega,P2Q,
     @         P2ratrad,
     @         P3tconj,P3period,P3T0,P3ecos,P3esin,P3incl,P3Omega,P3Q,
     @         P3ratrad,
     @         P4tconj,P4period,P4T0,P4ecos,P4esin,P4incl,P4Omega,P4Q,
     @         P4ratrad,
     @         P5tconj,P5period,P5T0,P5ecos,P5esin,P5incl,P5Omega,P5Q,
     @         P5ratrad,
     @         P6tconj,P6period,P6T0,P6ecos,P6esin,P6incl,P6Omega,P6Q,
     @         P6ratrad,
     @         P7tconj,P7period,P7T0,P7ecos,P7esin,P7incl,P7Omega,P7Q,
     @         P7ratrad,
     @         P8tconj,P8period,P8T0,P8ecos,P8esin,P8incl,P8Omega,P8Q,
     @         P8ratrad)
c
          call recordloopopt(Udatafile,Bdatafile,Vdatafile,Rdatafile,
     $      Idatafile,Jdatafile,Hdatafile,Kdatafile,RV1file,RV2file,
     $      Nvmax,Nvar,svar,var,vstart,stepsave,Nstep,Nobv,sobv,obv,
     @      eobv,vstep)
c
 1001     format(1x,2(f15.7,2x),a15)

          close(45)
          close(46)
          if(isw24.gt.0)close(47)
          if(isw30.gt.0)close(48)
          if(isw30.ge.3)close(49)

          end
c
c   &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
c
          include 'lcsubs.for'
          include 'optimizesubs.for'
          include 'dynamicssubs.for'


      SUBROUTINE DFPSAV(TOTIME,XPARAM,GD,XLAST,FUNCT1,MDFP,XDFP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INCLUDE 'SIZES'
      DIMENSION XPARAM(*), GD(*), XLAST(*), MDFP(9),XDFP(9)
**********************************************************************
*
* DFPSAV STORES AND RESTORES DATA USED IN THE D-F-P GEOMETRY
*        OPTIMISATION.
*
*  ON INPUT TOTIME = TOTAL CPU TIME ELAPSED DURING THE CALCULATION.
*           XPARAM = CURRENT VALUE OF PARAMETERS.
*           GD     = OLD GRADIENT.
*           XLAST  = OLD VALUE OF PARAMETERS.
*           FUNCT1 = CURRENT VALUE OF HEAT OF FORMATION.
*           MDFP   = INTEGER CONSTANTS USED IN D-F-P.
*           XDFP   = REAL CONSTANTS USED IN D-F-P.
*           MDFP(9)= 1 FOR DUMP, 0 FOR RESTORE.
**********************************************************************
      COMMON /KEYWRD/ KEYWRD
      COMMON /TITLES/ KOMENT,TITLE
      COMMON /GRADNT/ GRAD(MAXPAR),GNORM
      COMMON /GEOVAR/ NVAR,LOC(2,MAXPAR), IDUMY, DUMY(MAXPAR)
      COMMON /DENSTY/ P(MPACK), PA(MPACK), PB(MPACK)
      COMMON /ALPARM/ ALPARM(3,MAXPAR),X0, X1, X2, ILOOP
      COMMON /REACTN/ STEP, GEOA(3,NUMATM), GEOVEC(3,NUMATM),CALCST
      COMMON /GEOM  / GEO(3,NUMATM)
      COMMON /GEOKST/ NATOMS,LABELS(NUMATM),
     1                NA(NUMATM),NB(NUMATM),NC(NUMATM)
      COMMON /ELEMTS/ ELEMNT(107)
      COMMON /PATH  / LATOM,LPARAM,REACT(200)
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM),
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA,
     2                NCLOSE,NOPEN,NDUMY,FRACT
      COMMON /FMATRX/ HESINV(MAXHES)
      COMMON /GEOSYM/ NDEP,LOCPAR(MAXPAR),IDEPFN(MAXPAR),
     1                     LOCDEP(MAXPAR)
      COMMON /ERRFN / ERRFN(MAXPAR)
      DIMENSION IEL1(3),Q(3), COORD(3,NUMATM)
      CHARACTER ELEMNT*2, KEYWRD*80,KOMENT*80, TITLE*80
      LOGICAL FIRST, INTXYZ
      DATA FIRST /.TRUE./
      OPEN(UNIT=9,FILE='FOR009',STATUS='UNKNOWN',FORM='UNFORMATTED')
      REWIND 9
      OPEN(UNIT=10,FILE='FOR010',STATUS='UNKNOWN',FORM='UNFORMATTED')
      REWIND 10
      DEGREE=57.29577951D0
      IR=9
      IF(MDFP(9) .NE. 0) THEN
         IF(MDFP(9) .EQ. 1) THEN
            WRITE(6,'(//10X,''- - - - - - - TIME UP - - - - - - -'',//)'
     1)
            IF(INDEX(KEYWRD,'SADDLE') .NE. 0) THEN
               WRITE(6,'(//10X,'' NO RESTART EXISTS FOR SADDLE'',//
     1  10X,'' HERE IS A DATA-FILE FILES THAT MIGHT BE SUITABLE'',/
     2  10X,'' FOR RESTARTING THE CALCULATION'',///)')
               WRITE(6,'(A)')KEYWRD,KOMENT,TITLE
               INTXYZ=(NA(1).EQ.0)
               DO 60 ILOOP=1,2
                  IF(INTXYZ)THEN
                     GEO(2,1)=0.D0
                     GEO(3,1)=0.D0
                     GEO(1,1)=0.D0
                     GEO(2,2)=0.D0
                     GEO(3,2)=0.D0
                     GEO(3,3)=0.D0
                     DO 10 I=1,NATOMS
                        DO 10 J=1,3
   10                COORD(J,I)=GEO(J,I)
                  ELSE
                     CALL XYZINT(GEO,NUMAT,NA,NB,NC,1.D0,COORD)
                  ENDIF
                  IVAR=1
                  NA(1)=0
                  DO 40 I=1,NATOMS
                     DO 20 J=1,3
   20                IEL1(J)=0
   30                CONTINUE
                     IF(LOC(1,IVAR).EQ.I) THEN
                        IEL1(LOC(2,IVAR))=1
                        IVAR=IVAR+1
                        GOTO 30
                     ENDIF
                     IF(I.LT.4) THEN
                        IEL1(3)=0
                        IF(I.LT.3) THEN
                           IEL1(2)=0
                           IF(I.LT.2) THEN
                              IEL1(1)=0
                           ENDIF
                        ENDIF
                     ENDIF
                     IF(I.EQ.LATOM)IEL1(LPARAM)=-1
                     Q(1)=COORD(1,I)
                     Q(2)=COORD(2,I)*DEGREE
                     Q(3)=COORD(3,I)*DEGREE
   40             WRITE(6,'(2X,A2,3(F12.6,I3),I4,2I3)')
     1    ELEMNT(LABELS(I)),(Q(K),IEL1(K),K=1,3),NA(I),NB(I),NC(I)
                  I=0
                  X=0.D0
                  WRITE(6,'(I4,3(F12.6,I3),I4,2I3)')
     1    I,X,I,X,I,X,I,I,I,I
                  DO 50 I=1,NATOMS
                     DO 50 J=1,3
   50             GEO(J,I)=GEOA(J,I)
                  NA(1)=99
   60          CONTINUE
               WRITE(6,'(///10X,''CALCULATION TERMINATED HERE'')')
               STOP
            ENDIF
            WRITE(6,'(//10X,'' - THE CALCULATION IS BEING DUMPED TO DISK
     1'',  /10X,''   RESTART IT USING THE MAGIC WORD "RESTART"'')')
            WRITE(6,'(//10X,''CURRENT VALUE OF HEAT OF FORMATION =''
     1  ,F12.6)')FUNCT1
         ENDIF
         IF(MDFP(9) .EQ. 1)THEN
            IF(NA(1) .EQ. 99) THEN
C
C  CONVERT FROM CARTESIAN COORDINATES TO INTERNAL
C
               DO 70 I=1,NATOMS
                  DO 70 J=1,3
   70          COORD(J,I)=GEO(J,I)
               CALL XYZINT(COORD,NUMAT,NA,NB,NC,1.D0,GEO)
            ENDIF
            GEO(2,1)=0.D0
            GEO(3,1)=0.D0
            GEO(1,1)=0.D0
            GEO(2,2)=0.D0
            GEO(3,2)=0.D0
            GEO(3,3)=0.D0
            IVAR=1
            NA(1)=0
            WRITE(6,'(A)')KEYWRD,KOMENT,TITLE
            DO 100 I=1,NATOMS
               DO 80 J=1,3
   80          IEL1(J)=0
   90          CONTINUE
               IF(LOC(1,IVAR).EQ.I) THEN
                  IEL1(LOC(2,IVAR))=1
                  IVAR=IVAR+1
                  GOTO 90
               ENDIF
               IF(I.LT.4) THEN
                  IEL1(3)=0
                  IF(I.LT.3) THEN
                     IEL1(2)=0
                     IF(I.LT.2) THEN
                        IEL1(1)=0
                     ENDIF
                  ENDIF
               ENDIF
               IF(I.EQ.LATOM)IEL1(LPARAM)=-1
               Q(1)=GEO(1,I)
               Q(2)=GEO(2,I)*DEGREE
               Q(3)=GEO(3,I)*DEGREE
  100       WRITE(6,'(2X,A2,3(F12.6,I3),I4,2I3)')
     1ELEMNT(LABELS(I)),(Q(K),IEL1(K),K=1,3),NA(I),NB(I),NC(I)
            I=0
            X=0.D0
            WRITE(6,'(I4,3(F12.6,I3),I4,2I3)')
     1I,X,I,X,I,X,I,I,I,I
            IF(NDEP.NE.0)THEN
               DO 110 I=1,NDEP
  110          WRITE(6,'(3(I4,'',''))')LOCPAR(I),IDEPFN(I),LOCDEP(I)
               WRITE(6,*)
            ENDIF
         ENDIF
         WRITE(IR)MDFP,XDFP,TOTIME,FUNCT1
         WRITE(IR)(XPARAM(I),I=1,NVAR),(GD(I),I=1,NVAR)
         WRITE(IR)(XLAST(I),I=1,NVAR),(GRAD(I),I=1,NVAR)
         LINEAR=(NVAR*(NVAR+1))/2
         WRITE(IR)(HESINV(I),I=1,LINEAR)
         LINEAR=(NORBS*(NORBS+1))/2
         WRITE(10)(PA(I),I=1,LINEAR)
         IF(NALPHA.NE.0)WRITE(10)(PB(I),I=1,LINEAR)
         IF(LATOM .NE. 0) THEN
            WRITE(IR)((ALPARM(J,I),J=1,3),I=1,NVAR)
            WRITE(IR)ILOOP,X0, X1, X2
         ENDIF
         WRITE(IR)(ERRFN(I),I=1,NVAR)
         CLOSE (9)
         CLOSE (10)
      ELSE
         IF (FIRST) WRITE(6,'(//10X,'' RESTORING DATA FROM DISK''/)')
         READ(IR,END=130,ERR=130)MDFP,XDFP,TOTIME,FUNCT1
         IF (FIRST) WRITE(6,'(10X,''FUNCTION ='',F13.6//)')FUNCT1
         READ(IR)(XPARAM(I),I=1,NVAR),(GD(I),I=1,NVAR)
         READ(IR)(XLAST(I),I=1,NVAR),(GRAD(I),I=1,NVAR)
         LINEAR=(NVAR*(NVAR+1))/2
         READ(IR)(HESINV(I),I=1,LINEAR)
         LINEAR=(NORBS*(NORBS+1))/2
         READ(10)(PA(I),I=1,LINEAR)
         IF(NALPHA.NE.0)READ(10)(PB(I),I=1,LINEAR)
         IF(LATOM.NE.0) THEN
            READ(IR)((ALPARM(J,I),J=1,3),I=1,NVAR)
            READ(IR)ILOOP,X0, X1, X2
         ENDIF
         READ(IR)(ERRFN(I),I=1,NVAR)
  120    FIRST=.FALSE.
         RETURN
  130    WRITE(6,'(//10X,''NO RESTART FILE EXISTS!'')')
         STOP
      ENDIF
      END


      BLOCK DATA
C
C     BLK8
C
C     TITLE DATA FOR PLOT HEADINGS
C
      COMPLEX*16 OPT2,TITLE
C
      COMMON/PLTHED/ OPT2(10),TITLE(450)
C
      COMPLEX*16 OPT1(10)
     * /'PSI1            ','THET1           ','PHI1            ',
     *  'OMEG1           ','OMEG2           ','OMEG3           ',
     * 'PHILD           ','NUTAT. ANGLE    ','EPSERR          ',
     * '                '/
C
      DATA OPT2
     * /'ALFAE           ','BETAE           ','GAMAE           ',
     *  'OMBC1           ','OMBC2           ','OMBC3           ',
     *  'PHILD           ','ROLL RATE       ','PITCH RATE      ',
     *  'YAW RATE        '/
C
      COMPLEX*16 FL11(6)
     * /'DISPL 1-2 PLANE ','RATE 1-2 PLANE  ','DISPL 1-3 PLANE ',
     *  'RATE 1-3 PLANE  ','TWIST 1 AXIS    ','RATE 1 AXIS     '/
      COMPLEX*16 FL12(6)
     * /'DISPL 1-2 PLANE ','RATE 1-2 PLANE  ','DISPL 1-3 PLANE ',
     *  'RATE 1-3 PLANE  ','TWIST 1 AXIS    ','RATE 1 AXIS     '/
      COMPLEX*16 FL13(6)
     * /'DISPL 1-2 PLANE ','RATE 1-2 PLANE  ','DISPL 1-3 PLANE ',
     *  'RATE 1-3 PLANE  ','TWIST 1 AXIS    ','RATE 1 AXIS     '/
      COMPLEX*16 FL14(6)
     * /'DISPL 1-2 PLANE ','RATE 1-2 PLANE  ','DISPL 1-3 PLANE ',
     *  'RATE 1-3 PLANE  ','TWIST 1 AXIS    ','RATE 1 AXIS     '/
      COMPLEX*16 FL15(6)
     * /'DISPL 1-2 PLANE ','RATE 1-2 PLANE  ','DISPL 1-3 PLANE ',
     *  'RATE 1-3 PLANE  ','TWIST 1 AXIS    ','RATE 1 AXIS     '/
      COMPLEX*16 FL16(6)
     * /'DISPL 1-2 PLANE ','RATE 1-2 PLANE  ','DISPL 1-3 PLANE ',
     *  'RATE 1-3 PLANE  ','TWIST 1 AXIS    ','RATE 1 AXIS     '/
      COMPLEX*16 FL17(6)
     * /'DISPL 1-2 PLANE ','RATE 1-2 PLANE  ','DISPL 1-3 PLANE ',
     *  'RATE 1-3 PLANE  ','TWIST 1 AXIS    ','RATE 1 AXIS     '/
      COMPLEX*16 FL18(6)
     * /'DISPL 1-2 PLANE ','RATE 1-2 PLANE  ','DISPL 1-3 PLANE ',
     *  'RATE 1-3 PLANE  ','TWIST 1 AXIS    ','RATE 1 AXIS     '/
      COMPLEX*16 FL19(6)
     * /'DISPL 1-2 PLANE ','RATE 1-2 PLANE  ','DISPL 1-3 PLANE ',
     *  'RATE 1-3 PLANE  ','TWIST 1 AXIS    ','RATE 1 AXIS     '/
      COMPLEX*16 FL20(6)
     * /'DISPL 1-2 PLANE ','RATE 1-2 PLANE  ','DISPL 1-3 PLANE ',
     *  'RATE 1-3 PLANE  ','TWIST 1 AXIS    ','RATE 1 AXIS     '/
C
      COMPLEX*16 DM11(6)
     * /'DISPL 1-2 PLANE ','RATE 1-2 PLANE  ','DISPL 1-3 PLANE ',
     *  'RATE 1-3 PLANE  ','TWIST 1 AXIS    ','RATE 1 AXIS     '/
      COMPLEX*16 DM12(6)
     * /'DISPL 1-2 PLANE ','RATE 1-2 PLANE  ','DISPL 1-3 PLANE ',
     *  'RATE 1-3 PLANE  ','TWIST 1 AXIS    ','RATE 1 AXIS     '/
      COMPLEX*16 DM13(6)
     * /'DISPL 1-2 PLANE ','RATE 1-2 PLANE  ','DISPL 1-3 PLANE ',
     *  'RATE 1-3 PLANE  ','TWIST 1 AXIS    ','RATE 1 AXIS     '/
      COMPLEX*16 DM14(6)
     * /'DISPL 1-2 PLANE ','RATE 1-2 PLANE  ','DISPL 1-3 PLANE ',
     *  'RATE 1-3 PLANE  ','TWIST 1 AXIS    ','RATE 1 AXIS     '/
      COMPLEX*16 DM15(6)
     * /'DISPL 1-2 PLANE ','RATE 1-2 PLANE  ','DISPL 1-3 PLANE ',
     *  'RATE 1-3 PLANE  ','TWIST 1 AXIS    ','RATE 1 AXIS     '/
      COMPLEX*16 DM16(6)
     * /'DISPL 1-2 PLANE ','RATE 1-2 PLANE  ','DISPL 1-3 PLANE ',
     *  'RATE 1-3 PLANE  ','TWIST 1 AXIS    ','RATE 1 AXIS     '/
      COMPLEX*16 DM17(6)
     * /'DISPL 1-2 PLANE ','RATE 1-2 PLANE  ','DISPL 1-3 PLANE ',
     *  'RATE 1-3 PLANE  ','TWIST 1 AXIS    ','RATE 1 AXIS     '/
      COMPLEX*16 DM18(6)
     * /'DISPL 1-2 PLANE ','RATE 1-2 PLANE  ','DISPL 1-3 PLANE ',
     *  'RATE 1-3 PLANE  ','TWIST 1 AXIS    ','RATE 1 AXIS     '/
      COMPLEX*16 DM19(6)
     * /'DISPL 1-2 PLANE ','RATE 1-2 PLANE  ','DISPL 1-3 PLANE ',
     *  'RATE 1-3 PLANE  ','TWIST 1 AXIS    ','RATE 1 AXIS     '/
      COMPLEX*16 DM20(6)
     * /'DISPL 1-2 PLANE ','RATE 1-2 PLANE  ','DISPL 1-3 PLANE ',
     *  'RATE 1-3 PLANE  ','TWIST 1 AXIS    ','RATE 1 AXIS     '/
C
      COMPLEX*16 FEMOD(9)
     * /'MODE1 1-2 PLANE ','MODE1 1-3 PLANE ',
     *  'MODE2 1-2 PLANE ','MODE2 1-3 PLANE ',
     *  'MODE3 1-2 PLANE ','MODE3 1-3 PLANE ',
     *  'MODE1 TWIST     ','MODE2 TWIST     ','MODE3 TWIST     '/
      COMPLEX*16 DEMOD(9)
     * /'MODE1 1-2 PLANE ','MODE1 1-3 PLANE ',
     *  'MODE2 1-2 PLANE ','MODE2 1-3 PLANE ',
     *  'MODE3 1-2 PLANE ','MODE3 1-3 PLANE ',
     *  'MODE1 TWIST     ','MODE2 TWIST     ','MODE3 TWIST     '/
C
      COMPLEX*16 GAREAD(6)
     * /'ACC. READING  1 ','ACC. READING  2 ','ACC. READING  3 ',
     *  'ACC. READING  4 ','ACC. READING  5 ','ACC. READING  6 '/
C
      COMPLEX*16 BDYINT(3)
     * /'BODY    IXX     ','BODY    IYY     ','BODY    IZZ     '/
      COMPLEX*16 HMMNTM(3)
     * /'RT.ASCENSION-HI ','DECLINATION-HI  ','MAGNITUDE OF HI '/
C
      COMPLEX*16 RTTNSN(10)
     * /'ROOT TENSION  1 ','ROOT TENSION  2 ','ROOT TENSION  3 ',
     *  'ROOT TENSION  4 ','ROOT TENSION  5 ','ROOT TENSION  6 ',
     *  'ROOT TENSION  7 ','ROOT TENSION  8 ','ROOT TENSION  9 ',
     *  'ROOT TENSION  10'/
C
      COMPLEX*16 RTBNDM(20)
     *   /'1-2 PLANE BNDM 1','1-3 PLANE BNDM 1',
     *    '1-2 PLANE BNDM 2','1-3 PLANE BNDM 2',
     *    '1-2 PLANE BNDM 3','1-3 PLANE BNDM 3',
     *    '1-2 PLANE BNDM 4','1-3 PLANE BNDM 4',
     *    '1-2 PLANE BNDM 5','1-3 PLANE BNDM 5',
     *    '1-2 PLANE BNDM 6','1-3 PLANE BNDM 6',
     *    '1-2 PLANE BNDM 7','1-3 PLANE BNDM 7',
     *    '1-2 PLANE BNDM 8','1-3 PLANE BNDM 8',
     *    '1-2 PLANE BNDM 9','1-3 PLANE BNDM 9',
     *    '1-2 PLANE BNDM10','1-3 PLANE BNDM10'/
C
      COMPLEX*16 SANGLS(2)
     *  /'BODY SUN ANG-ALP','BODY SUN ANG-DEC'/
C
      COMPLEX*16 FIELDM(3)
     *  /'MAGNET.VECTOR-B1','MAGNET.VECTOR-B2','MAGNET.VECTOR-B3'/
C
      COMPLEX*16 HHHVAL/'HAMILTONIAN     '/
      COMPLEX*16 BNDMAG(10)
     *   /'MAG. BNDM-ELEM 1',
     *    'MAG. BNDM-ELEM 2',
     *    'MAG. BNDM-ELEM 3',
     *    'MAG. BNDM-ELEM 4',
     *    'MAG. BNDM-ELEM 5',
     *    'MAG. BNDM-ELEM 6',
     *    'MAG. BNDM-ELEM 7',
     *    'MAG. BNDM-ELEM 8',
     *    'MAG. BNDM-ELEM 9',
     *    'MAG. BNDM-ELEM10'/
C
      COMPLEX*16 WHLSPD(3)
     * /'AXIS 1 WHL. SPD.','AXIS 2 WHL. SPD.','AXIS 3 WHL. SPD.'/
C
      COMPLEX*16 EXTMOM(3)
     * /'EXTERNAL MOMENT1','EXTERNAL MOMENT2','EXTERNAL MOMENT3'/
C
      COMPLEX*16 HMBODY(3)
     * /'AXIS 1  MOMENTUM','AXIS 2  MOMENTUM','AXIS 3  MOMENTUM'/
C
      COMPLEX*16 CONSYS(20)
     */'CONT. SYS. INT 1','CONT. SYS. INT 2','CONT. SYS. INT 3',
     * 'CONT. SYS. INT 4','DEB NUTATION ANG','CONT. SYS. INT 6',
     * 'CONT. SYS. INT 7','CONT. SYS. INT 8','CONT. SYS. INT 9',
     * 'CONT. SYS. INT10','CONT. SYS. INT11','CONT. SYS. INT12',
     * 'CONT. SYS. INT13','CONT. SYS. INT14','CONT. SYS. INT15',
     * 'CONT. SYS. INT16','CONT. SYS. INT17','CONT. SYS. INT18',
     * 'CONT. SYS. INT19','CONT. SYS. INT20'/
C
      COMPLEX*16 SBDTIT(9)
     1/'GAMMA SEC. BODY ','ALPHA SEC. BODY ','BETA SEC. BODY  ',
     2 'GAMMAD SEC. BODY','ALPHAD SEC. BODY','BETAD SEC. BODY ',
     3 'OMEGA1 SEC. BODY','OMEGA2 SEC. BODY','OMEGA3 SEC. BODY'/
C
      COMPLEX*16 ACFTIT(3)
     1/'SENSOR OUTPUT   ','FILTER OUTPUT   ','FILTER W-OUTPUT '/
C
      COMPLEX*16 PRODIN(3)
     * /'BODY    IXY     ','BODY    IXZ     ','BODY    IYZ     '/
C
      COMPLEX*16 TSLOPS(40)
     * /'SLOPE 1-2 PLANE ','SLOPE 1-3 PLANE ','SLOPE 1-2 PLANE ',
     *  'SLOPE 1-3 PLANE ','SLOPE 1-2 PLANE ','SLOPE 1-3 PLANE ',
     *  'SLOPE 1-2 PLANE ','SLOPE 1-3 PLANE ','SLOPE 1-2 PLANE ',
     *  'SLOPE 1-3 PLANE ','SLOPE 1-2 PLANE ','SLOPE 1-3 PLANE ',
     *  'SLOPE 1-2 PLANE ','SLOPE 1-3 PLANE ','SLOPE 1-2 PLANE ',
     *  'SLOPE 1-3 PLANE ','SLOPE 1-2 PLANE ','SLOPE 1-3 PLANE ',
     *  'SLOPE 1-2 PLANE ','SLOPE 1-3 PLANE ','SLOPE 1-2 PLANE ',
     *  'SLOPE 1-3 PLANE ','SLOPE 1-2 PLANE ','SLOPE 1-3 PLANE ',
     *  'SLOPE 1-2 PLANE ','SLOPE 1-3 PLANE ','SLOPE 1-2 PLANE ',
     *  'SLOPE 1-3 PLANE ','SLOPE 1-2 PLANE ','SLOPE 1-3 PLANE ',
     *  'SLOPE 1-2 PLANE ','SLOPE 1-3 PLANE ','SLOPE 1-2 PLANE ',
     *  'SLOPE 1-3 PLANE ','SLOPE 1-2 PLANE ','SLOPE 1-3 PLANE ',
     *  'SLOPE 1-2 PLANE ','SLOPE 1-3 PLANE ','SLOPE 1-2 PLANE ',
     *  'SLOPE 1-3 PLANE '/
C
      COMPLEX*16 SLPMOD(6)
     *  /'MODE1 1-2 SLOPE ','MODE1 1-3 SLOPE ','MODE2 1-2 SLOPE ',
     *  'MODE2 1-3 SLOPE ','MODE3 1-2 SLOPE ','MODE3 1-3 SLOPE '/
C
      COMPLEX*16 GIMBLE(4)
     * /'GIMBLE AZIMUTH  ','GIMBLE AZIM RATE','GIMBLE ELEVATION',
     *  'GIMBLE ELEV RATE'/
C
      COMPLEX*16 DIMBLE(4)
     * /'GIMBLE AZIMUTH  ','GIMBLE AZIM RATE','GIMBLE ELEVATION',
     *  'GIMBLE ELEV RATE'/
C
      COMPLEX*16 PLATCS(9)
     * /'FILTER MAG 1    ','FILTER MAG 2    ','FILTER MAG 3    ',
     *  'AZIMUTH ERROR   ','ELEVATION ERROR ','AZIM P I D OUTPT',
     *  'ELEV P I D OUTPT','AZIM MOTOR TRQUE','ELEV MOTOR TRQUE'/
C
      COMPLEX*16 DLATCS(9)
     * /'FILTER MAG 1    ','FILTER MAG 2    ','FILTER MAG 3    ',
     *  'AZIMUTH ERROR   ','ELEVATION ERROR ','AZIM P I D OUTPT',
     *  'ELEV P I D OUTPT','AZIM MOTOR TRQUE','ELEV MOTOR TRQUE'/
C
      COMPLEX*16 ELTEMP(10)
     *   /'AVG. TEMP-ELEM 1',
     *    'AVG. TEMP-ELEM 2',
     *    'AVG. TEMP-ELEM 3',
     *    'AVG. TEMP-ELEM 4',
     *    'AVG. TEMP-ELEM 5',
     *    'AVG. TEMP-ELEM 6',
     *    'AVG. TEMP-ELEM 7',
     *    'AVG. TEMP-ELEM 8',
     *    'AVG. TEMP-ELEM 9',
     *    'AVG. TEMP-ELEM10'/
C
      COMPLEX*16 AWHSPD(3)
     * /'AXIS 1 WHL. SPD.','AXIS 2 WHL. SPD.','AXIS 3 WHL. SPD.'/
C
      COMPLEX*16 FILOUT(3)
     * /'AXIS 1  FILT OUT','AXIS 2  FILT OUT','AXIS 3  FILT OUT'/
C
      COMPLEX*16 AILOUT(2)
     * /'ARB AXS FILT OUT','ARB AXS WHL. SPD'/
C
      COMPLEX*16 SPARES(87)
     * /87*'                '/
C
      COMPLEX*16 ENVMOM(9)
     * /'GR. GR. MOMENT 1','GR. GR. MOMENT 2','GR. GR. MOMENT 3',
     *  'SOL PR. MOMENT 1','SOL PR. MOMENT 2','SOL PR. MOMENT 3',
     *  'AIR DR. MOMENT 1','AIR DR. MOMENT 2','AIR DR. MOMENT 3'/
C
      COMPLEX*16 SAGLOT(2)
     * /'SNGL AXS GMB ANG','SNGL AXS GMB RT.'/
C
      COMPLEX*16 SAPLCS(6)
     * /'FILTER VECTOR 1 ','FILTER VECTOR 2 ','FILTER VECTOR 3 ',
     *  'ANGLE ERROR     ','ANGL P I D OUTPT','ANGL MOTOR TRQUE'/
C
      COMPLEX*16 REACTR(6)
     * /'REACTN MOMENT  1','REACTN MOMENT  2','REACTN MOMENT  3',
     *  'MOTOR  TORQUE  1','MOTOR  TORQUE  2','MOTOR  TORQUE  3'/
C
C
      EQUIVALENCE (TITLE(1),OPT1(1))
C
      EQUIVALENCE (TITLE(11),FL11(1)),(TITLE(17),FL12(1))
     * ,(TITLE(23),FL13(1)),(TITLE(29),FL14(1)),(TITLE(35),FL15(1))
     * ,(TITLE(41),FL16(1)),(TITLE(47),FL17(1)),(TITLE(53),FL18(1))
     * ,(TITLE(59),FL19(1)),(TITLE(65),FL20(1))
C
      EQUIVALENCE (TITLE(71),DM11(1)),(TITLE(77),DM12(1))
     * ,(TITLE(83),DM13(1)),(TITLE(89),DM14(1)),(TITLE(95),DM15(1))
     * ,(TITLE(101),DM16(1)),(TITLE(107),DM17(1)),(TITLE(113),DM18(1))
     * ,(TITLE(119),DM19(1)),(TITLE(125),DM20(1))
C
      EQUIVALENCE (TITLE(131),FEMOD(1)),(TITLE(140),DEMOD(1))
     * ,(TITLE(149),GAREAD(1)),(TITLE(155),BDYINT(1))
     * ,(TITLE(158),HMMNTM(1)),(TITLE(161),RTTNSN(1))
     * ,(TITLE(171),RTBNDM(1)),(TITLE(191),SANGLS(1))
     * ,(TITLE(193),FIELDM(1)),(TITLE(196),HHHVAL)
     * ,(TITLE(197),BNDMAG(1))
C
      EQUIVALENCE (TITLE(207),WHLSPD(1))
C
      EQUIVALENCE (TITLE(210),EXTMOM(1)),(TITLE(213),HMBODY(1))
C
      EQUIVALENCE (TITLE(216),CONSYS(1))
C
      EQUIVALENCE (TITLE(236),SBDTIT(1)),(TITLE(245),ACFTIT(1))
C
      EQUIVALENCE (TITLE(248),PRODIN(1))
      EQUIVALENCE (TITLE(251),TSLOPS(1))
      EQUIVALENCE (TITLE(291),SLPMOD(1))
      EQUIVALENCE (TITLE(297),GIMBLE(1))
      EQUIVALENCE (TITLE(301),PLATCS(1))
      EQUIVALENCE (TITLE(310),DIMBLE(1))
      EQUIVALENCE (TITLE(314),DLATCS(1))
      EQUIVALENCE (TITLE(323),FILOUT(1))
      EQUIVALENCE (TITLE(326),AWHSPD(1))
      EQUIVALENCE (TITLE(329),AILOUT(1))
      EQUIVALENCE (TITLE(331),ELTEMP(1))
      EQUIVALENCE (TITLE(341),SAGLOT(1))
      EQUIVALENCE (TITLE(343),SAPLCS(1))
      EQUIVALENCE (TITLE(349),ENVMOM(1))
      EQUIVALENCE (TITLE(358),REACTR(1))
      EQUIVALENCE (TITLE(364),SPARES(1))
C
C
      END


	SUBROUTINE TA_DCOD ( cldt, bufrta_old, bufrta_new,
     +						gemfil, nhours, iret)
C************************************************************************
C* TA_DCOD								*
C*									*
C* This routine decodes bulletins containing TAMDAR BUFR messages      	*
C* received directly from AirDat into GEMPAK sounding format and 	*
C* writes the data into the output sounding file.			*
C*									*
C* TA_DCOD ( CLDT, BUFRTA_OLD, BUFRTA_NEW, GEMFIL, NHOURS, IRET )	*
C*									*
C* Input parameters:							*
C*	CLDT		CHAR*		Date-time from command line	*
C*	BUFRTA_OLD	CHAR*		Old TAMDAR BUFR table file   	*
C*	BUFRTA_NEW	CHAR*		New TAMDAR BUFR table file	*
C*	GEMFIL		CHAR*		Output file name template	*
C*	NHOURS		INTEGER		Max # of hours before run time	*
C*					for creating BUFR output	*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code:			*
C*					  0 = normal return		*
C*									*
C**									*
C* Log:									*
C* C. Caruso Magee/NCEP	07/07 						*
C* C. Caruso Magee/NCEP	10/07  	Add pressure (007004) to input descrpor	*
C*                             	list.					*
C* m.gamazaychikov/SAIC	02/08	Change output stream to sounding format	*
C* m.gamazaychikov/SAIC	07/08	Cleaned up				*
C* T. Piper/SAIC	08/08	Changed '.dummy/' to '.dummy.'		*
C* T. Piper/SAIC	09/08	Completely restructured logic		*
C* T. Piper/SAIC	10/08	Create unique "Observation ID"		*
C* T. Piper/SAIC	12/08	Added capability to process new format	*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'BRIDGE.PRM'
	INCLUDE		'tacmn.cmn'
C*
C*      Number of non-NCEP BUFR tables files.
C*
        PARAMETER       ( NBUFRT = 2 )
C
	PARAMETER	( NACRN=1000, NLV=50, NPARMS=6 )
C
	CHARACTER*(*)	cldt, bufrta_old, bufrta_new, gemfil
C
	CHARACTER	acrn(NACRN)*9, afdate(NACRN, NLV)*13, bbb*8,
     +			bfstyp*8, bufrtf(NBUFRT)*(DCMXLN), buhd*8,
     +			bull*(DCMXBF), bulldt*8, cbf,
     +			cborg*8, cbull*(DCMXBF), cdum*13,
     +                  cimnem(NCIMN)*8, coun(NACRN)*2, cracrn*9,
     +                  dattim*13, filnam*132, newfil*132,
     +			parms(NPARMS)*4, prmfil*72,
     +			rimnem(NRIMN)*8, rundt*12, seqnum*8,
     +			stat(NACRN)*2, sysdt*12
C
        REAL            corn
        REAL            alat(NACRN, NLV), alon(NACRN, NLV),
     +                  datai(NPARMS*NLV), datao(NPARMS*NLV),
     +			flat(NACRN), flon(NACRN),
     +                  poaf(NACRN, NLV),
     +                  wspd(NACRN, NLV), wdir(NACRN, NLV),
     +                  hmdt(NACRN, NLV), tmpk(NACRN, NLV),
     +			hght(NACRN, NLV), pres(NACRN, NLV),
     +                  selv(NACRN)
C
	INTEGER		iacrn(NACRN), iarcft(5), ibull(DCMXBF/4),
     +			irptdt(5), irundt(5), iubfmf(NBUFRT),
     +			iubftf(NBUFRT), nmlev(NACRN), nxdsc(NBUFRT)
C
	LOGICAL         addstn, amatch, bullok, cirflg, datflg,
     +			exist, mrgdat, pkflg, stmflg
C
	EQUIVALENCE	( cbull(1:4), ibull(1) )
C*
C*	Number of expected descriptors within Section 3 of each
C*	type of non-NCEP BUFR message.
C*
	PARAMETER	( NXDSC1 = 23 )
	PARAMETER	( NXDSC2 = 25 )
C*
C*	The following array will hold the list of expected descriptors
C*	within Section 3 of each type of non-NCEP BUFR message.
C*	The first dimension of this array must be at least as large
C*	as the largest of the above NXDSC values.
C*
	CHARACTER	cxdsc( NXDSC2, NBUFRT )*6
C*
C*	Expected descriptors within Section 3 of a TAMDAR BUFR message
C*	prior to October 2008.
C*
	DATA		( cxdsc ( ii, 1 ), ii = 1, NXDSC1 )
     +          / '301011', '301013', '301021', '007002',
     +            '007004', '007010', '010082', '008004', '001008',
     +		  '204002', '031021', '001013',
     +            '012001', '011001', '011002', '011037',
     +            '011038', '020041', '204000', '204007',
     +            '031021', '013009', '204000'/
C*
C*	Expected descriptors within Section 3 of a TAMDAR BUFR message
C*	after October 2008.
C*
	DATA		( cxdsc ( ii, 2 ), ii = 1, NXDSC2 )
     +          / '301011', '301013', '301021', '007002',
     +            '007004', '007010', '010082', '008004', '001008',
     +		  '001095', '001009',
     +		  '204002', '031021', '001013',
     +            '012001', '011001', '011002', '011037',
     +            '011038', '020041', '204000', '204007',
     +            '031021', '013009', '204000'/
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = 0
C
        bufrtf(1) = bufrta_old
        nxdsc(1) = NXDSC1
C
        bufrtf(2) = bufrta_new
        nxdsc(2) = NXDSC2

C
C*  Set the pointers for the interface arrays.
C
	CALL TA_IFSP  ( rimnem, cimnem, ierfsp )
	IF  ( ierfsp .ne. 0 )  THEN
	    RETURN
	END IF

C
C++++	BUFR input setup
C
C*  Loop on each type of non-NCEP BUFR tables file.
C
	DO ii = 1, NBUFRT
C
C*  Open the tables file.
C
	    CALL FL_TBOP  ( bufrtf(ii), 'bufr', iubftf(ii), ierspn )
	    IF  ( ierspn .ne. 0 )  THEN
	        CALL DC_WLOG  ( 0, 'FL', ierspn, bufrtf(ii), ierwlg )
	        RETURN
	    END IF
C
C*  Open the messages file.
C
	    CALL FL_GLUN  ( iubfmf(ii), iergln )
	    IF  ( iergln .ne. 0 )  THEN
	        CALL DC_WLOG  ( 0, 'FL', iergln, ' ', ierwlg )
	        RETURN
	    END IF
	    WRITE ( UNIT = cbf, FMT = '(I1.1)')  ii
	    OPEN  ( UNIT = iubfmf(ii),
     +		    FILE = '.dummy.dctama_' // cbf,
     +		    FORM = 'UNFORMATTED' )
C
C*  Connect the tables and messages files.
C
	    CALL OPENBF  ( iubfmf(ii), 'IN', iubftf(ii) )
C
C*  Close the tables file.
C
            CALL FL_CLOS  ( iubftf(ii), iercls )
	    IF  ( iercls .ne. 0 )  THEN
		CALL DC_WLOG  ( 0, 'FL', iercls, ' ', ierwlg )
	    END IF
C
	END DO

C
C*  Constants for SN_CRFP
C
	iflsrc = 4
	maxstn = NACRN
	maxtim = 24
	stmflg = .true.
	addstn = .true.
	cirflg = .true.
	prmfil = 'sntdar.pack'

C
C======================================================================
C  Process bulltins...
C
	DO WHILE ( .true. )
C
C*  Get a new bulletin from the input pipe.
C
	  CALL DC_GBUL ( bull, lenb, ifdtyp, iergbl )
	  IF ( iergbl .ne. 0 ) THEN
C
C*  A time-out occurred while waiting for a new bulletin
C*  on the input pipe.  Shut down the decoder and exit.
C
	      CALL DC_WLOG  ( 0, 'DC', iergbl, ' ', ierwlg )
		DO ii = 1, NBUFRT
		    CALL CLOSBF  ( iubfmf (ii) )
		END DO
		CALL FL_CLAL ( iercal )
	      RETURN
	  END IF
C
C*  Decode the header information from this bulletin.
C
	  IF  ( ifdtyp .ne. 0 )  THEN
C
C*  Do not decode AFOS products.
C
	    bullok = .false.
	  ELSE
C
C*  Decode WMO products.  Initialize the arrays.
C
	    nrept = 0
	    naircft = 0
	    bullok = .true.
	    DO na = 1, NACRN
	      iacrn( na ) = IMISSD
	      selv( na ) = RMISSD
	      acrn( na ) = ' '
	      stat( na ) = '--'
	      coun( na ) = '--'
	      nmlev( na ) = 0
	      flat( na ) = RMISSD
	      flon( na ) = RMISSD
	      DO nl = 1, nlv
		poaf( na, nl ) = RMISSD
		alat( na, nl ) = RMISSD
		alon( na, nl ) = RMISSD
		wspd( na, nl ) = RMISSD
		wdir( na, nl ) = RMISSD
		hmdt( na, nl ) = RMISSD
		tmpk( na, nl ) = RMISSD
		hght( na, nl ) = RMISSD
		pres( na, nl ) = RMISSD
		afdate(na, nl) = ' '
	      END DO
	    END DO
C
C*  Decode WMO products.
C
	    CALL DC_GHDR  ( bull, lenb, seqnum, buhd, cborg,
     +                          bulldt, bbb, ibptr, ierghd )
	    IF  ( ierghd .ne. 0 )  THEN
	      CALL DC_WLOG  ( 2, 'DC', ierghd, ' ', ierwlg )
	      bullok = .false.
	    ELSE
C
C*  Start an entry for this bulletin in the decoder log.
C
	          logmsg = '####################' //
     +			   '####################'
	      CALL DC_WLOG  ( 2, 'DC', 2, logmsg, ierwlg )
	      logmsg = seqnum // buhd // cborg // bulldt // bbb
	      CALL DC_WLOG  ( 2, 'DC', 2, logmsg, ierwlg )
	    END IF
	  END IF
C
	  IF  ( bullok )  THEN
C
C*  Get the system time.
C
	    itype = 1
	    CALL CSS_GTIM  ( itype, sysdt, iergtm )
	    IF  ( iergtm .ne. 0 )  THEN
	      CALL DC_WLOG  ( 2, 'SS', iergtm, ' ', ierwlg )
	      bullok = .false.
	    END IF
	  END IF
C
	  IF  ( bullok )  THEN
C
C*  If a date-time was entered on the command line, then
C*  use it as the run date-time.  Otherwise, use the
C*  system time as the run date-time.
C
	    IF  ( cldt .eq. 'SYSTEM' )  THEN
	      rundt = sysdt
	    ELSE
	      CALL TI_STAN  ( cldt, sysdt, rundt, ierstn )
	      IF  ( ierstn .ne. 0 )  THEN
	        CALL DC_WLOG  ( 2, 'TI', ierstn, ' ', ierwlg )
	        bullok = .false.
	      END IF
	    END IF
	  END IF
C
	  IF  ( bullok )  THEN
C
C*  Convert the run date-time to integer.
C
	    rundt = rundt(1:9) // '00'
	    CALL TI_CTOI  ( rundt, irundt, ierctoi )
	    IF  ( ierctoi .ne. 0 )  THEN
	      CALL DC_WLOG  ( 2, 'TI', ierctoi, ' ', ierwlg )
	      bullok = .false.
	    END IF
	  END IF
C
	  IF ( bullok ) THEN
C
C*  Locate the next BUFR message within the bulletin,
C*  and store it within an equivalenced integer array.
C
	    ipt1 = INDEX ( bull ( ibptr : lenb ), 'BUFR' )
	    IF  ( ipt1 .eq. 0 )  THEN
	      bullok = .false.
	    ELSE
	      istart = ibptr + ipt1 - 1
	      cbull = bull ( istart : lenb )
	    END IF
	  END IF
C
          IF ( bullok ) THEN
C
C*  Determine which BUFR tables file this message
C*  corresponds to.  Retrieve the Section 3 descriptors
C*  from this TAMDAR BUFR message and compare it with
C*  the list of expected descriptors.
C
		ii = 1
		bullok = .false.
		DO WHILE  (  ( .not. bullok ) .and.
     +				( ii .le. NBUFRT )  )
		    CALL UT_CBS3  ( 4, ibull, cxdsc ( 1, ii ),
     +				    nxdsc ( ii ), iercs3 )
		    IF  ( iercs3 .eq. 0 )  THEN
			bullok = .true.
		    ELSE
			ii = ii + 1
		    END IF
		END DO
	  END IF
C
	  IF ( bullok ) THEN
		logmsg = 'message read using ' // bufrtf(ii)
		CALL DC_WLOG  ( 2, 'DC', 2, logmsg, ierwlg )
C
C*  Open the TAMDAR BUFR message.
C
		CALL READERME  ( ibull, iubfmf (ii),
     +				 bfstyp, ibfdt, ierrme )
		IF  ( ierrme .ne. 0 )  THEN
		    bullok = .false.
		ELSE
C
C*  Check update sequence number in Section 1 to see
C*  if correction is indicated.  If this bulletin is
C*  a correction, 'corn' will be set to a non-zero
C*  value so CORN may be set within TA_BUFR.
C
		    corn = FLOAT ( IUPBS01 ( ibull, 'USN' ) )
		    IF ( corn  .gt. 0.0 ) corn = 1.0
		    nrept = 0
		END IF
	  ELSE
		logmsg = 'message has unknown format'
		CALL DC_WLOG  ( 2, 'DC', 2, logmsg, ierwlg )
	  END IF
C
	  DO WHILE  ( bullok )
C
C*  Get the next report from this BUFR message.
C
	    CALL READSB  ( iubfmf(ii), ierrsb )
	    IF  ( ierrsb .ne. 0 )  THEN
C
C*  There are no more reports in this message.
C
	      bullok = .false.
C
C*  Print a count of the number of reports processed.
C
	      WRITE  ( UNIT = logmsg, FMT = '( A, I4, A )' )
     +		'contained ', nrept, ' reports'
	      CALL DC_WLOG  ( 2, 'DC', 2, logmsg, ierwlg )

C
C*  READSB - ierrsb = 0...
C
	    ELSE
	      nrept = nrept + 1
C
C*  Initialize the interface arrays.
C
	      CALL TA_IFIV  ( ier_ifiv )
C
C*  Decode the report into the interface arrays.
C
	      CALL TA_BFIF  ( iubfmf (ii) , ierbif )
C
C*  Write data for this report to the decoder log.
C
	      CALL TA_IFPT  ( rimnem, cimnem, ier_ifpt )
C
C*  Do not create output for reports that are more than
C*  NHOURS before or more than 3 hours after the run time.
C
	      IF  (  ( ERMISS ( rivals( iryear ) ) ) .or.
     +			 ( ERMISS ( rivals( irmnth ) ) ) .or.
     +			 ( ERMISS ( rivals( irdays ) ) ) .or.
     +			 ( ERMISS ( rivals( irhour ) ) ) .or.
     +			 ( ERMISS ( rivals( irminu ) ) )  ) THEN
		    iertmk = -1
	      ELSE
		irptdt(1) = INT ( rivals( iryear ) )
		irptdt(2) = INT ( rivals( irmnth ) )
		irptdt(3) = INT ( rivals( irdays ) )
		irptdt(4) = INT ( rivals( irhour ) )
		irptdt(5) = INT ( rivals( irminu ) )
		CALL DC_TMCK  ( 2, irundt, irptdt, nhours,
     +			    180, iertmk )
	      END IF
	      IF  ( iertmk .eq. 0 )  THEN
C
C*  Construct the aircraft id from aircraft number
C*  by appending flight phase character:
C*  - 'A' for ascending plane
C*  - 'D' for descending plane
C
		CALL ST_NUMB (civals ( icacrn ), icurra, iret)
		IF ( rivals (irpoaf) .eq. 5 ) THEN
		  cracrn = civals ( icacrn )(2:) // 'A'
		ELSE IF ( rivals (irpoaf) .eq. 6 ) THEN
		  cracrn = civals ( icacrn )(2:) // 'D'
		ELSE
		  cracrn = ' '
		ENDIF
		amatch = .false.
		ia    = 1
		iaircft = 0
C
C*  Start loop over the planes in the bulletin.
C
		DO WHILE ( .not. amatch )
		  IF ( ( cracrn .eq. acrn(ia) ) .and.
     +                 ( nmlev(ia) .ne. 0 ) ) THEN
C
C*  This is an existing plane - increment the number of levels.
C
		    amatch = .true.
		    nmlev(ia) = nmlev(ia) + 1
		    iaircft = ia
		  ELSE IF ( ( cracrn .ne. acrn(ia) ) .and.
     +                           ( rivals(irpoaf) .ne. RMISSD ) .and.
     +                           ( nmlev( ia ) .eq. 0 ) ) THEN
C
C*  This is a new plane - increment the total
C*  number of aircrafts and construct the aircraft number.
C
		    naircft = naircft + 1
		    acrn(naircft) = cracrn
		    IF ( cracrn(8:8) .eq. 'D') THEN
		      ipoaf = 6
		    ELSE IF (cracrn(8:8) .eq. 'A') THEN
		      ipoaf = 5
		    END IF
		    iacrn(naircft) = ipoaf*100000 + icurra
		    nmlev(naircft) = 1
		    iaircft = naircft
		    amatch = .true.
		  END IF
		  ia = ia + 1
		  IF ( ia .gt. NACRN ) amatch = .true.
		END DO
C
C*  Decode the records into the individual arrays.
C
		IF ( iaircft .gt. 0 ) THEN
		  il = nmlev(iaircft)
		  alat(iaircft, il) = rivals(irslat)
		  alon(iaircft, il) = rivals(irslon)
		  wspd(iaircft, il) = rivals(irwspd)
		  wdir(iaircft, il) = rivals(irwdir)
		  hght(iaircft, il) = rivals(irhmsl)
		  pres(iaircft, il) = rivals(irprlc)/100.
		  tmpk(iaircft, il) = rivals(irtmdb)
		  hmdt(iaircft, il) = rivals(irrehu)
		  CALL TI_ITOC ( irptdt, cdum, iret)
		  afdate(iaircft, il) = cdum
		END IF
	      END IF
C
		  logmsg = '-----------------------------------'
		  CALL DC_WLOG  ( 3, 'DC', 2, logmsg, ierwlg )
	    END IF

C
C*  END DO for DO WHILE ( bullok );
C*  looping over reports in a single BUFR message...
C
	  END DO

C
C======================================================================
C
C*  Write out the data for each aircraft for this BUFR message...
C
	  DO ia = 1, naircft
	    IF ( acrn(ia)(8:8) .eq. 'A' ) THEN
	      bot = 1
	      top = nmlev(ia)
	      inc = 1
	    ELSE
	      bot = nmlev(ia)
	      top = 1
	      inc = -1
	    END IF

C
C*  Create a "Nominal Time" of observation.
C
	    dattim = afdate(ia,bot)(1:9) // '00'

C
C*  Create a unique "observation ID" from time and aircraft ID.
C
	    acrn(ia) = dattim(8:9) // acrn(ia)(3:8)

C
C*  Make a file name from the template and the aircraft report time.
C
	    CALL FL_MNAM ( dattim(1:6), gemfil, filnam, ier )

C
C*  Check for the requested upper air data file.
C
	    CALL FL_INQR ( filnam, exist, newfil, ier )
	    IF  ( exist )  THEN

C
C*  Open the merged upper air data file.
C
	      CALL SN_OPNR ( filnam, isnfln, ifsc, nparm, parms, ivert,
     +				mrgdat, ieropnr )

C
C*  Check that the file was opened properly.
C
	      IF  ( ieropnr .ne. 0 )  THEN

C
C*  If not, write an error to the decoder log file.
C
	        CALL DC_WLOG ( 0, 'SN', ierr, filnam, iret )
	        RETURN
	      ELSE

C
C*  Check for existence of time/aircraft in file; if not present
C*  add the time/aircraft; if present, has data been added?
C
		CALL TA_TMST ( isnfln, dattim , acrn(ia),
     +				iacrn(ia), alat(ia,bot), alon(ia,bot),
     +				RMISSD, addstn, cirflg, datflg, ier_tmst)
		IF ( ier_tmst .eq. 0 ) THEN
		  IF ( datflg ) THEN

C
C*  Data already present in sounding file, read it in.
C
		    CALL SN_RDAT(isnfln, nlevi, datai, ihhmm, ier)
		    nlevo = nlevi + nmlev(ia)
		    IF ( acrn(ia)(8:8) .eq. 'A' ) THEN

C
C*  Ascending aircraft so can insert new data at the end of datai.
C
		      ii = nlevi * NPARMS
		      DO il = 1, nmlev(ia)
			datai(ii+1) = pres(ia,il)
			datai(ii+2) = tmpk(ia,il)
			datai(ii+3) = hmdt(ia,il)

C
C*  It appears that wdir equal to 360.0 is reserved for missing...
C
			IF ( wdir(ia,il) .eq. 360.0 )  THEN
			  datai(ii+4) = RMISSD
			  datai(ii+5) = RMISSD
			ELSE
			  datai(ii+4) = wdir(ia,il)
			  datai(ii+5) = wspd(ia,il)
			END IF
			datai(ii+6) = hght(ia,il)
			ii = ii + 6
		      END DO
		      CALL SN_WDAT(isnfln, ihhmm, nlevo, datai, ier)
		    ELSE

C
C*  Descending aircraft so must put new data at head of datai.
C*  Use datao for the output data.
C
		      ii = 0
		      DO il = bot, top, inc
			datao(ii+1) = pres(ia,il)
			datao(ii+2) = tmpk(ia,il)
			datao(ii+3) = hmdt(ia,il)

C
C*  It appears that wdir equal to 360.0 is reserved for missing...
C
			IF ( wdir(ia,il) .eq. 360.0 )  THEN
			  datao(ii+4) = RMISSD
			  datao(ii+5) = RMISSD
			ELSE
			  datao(ii+4) = wdir(ia,il)
			  datao(ii+5) = wspd(ia,il)
			END IF
			datao(ii+6) = hght(ia,il)
			ii = ii + 6
		      END DO
		      kk = 1
		      DO jj = nmlev(ia)*NPARMS+1, nlevo*NPARMS
			datao(jj) = datai(kk)
			kk = kk +1
		      END DO
		    END IF

C
C*  ELSE for "IF ( datflg ) THEN"
C
		  ELSE

C
C*  New aircraft for this time period, just add it...
C
		    CALL TI_CTOI(afdate(ia,bot), iarcft, ierctoi )
		    ihhmm = 100*iarcft(4) + iarcft(5)
		    ii = 0
		    DO il = bot, top, inc
		      datao(ii+1) = pres(ia,il)
		      datao(ii+2) = tmpk(ia,il)
		      datao(ii+3) = hmdt(ia,il)

C
C*  It appears that wdir equal to 360.0 is reserved for missing...
C
		      IF ( wdir(ia,il) .eq. 360.0 )  THEN
		        datao(ii+4) = RMISSD
		        datao(ii+5) = RMISSD
		      ELSE
		        datao(ii+4) = wdir(ia,il)
		        datao(ii+5) = wspd(ia,il)
		      END IF
		      datao(ii+6) = hght(ia,il)
		      ii = ii + 6
		    END DO
		    CALL SN_WDAT(isnfln, ihhmm, nmlev(ia), datao, ier)
		  END IF

C
C*  END IF for "IF ( iertmst .eq. 0 ) THEN"
C
		END IF
		CALL SN_CLOS(isnfln, ierclos)

C
C*  END IF for "IF  ( ieropnr .ne. 0 )  THEN"
C
	      END IF

C
C*  ELSE for "IF  ( exist )  THEN"
C
	    ELSE

C
C*  File does NOT exist, create the merged upper air data file.
C
	      CALL SN_CRFP ( filnam, prmfil, iflsrc, maxstn, maxtim,
     +               stmflg, isnfln, nparm, parms, pkflg, iercrfp )

C
C*  Check that the file was created properly.
C
              IF  ( iercrfp .ne. 0 )  THEN

C
C*  If not, write an error to the decoder log file.
C
                CALL DC_WLOG ( 0, 'SN', ierr, filnam, iret )
                RETURN
	      ELSE

C
C*  Add station to the data file.
C
		CALL TA_TMST ( isnfln, dattim, acrn(ia),
     +				iacrn(ia), alat(ia,bot), alon(ia,bot),
     +				RMISSD, addstn, cirflg, datflg, iertmst )
		IF ( iertmst .eq. 0 ) THEN
		  CALL TI_CTOI(afdate(ia,bot), iarcft, ierctoi )
		  ihhmm = 100*iarcft(4) + iarcft(5)
		  ii = 0
		  DO il = bot, top, inc
		    datao(ii+1) = pres(ia,il)
		    datao(ii+2) = tmpk(ia,il)
		    datao(ii+3) = hmdt(ia,il)

C
C*  It appears that wdir equal to 360.0 is reserved for missing...
C
		    IF ( wdir(ia,il) .eq. 360.0 )  THEN
		      datao(ii+4) = RMISSD
		      datao(ii+5) = RMISSD
		    ELSE
		      datao(ii+4) = wdir(ia,il)
		      datao(ii+5) = wspd(ia,il)
		    END IF
		    datao(ii+6) = hght(ia,il)
		    ii = ii + 6
		  END DO
		  CALL SN_WDAT (isnfln, ihhmm, nmlev(ia), datao, ierwdat)
		END IF
		CALL SN_CLOS(isnfln, ierclos)
	      END IF

C
C*  END IF for "IF  ( exist )  THEN"
C
	    END IF

C
C*  END DO for "DO ia = 1, naircft"
C
	  END DO

C
C*  END DO for "DO WHILE ( .true. )"; looping over BUFR bulltins...
C
	END DO
C
	RETURN
	END