text:
c  To Do:
c  Check for '<<<<<<<<<<<<<<<'
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      PROGRAM LCMODL
C
Cvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv For user vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
C
C LCModel license
C
C    Copyright (c) 1992-2021, Stephen Provencher
C    All rights reserved.
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions are met:
C
C  1. Redistributions of source code must retain the above copyright notice, this
C   list of conditions and the following disclaimer.
C
C  2. Redistributions in binary form must reproduce the above copyright notice,
C     this list of conditions and the following disclaimer in the documentation
C     and/or other materials provided with the distribution.
C
C  3. Neither the name of the copyright holder nor the names of its
C     contributors may be used to endorse or promote products derived from
C     this software without specific prior written permission.
C
C  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
C  AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
C  IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
C  DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
C  FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
C  DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
C  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
C  CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
C  OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C     OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
C
C^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^For user ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

CvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvFor user vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
C
C
C  LCMODL.  Automatic estimation of metabolite concentrations from in vivo NMR
C             spectra.
C           The data spectrum is analyzed as a linear combination from a basis
C             set of model in vitro spectra, with automatic corrections for
C             phase, field inhomogeneity, eddy currents, background, and
C             differences in 1/T2.
C
C
C  To use this program, you need the following references:
C    S.W. Provencher (1993) Magn. Reson. Med. 30, 672-679.
C                    (1993--2021) LCModel Users Manual.
C
C  The first reference above is referred to as simply "MRM" in the comment
C    statements here.
C  In general, the comment statements are mainly for my use.  You need the
C    User's Manual and MRM.
C  Comment statements for you are set off by 2 comment lines, the top with a
C    string of "v" characters and the bottom with a string of "^", both with
C    "For user" in the middle (as these comments are).  Comments for you occur
C    only in subprograms MYCONT, MYDATA, and MYBASI.
C
C^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ For user ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
C
C  Input:
C
C    On unit LCONTR (must be standard input):
C       NAMELIST LCMODL.
C
C    On unit LBASIS (file FILBAS) (in subprogram MYBASI):
C       NAMELIST BASIS1
C       NAMELIST BASIS
C       Frequency-domain basis spectra from zero-filling
C                                      (2*NUNFIL=NDATA COMPLEX values).
C
C    On unit LRAW (file FILRAW) (in subprogram MYDATA):
C       NAMELIST NMID
C       Time-domain data (NUNFIL COMPLEX values)
C
C    If DOECC or DOWS or UNSUPR, on unit LH2O (file FILH2O) (in subprogram
c      MYDATA):
C       NAMELIST NMID
C       Time-domain non-H2O-suppressed data
C
C
C  Output:
C
C    If LPRINT>0, on unit LPRINT (file FILPRI):
C       Detailed output for printing.
C
C    If LCOORD>0, on unit LCOORD (file FILCOO):
C       Output for possible subsequent external plot program.
C
C    If LCOraw>0, on unit LCoraw (file FILCOr):
C       Output of RAW data, after ECC, *FCALIB*TRAMP/VOLUME, correction for
C         BRUKER=T or SEQACQ=T; corrections for phase & referencing shift.
C
C    If LPS>0, on unit LPS (file FILPS):
C       .PS file for PostScript printer.
C
C    If LTABLE>0, on unit LTABLE (file FILTAB):
C       short .TABLE file, containing only the 4 tables from 1-page output.
C
C
C  The fit is to the real part of the spectrum obtained with zero filling.
C     The spectra are rearranged; therefore, the analysis also works for
C     PPM>PPMCEN.
c  Old grid positions + NUNFIL.
c  Rearrangement in CFFT_r and DCFFT_r, but not in CFFT or CFFTIN (since
c    BASISF is not rearranged)
c  SEQACC = T not tested.
c  Had to redefine INCDIM, DELPPM, and test for INITIA 3.
C
C  Fortran 77 extensions: COMPLEX*16, INCLUDE, NAMELIST,
C  (Obsolete) Sun version (marked ! followed directly by Sun): Time, date
C  IRIX Version (marked ! followed directly by IRIX): READONLY, TIME, DATE,
C                                                     UNKNOWN, ZEXP
c  ***************************************************************************
C                 markers preceded by a !
c                 =======================
C  Cyg: (formerly Cygwin g77 version) Intel version for MS Windows.  License
c       tests are skipped.  It is assumed that a HASP envelope protects it.
c  sun: g77 Sun cross-compiler (important to only leave this not commented out;
C       its preparation will only comment out Linux preceded by ! and could
c       otherwise produce the statement twice.  The others comment out all
C       lines with ! string, except its own).
c  IRIX: IRIX
c  OSF: DEC Fortran
c  Linux: g77 PC Linux
c  ***************************************************************************
C  Version-dependent parts are marked with C!!!!...
C
C  Extra tests (COMMENTed out):
C    !CT1: Checks (quadratic) convergence with exact data from previous fit
C          when ISTAGE=1.
C    !CT2: As !CT1, but for ISTAGE=2.
C
c  LDUMP(1) = T to dump weights, etc, for phased-array averaging in AVERAGE.
c       (2) = T to dump details of gaps and baseline regions on ppm-axis.
c       (3) = T to dump compacted lines of CONTROL file.
c       (4) = T & SUBBAS=T & NEACH=99 to dump ratios of peak areas to Concs to
c               check normalization and scaling of simulated basis spectra.
c       (5) = T to dump the real part of basis around WSPPM in AREABA.
c
      INCLUDE 'lcmodel.inc'
      external ilen
      logical iok
      data nanalyses_done/0/, nvoxels_done/0/, nvoxels_done_in/0/
      chsubp = 'MAIN'
      version_lcm = '6.3-1N'
      lversion_lcm = ilen(version_lcm)
      VERSIO='LCModel (Version ' // version_lcm(:lversion_lcm) //
     1       ') Copyright: S.W. Provencher.' //
     2       '          Ref.: Magn. Reson. Med. 30:672-679 (1993).'
C     -------------------------------------------------------------------------
C     Get changes to Control Variables.
C     -------------------------------------------------------------------------
      CALL MYCONT ()
C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
c     Uncomment the following to initialize license KEYs and other Control
c       Parameters for Frahm.
c
c      include 'frahm.inc'
c
C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C
C     -------------------------------------------------------------------------
c     Load ZERO_VOXEL array, which has values of T for zero voxels.
c     Skip this if BASCAL=T.
C     -------------------------------------------------------------------------
      if (.not.bascal) then
         call check_zero_voxels ()
C        ----------------------------------------------------------------------
c        IAVERG >= 1 to call AVERAGE to average series of "voxels" in CSI
c                    format in DATAT (as in phased-array or Philips or Elscint
c                    series of scans) and then set control parameters for
c                    single-voxel analysis.
C        ----------------------------------------------------------------------
         if (iaverg .ge. 1) call average ()
      end if

      if (lcsi_sav_1 .eq. 12) then
         if (lcsi_sav_2 .ne. 13) go to 801
         open (12, file=filcsi_sav_1, status='old', err=801)
         open (13, file=filcsi_sav_2, status='old', err=801)
         read (12, 5030, err=801, end=801) nvoxels_done, nanalyses_done,
     1                                     ioffset_current
 5030    format (3i5)
         nvoxels_done_in = nvoxels_done
         ioffset_current_in = ioffset_current
         if (nanalyses_done .gt. 0) read (12, 5040, err=801, end=40)
     1                              degppm, degzer, dgppmn, dgppmx,
     2                              sddegp, sddegz, shifmn, shifmx
 5040       format (1p5e16.6)
      else
         nxoxels_done_in = 0
         nanalyses_done = 0
         ioffset_current_in = 0
      end if

 40   IF (Lcsv .GT. 0   .and.   FILcsv .NE. ' ') then
         if (nanalyses_done .le. 0) then
            OPEN (Lcsv, FILE=FILcsv, STATUS='UNKNOWN', err=802)
         else
            OPEN (Lcsv, FILE=FILcsv, STATUS='OLD', err=802)
            do 30 jline = 1, 9999
 5020          format (a)
               read (lcsv, 5020, err=803, end=35) chline
 30         continue
 35         backspace lcsv
            go to 50
         end if
      end if
C     -------------------------------------------------------------------------
C     Main loop for all analyses of all voxels.
c     Dimensions ND* I* have been checked and ordered in MYCONT
c     Round up or down to put i*_center closest to the overall center.
C     -------------------------------------------------------------------------
 50   center_whole = float(ndrows + 1) / 2.
      i1 = (irowst + irowen) / 2
      i2 = (irowst + irowen + 1) / 2
      if (abs(float(i1) - center_whole) .lt.
     1    abs(float(i2) - center_whole)) then
         irow_center = i1
      else
         irow_center = i2
      end if
      center_whole = float(ndcols + 1) / 2.
      i1 = (icolst + icolen) / 2
      i2 = (icolst + icolen + 1) / 2
      if (abs(float(i1) - center_whole) .lt.
     1    abs(float(i2) - center_whole)) then
         icol_center = i1
      else
         icol_center = i2
      end if
      single_voxel = max0(ndslic, ndrows, ndcols) .eq. 1
      noffset = max0(irowen - irow_center, irow_center - irowst,
     1               icolen - icol_center, icol_center - icolst)
C     -------------------------------------------------------------------------
c     If there is only one voxel (NOFFSET=0), then force an analysis by
c        setting ZERO_VOXEL(1)=F (and let LCModel abort if only voxel really
c        is zero).
C     -------------------------------------------------------------------------
      if (noffset .le. 0) zero_voxel(1) = .false.
      voxel1 = .true.
      do 100 ioffset = ioffset_current_in, noffset
         if (.not. voxel1) then
            rewind lraw
            lraw_at_top = .true.
            IF (filh2o .ne. ' ') rewind lh2o
         end if
         if (ioffset .gt. ioffset_current_in) nvoxels_done_in = 0
         ivoxel = 0
         do 110 idslic = 1, ndslic
            do 120 idrow = 1, ndrows
               do 130 idcol = 1, ndcols
                  ivoxel = ivoxel + 1
                  ir = iabs(idrow - irow_center)
                  ic = iabs(idcol - icol_center)
                  iok = (ir .eq. ioffset   .and.   ic .le. ioffset) .or.
     1                  (ir .le. ioffset   .and.   ic .eq. ioffset)
                  skip_voxel = .not.iok   .or.
     1                         idrow .lt. irowst   .or.
     2                         idrow .gt. irowen   .or.
     3                         idcol .lt. icolst   .or.
     4                         idcol .gt. icolen   .or.
     5                         idslic .ne. islice   .or.
     6                         zero_voxel(ivoxel)   .or.
     7                         ivoxel .le. nvoxels_done_in
                  do 140 j = 1, nvoxsk
                     skip_voxel = skip_voxel   .or.
     1                            (idrow .eq. irowsk(j)   .and.
     2                             idcol .eq. icolsk(j))
 140              continue
                  call restore_settings ()
C
C                 -------------------------------------------------------------
c                 Open output files.
C                 -------------------------------------------------------------
                  call open_output ()
c
C                 -------------------------------------------------------------
                  if (.not.skip_voxel) then
c                    ----------------------------------------------------------
C                    Load changes to Control Variables in array CHANGE for
c                       later output.
C                    ----------------------------------------------------------
                     CALL LOADCH ()
c
C                    ----------------------------------------------------------
C                    Initialize global quantities for later use.
C                    DELPPM(JY) = PPM - PPMCEN on the frequency grid.
C                    ----------------------------------------------------------
                     CALL INITIA ()
c
                  end if
C                 -------------------------------------------------------------
C                 Get DATAT = raw time-domain data.
C                 -------------------------------------------------------------
                  if (.not.bascal) CALL DATAIN ()
                  voxel1 = .false.
                  lraw_at_top = .false.
                  if (skip_voxel) go to 130

                  if (lcsi_sav_1 .eq. 12) then
                     nanalyses_done = nanalyses_done + 1
                     nvoxels_done = ivoxel
                     ioffset_current = ioffset
                     rewind 12
                     write (12, 5030, err= 143)
     1                  nvoxels_done, nanalyses_done, ioffset_current
                     go to 145
 143                 call errmes (1, 4, chsubp)
                  end if
 145              initialize_solve = .true.
C                 -------------------------------------------------------------
C                 BASIST(JDATA,JMETAB) = time-domain basis vectors (COMPLEX).
C                 -------------------------------------------------------------
                  CALL MYBASI (1)
c
C                 -------------------------------------------------------------
C                 Compute NCOMPO and LCOMPO for combinations of metabolites.
C                 -------------------------------------------------------------
                  CALL COMBIS ()
C
C                 -------------------------------------------------------------
C                 Preliminary analysis to get starting estimates for the phase
C                   corrections and the referencing shift in the
c                   frequency-domain data.
C                 -------------------------------------------------------------
                  CALL STARTV (1)
C                 -------------------------------------------------------------
C                 Repeat Prel with fewer metabolites.  Typically, L20 & L09
c                    are omitted in CHECK_CHLESS.  This is skipped when
c                    NCHLES <= 0 (default in Block Data).
C                 -------------------------------------------------------------
                  call check_chless ()
                  if (omit_chless) then
                     CALL MYBASI (1)
                     CALL COMBIS ()
                     CALL STARTV (2)
                  end if
C
C                 -------------------------------------------------------------
C                 Analyses with Regula Falsi searches for ALPHAB and ALPHAS
C                   with PROB1 between PRMNMX(1,1) and PRMNMX(2,1).
C                 -------------------------------------------------------------
                  IF (DOFULL) THEN
                     CALL MYBASI (2)
                     CALL COMBIS ()
                     CALL TWOREG ()
                  END IF
C
C                 -------------------------------------------------------------
C                 Final output.
C                 -------------------------------------------------------------
                  CALL FINOUT ()
                  if (.not.single_voxel) call update_priors ()
 130           continue
 120        continue
 110     continue
 100  continue
      if (lcsv .gt. 0) close (lcsv)
      if (lcsi_sav_1 .eq. 12) then
         rewind 12
         nanalyses_done = 0
         write (12, 5030) nvoxels_done, nanalyses_done, ioffset_current
         close (12)
         close (13)
      end if
      stop
 801  call errmes(1, -4, chsubp)
 802  call errmes(2, -4, chsubp)
 803  call errmes(3, -4, chsubp)
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      BLOCK DATA
      INCLUDE 'lcmodel.inc'
C
C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      DATA RRANGE/1.E37/
c     -----------------------------------------------------------------------
c     DRANGE = SQRT(big number), because it can be squared.
c     -----------------------------------------------------------------------
      DATA DRANGE/1.D153/
      DATA CCNTRL/.FALSE./
C!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C
c     ------------------------------------------------------------------------
c     The ordering of the Metabolite Names for the Cho & Cr families in
c       CHCOMB below must be that in COMBIS and in the tests for NAMREL in
c       FINOUT.
c     ------------------------------------------------------------------------
      DATA change/mlines*' ', mlines*' '/,
     1     chbcal/' '/, chcali/mmetab*' '/, chcol/'-'/,
     1     CHCOMB/'GPC+PCh', 'GPC+Cho', 'PCh+Cho', 'Cho+GPC+PCh',
     1            'NAA+NAAG', 'Ins+Glyc', 'mI+Glyc',  'Ins+Gly',
     1            'mI+Gly', 'Cr+PCr', 'Cre+PCr',  'Glu+Gln',
     1            'Lip13a+Lip13b', 'MM14+Lip13a+Lip13b+MM12',
     1            'MM09+Lip09',    'MM20+Lip20', MPMET16*' '/,
     1     chcom2/mpmet*' '/, chdate/' '/,
     1     CHEXT2/MMETAB*' '/, chgam/'gamma'/, chgrsh/mgroup_shift*' '/,
     1     CHKEEP/MMETAB_extra*' '/, chless/'L09', 'L20', mmeta2*' '/,
     1     chlsha/mmetab*' '/, chmore/'L13'/,
     1     chnols/'Lac', 'Ala', mmet_ex2*' '/,
     1     chnot1/'Acn',   'Act',   'Bet',   'bHb',   'Car',
     2            'Cit',   '-CrCH2','Eth',   'Fuc',   'GABA',
     3            'Gcn',  'Gcr',    'Glc',   'Gly',   'Glyc',
     4            'Gua',  'Ilc',    'Leu',   'Lip20', 'MM12',
     5            'MM14', 'MM17',   'MM20',  'NAAG',  'Pal',
     6            'Pgc',  'Pyr',    'Scyllo','Suc',   'notTau',
     7            'Thr',  'TMPO',   'Val',   mmet_ex33*' '/,
     1     chnot2/'Lip13c', 'Lip13d', 'Lip13e', mmet_ex3*' '/
     1     CHOMIT/MPMET*' '/
      DATA CHPMET/
     1            'Acn',    'Act',    'Ala',
     2            'Asp',    'Bet',    'bHb',
     3            'Car',    'Cho',    'Cit',
     4            'Cr',     'Cys',    'Eth',
     5            'Fuc',    'GABA',   'Gcn',
     6            'Gcr',    'Glc',    'Gln',
     7            'Glu',    'Glyc',   'GPC',
     8            'Gua',    'ILc',    'Ins',
     9            'Lac',    'Leu',    'NAA',
     T            'NAAG',   'PAl',    'PCh',
     1            'Pgc',    'Pyr',    'Scyllo',
     2            'Suc',    'Tau',    'Thr',
     3            'TMPO',   'Val',    'PCr',
     4            'Cre',    'Gly',    'mI',
     5            '-CrCH2', 'Lip20',  'MM12',
     6            'MM14',   'MM17',   'MM20',
     7            'Lip13a', 'Lip13b', 'Lip13c',
     8            'Lip13d', 'Lip13e', 'MM09',
     9            'Lip09',  MPME55*' '/
c     -------------------------------------------------------------------------
c     If CHRATO is changed below, then NORATO, NRATIO, etc, may have to be
c       adjusted in assignments according to SPTYPE in MYCONT and liver-1.inc
c       and lipid-1.inc.
c     .286+-.126 below corresponds to GSH/Gln=.4+-.3
c     -------------------------------------------------------------------------

      DATA chrati/mmetab*' '/,
     1     chrato/
     1            'Lip09/Lip13* = .267 +- .1 +WT= MM12',
     1            'Lip20/Lip13* = .15 +- .07 +WT= MM12',
     1            'MM20/MM09* = 1.5 +- .375 +WT= Lip09*',
     1            'MM12/MM09* = .3 +- .1 +WT= Lip09*',
     1            'MM14/MM09* = .75 +- .45 +WT= Lip09*',
     1            'MM17/MM09* = .375 +- .3 +WT= Lip09*',
     1            '-CrCH2/totCr = .1 +- .25',
     1            'Asp/Big3 = .05 +- .05',
     1            'GABA/Big3 = .03 +- .03',
     1            'Glc/Big3 = .03 +- .03',
     1            'Scyllo/Big3 = .01 +- .01',
     1            'Tau/Big3 = .05 +- .05',
     1            'GSH/Gln+GSH = .286 +- .126',
     1            mmet13*' '/,
     1     chratw/mmetab*' '/,
     1     chrow/'_'/, CHSDSH/'NAA', 'NAAG', 'Cho', MMETA3*' '/,
     1     CHSDT2/MMETAB*' '/, chsim/mmetab*' '/
      data chsimu/
     1          'Lip13a @ 1.28 +- .01 FWHM= .15 < .2 +- .035 AMP= 2.',
     1          'Lip13b @ 1.28 +- .01 FWHM= .089 < .09 +- .035 AMP= 2.',
     1          'Lip13c @ 1.30 +- .01 FWHM= .089 < .09 +- .035 AMP= 2.',
     1          'Lip13d @ 1.26 +- .01 FWHM= .089 < .09 +- .035 AMP= 2.',
     1          'Lip09 @ .89 +- .02 FWHM= .14 < .19 +- .035 AMP= 3.',
     1          'MM09 @ .91 +- .02 FWHM= .14 < .17 +- .015 AMP= 3.',
     1          'Lip20 @ 2.04 +- .005 FWHM=.15 < .2 +- .025 AMP=1.33
     1             @ 2.25 FWHM=.15 AMP=.67  @ 2.8 FWHM=.2 AMP=.87',
     1          'MM20 @ 2.08 +- .005 FWHM=.15 < .18 +- .01 AMP=1.33
     1             @ 2.25 FWHM=.2 AMP=.33  @1.95 FWHM=.15 AMP=.33
     1             @ 3. FWHM=.2 AMP=.4',
     1          'MM12 @ 1.21 +- .01 FWHM= .15 < .2 +- .02 AMP= 2.',
     1          'MM14 @ 1.43 +- .02 FWHM= .17 < .2 +- .02 AMP= 2.',
     1          'MM17 @ 1.67 +- .03 FWHM= .15 < .17 +- .02 AMP= 2.',
     1          '-CrCH2 @ 3.93 +- 0. FWHM= -9. < 0. +- 0. AMP= -2.',
     1          'Gua @ 3.78 +- 0. FWHM=-9.<0. +- 0. AMP=2.',
     1          'Glyc @ 3.55 +- 0. FWHM=-9.<0. +- 0. AMP=2.',
     1          mmet14*' '/,
     1     chslic/'sl'/,
     1     CHUSE1/'NAA', 'Cr', 'GPC', 'Glu', 'Ins', 'Lac', 'Glc',
     1            'Gln', 'NAAG', 'Tau', 'Asp', 'Ala', 'GABA', 'Scyllo',
     1            MMET_ex14*' '/,
     1     FILBAS/' '/,  FILCOO/' '/, filcor/' '/,
     1     filcsi_sav_1/' '/, filcsi_sav_2/' '/, filcsv/' '/,
     1     FILH2O/' '/, FILPS/' '/, FILPRI/' '/, FILRAW/' '/,
     1     FILTAB/' '/, NAMEAC/MMETAB*' '/, NAMREL/'Cr'/,
     1     norato/mmetab*' '/,
     1     OWNER/' '/, ownout/' '/, PGNORM/' '/, savdir/' '/,
     1     sptype/' '/, srch2o/' '/, srcraw/' '/,
     1     SYNUS1/'GPC','PCh',  'GPC','Cho',  'PCh','Cho',
     1            'Ins','mI',   'Glyc','Gly', 'Cr','Cre',
     1            MPMET6*' ', MPMET6*' '/
     1     TITLE/' '/, title_line/2*' '/, wsmet/'Cr'/
      data power/2.d0, 1.d0, 1.5d0/
      DATA iareaw/2/,
     3     iauto/1/, iaverg/0/, icolen/1/, icolsk/mvoxsk*0/, icolst/1/,
     3     idgppm/-1/, IDUMP/MSTAGE*1/,
     3     IETCOU/3/, imethd/0/, INCSID/1/, INCSMX/15/,
     3     ioffset_current_in/0/,
     3     IPAGE2/1/, ipdump/0/, ipowph/6/, ipowrg/0/, irowen/1/,
     3     irowsk/mvoxsk*0/,  irowst/1/, ISDBOL/15/,
     3     ISHIFW/0/, islice/1/,
     3     ISTAGO/0/, iter_dump/-1/,
     3     KEY/MKEY*0/, LBASIS/3/, LCONTR/5/, lcontr_scratch/29/,
     3     LCOORD/0/, lcoraw/0/, lcsi_sav_1/0/, lcsi_sav_2/0/, lcsv/0/,
     3     LDWFFT/0/,  lett/0/, LH2O/2/, LINCHG/2*0/, LINERR/0/,
     3     linerr_mycont/0/,
     3     LINETC/0/, LINTBL/0/, LPRINT/0/, LPS/8/, LRAW/1/,
     3     LTABLE/0/, LWFFT/0/,
     3     MDALPB/12/, mdegp3/41/,
     3     MERMES/9000/, MFNDAL/25/, MINTER/3*1/,
     3     MITER/20, 40, 30/, mnsamp/9/, mpower/1/,
     3     MREPHA/3, 0/, n1hmet/3/, nback/75, 50/, nbas_ccf/10/,
     3     nbckmn/6/, ncalib/0/, nchgam/5/, nchles/0/, nchlin/35, 49/,
     3     NCOMBI/16/, ndcols/1/, NDEGZ/36, 4/,
     3     NDGPPM/21, 3/, ndrows/1/, ndslic/1/,
     3     NEACH/0/, nermes/0/, NERROR/MMERM9*0/,
     3     nextr/2*0/, NEXT2/0/, ngau/mmetab*1/, ngrsh/0/,
     3     ninfl/2*0/, NKEEP/0/, nlin/0/,
     3     nlshap/0/, nnolsh/0/,
     3     nnot1/33/, nnot2/3/, nnorat/0/, NOMIT/0/,
     3     npar/0/, npower/mmetab*0/,  nratio/13/,
     3     nratio_used/0/, NREFPK/1, 3/,
     3     NRF2MN/2/, NSDSH/3/, NSDT2/0/, NSHIFT/8/, NSIDMN/5/,
     3     NSIDMX/11/, nsimul/13/, NSUBTK/2/, ntitle/2/,
     3     NUNFIL/2048/, NUSE1/5/, nvoxsk/0/,
     3     nwsend/50/, nwsst/10/
      DATA absval/.false./, accept_alpbmn/.false./,
     4     accept_step2/.false./,
     4     areaba_orig_basisf/.true./, asymlp/.false./,
     4     badref/.false./, bascal/.false./,
     4     basout/.false./, biglip/.false./,
     4     chksim/.true./, conc3f/.true./,
     4     DOECC/.FALSE./, DOFULL/.TRUE./,
     4     DOREFS/.FALSE., .TRUE./,
     4     dowatr/.true./, dows/.false./,
     4     DOZERO/2*.FALSE., .TRUE./, eccdon/.false./, endpha/.false./,
     4     fixshf/.false./, forecc/.false./,
     4     gauss_rt2/.true./, gshgua/.true./, LANDSC/.TRUE./,
     4     ldump/10*.false./, lcy_skip/my*.false./,
     4     nobase/.false./, nobasi/.false./,
     4     onlyco/.false./, QUICK/.FALSE./,
     4     reflac/.FALSE./, roomt/.false./, scafwh/.false./,
     4     scasim/.true./, sidump/mmetab*.false./,
     4     sitayl/mmetab*.false./, skip_step3/.false./,
     4     solgrd/.true./, smtail/.true./,
     4     SUBBAS/.FALSE./, unsupr/.false./,
     4     useany/.FALSE./, useglc/.FALSE./, usemxb/.true./,
     4     USINFL/.TRUE./, VITRO/.FALSE./, wsdone/.false./,
     4     year4d/.true./
      DATA ALEXT2/MMETAB*0./, ALPBMN/1.7D-3/, ALPBMX/.84D0/,
     5     ALPBPN/.0021/,
     5     ALPBST/.0025/, alphab_dump/-1./, alphas_dump/-1./,
     5     ALPSMN/.1D0/, ALPSMX/2.D3/, ALPSST/10.0001/,
     5     ALSDSH/2*.002, .008, MMETA3*0./, ALSDT2/MMETAB*0./,
     5     area_met_norm/0./,
     5     atth2o/.7/, attmet/1./, black/3*0./, bwtolr/.001/,
     5     conc_expect/mmetab*0./,
     5     CONREL/1./, COSMIN/3*1.E-2/, ddegp3/5./, DDGPMQ/1., 1./,
     5     DDGZMQ/3., 3./, DEEXT2/2./, DEGMAX/12.5, 13./,
     5     DEGPPM/0./, DEGZER/0./, DELTAT/5.E-4/, DESDSH/.004/,
     5     DESDT2/.4/, DFLDMQ/.1/, DGPPMN/-30./, DGPPMX/30./,
     5     dkngam/.35/, DKNTMN/.15, .6/, dkntmn_standard/.075/,
     5     DSHPAT/.05,.1, 2*0./, echot/-1./, exrati/mmetab*-1./,
     5     EXRT2/MMETAB*2./, fcalib/1./, fcsum/1.e-3/, FH2OMX/.25/,
     5     fmain_power/.6/, fother_power/.1/,
     5     frepha/.5/, FSTPMQ/5./, FWHH2O/.4/, FWHMBA/.013/,
     5     fwhmmn/.1/, fwhmmx/.15/,
     5     fwhmsm/-1./, FWHMST/.04/, hifmm/190./,
     5     hwdwat/1., 2./, hzpgam/90., 210./,
     5     HZPPPM/84.47/, HZREF/MREFPK*0., MREFPk*0./,
     5     PAGEHT/27.9/, PAGEWD/21./, PHITOT/2*0./,
     5     PMQST/3*1./, PMQSTL/3*.6/, PNALPB/9./, ppmbas/.1, .2/,
     5     PPMCEN/4.65/, PPMEND/9999./, ppmend_phalip/-1./,
     5     ppmgap/mgap*1.e37, mgap*1.e37/, ppmh2o/4.65/
c     -------------------------------------------------------------------------
c          With PPMMET below:
c     -CrCH2 is omitted if the CH3 peak around 3ppm is not included.
c     MM12 MM14 MM17 MM20 MM09 require MM09 and baseline down to 0.61.
c        However, these are relaxed as much as possible in MYBASI if
c        TE <= TEMM (typically 99.99), with error message if PPMEND > .6, so
c        that they (especially MM20) can fit under NAA peak, etc.
c
c     Lip* are not excluded if PPMEND>0.6, since (especially mobile) lipids
c        can still be present, even at long TE.
c     Changes below must be also made in MYBASI.
c     -------------------------------------------------------------------------
      DATA PPMMET/
     1 2.27,2.17,2.27,2.17,  1.97,1.87,1.97,1.87,  1.57,1.29,1.57,1.29,
     2 2.91,2.59,2.91,2.59,  3.31,3.21,3.31,3.21,  1.26,1.09,1.26,1.09,
     3 3.71,2.35,3.71,2.35,  3.25,3.22,3.22,3.19,  2.71,2.49,2.71,2.49,
     4 3.92,3.89,3.03,3.00,  3.71,3.05,3.71,3.05,  1.29,1.01,1.29,1.01,
     5 1.31,1.09,1.31,1.09,  3.17,2.10,3.17,2.10,  3.81,3.59,3.81,3.59,
     6 3.99,3.09,3.99,3.09,  3.84,2.99,3.84,2.99,  3.91,3.59,2.65,2.01,
     7 3.84,3.59,2.51,2.26,  3.84,3.49,3.84,3.49,  3.25,3.22,3.22,3.19,
     8 3.83,3.73,3.83,3.73,  1.09,0.79,1.09,0.79,  3.59,3.56,3.56,3.51,
     9 1.41,1.21,1.41,1.21,  1.81,0.79,1.01,0.79,  2.63,2.55,2.01,2.01,
     T 2.81,2.45,2.31,2.01,  3.99,2.99,3.99,2.99,  3.25,3.22,3.22,3.19,
     1 1.31,1.01,1.31,1.01,  2.43,2.33,2.43,2.33,  3.40,3.30,3.40,3.30,
     2 2.45,2.35,2.45,2.35,  3.61,3.06,3.61,3.06,  1.41,1.19,1.41,1.19,
     3 3.95,3.85,3.78,3.68,  1.21,0.79,1.21,0.79,  3.92,3.89,3.03,3.00,
     4 3.92,3.89,3.03,3.00,  3.84,3.49,3.84,3.49,  3.59,3.56,3.56,3.51,
     5 3.03,3.00,3.03,3.00,  2.31,1.11,2.31,1.11,  1.25,0.61,1.25,0.61,
     6 1.50,0.61,1.50,0.61,  1.75,0.61,1.75,0.61,  2.31,0.61,2.31,0.61,
     7 1.50,1.11,1.50,1.11,  1.50,1.11,1.50,1.11,  1.50,1.11,1.50,1.11,
     8 1.50,1.11,1.50,1.11,  1.50,1.11,1.50,1.11,  1.20,0.61,1.20,0.61,
     9 1.20,0.61,1.20,0.61,
     T MPME55*0., MPME55*0.,  MPME55*0., MPME55*0./
      DATA PPMPOS/-1.E6, 1.E6/,
     5     PPMREF/4.65, MREFP1*0.,
     5            2.01, 3.03, 3.22, 3.56, MREFP4*0./,
     5     ppmsep/mgap*1.e37/,
     5     PPMSHF/1.E37/, ppmsig/1.e9, -1.e9/, PPMST/-9999./,
     5     ppmst_phalip/7./,
     5     ppm_truncate_max/-999./, ppm_truncate_min/999./,
     5     ppm_water_range/1./, ppm_water_tol/.08/,
     5     PRMNMX/.02,.08, .2,.5, .02,.08/, PTLABL/7.8/,
     5     PTOUTP/7.8/, PTTITL/11./, PTVERS/9./, RALIMN/1.02/,
     5     RALINC/2./, r_areaba/20./, ratipm/4./, RBACKG/6., 2.5/,
     5     rbasmx/2*.25/, RCONVR/3*1.E-3/,
     5     RDALPB/2./, rfwbas/10./, RFWHCC/.5/, RFWHM/1.8/,
     5     rfwhmst_ccf/1.5/, RFWHST/.5/,
     5     RGBBOL/2*0., .999/, rgberr/.999, 2*0./,
     5     RGBLIN/.999, 17*0./, rgbrat/.999, 2*0./,
     5     RHLABL/1.2/, RHOUTP/1.3/, RHTITL/1.5/, RHVERS/2./,
     5     RINCRS/3*1.E-5/, rincsh/.5/, rlesmo/.35/, rlrntz/1./,
     5     RMQDEC/3*.5/, RMQINC/6*4./, RPENMX/1.00001/,
     5     RPMQMN/3*1./, rpowmq/.1/, RRT2MQ/.1/, rsdgp3/1.3/,
     5     rsdsam/2.5, 1.5, 3./, rsdsmq/.125/,
     5     RSHFMQ/.025/, RSTPMN/3*0./,
     5     RSTPMX/3*1./, rt2min/mmetab*0./,
     5     RWFONT/.62/, SDDEGP/20./, SDDEGZ/999./,
     5     sdgrsh/mgroup_shift*0./, SDMSHF/.02/, sdrati/mmetab*0./,
     5     sdshmn/.002/, sdshmx/.004/, SDSMOO/.01, .02, .03, .01/,
     5     SHIFMN/-.3, -.1/, SHIFMX/.3, .3/, siamp/mmet_mgau*0./,
     5     sifwex/mmetab*0./, sifwmn/mmet_mgau*0./, sifwsd/mmetab*0./,
     5     sippm/mmet_mgau*999./, sisdsh/mmetab*-1./,
     5     temm/99.99/, THRLIN/.1/,
     5     wconc/35880./, WDLINE/.06, .01, .005, .01, .04, .005/,
     5     wsppm/3.027/, XLEFT/1.3/,
     5     XRIGHT/1.3/, XSTEP/.2/, XTRPMX/2./, YBOTT/1.3/, YTOP/1.5/
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C      subroutine y2k !OSF
C      INCLUDE 'lcmodel.inc' !OSF
C      character chstr*40 !OSF
c
C      CALL IDATE (KNUM(2), KNUM(1), KNUM(3)) !OSF
C      CALL DATE (CHSTR) !OSF
C      if (year4d) then !OSF
C         chdate(1:7) = chstr !OSF
C         if (knum(3) .lt. 99) then !OSF
C            knum(3) = knum(3) + 2000 !OSF
C         end if !OSF
C         write (chstr, 5100) knum(3) !OSF
C 5100    format (i4) !OSF
C         chdate(8:11) = chstr !OSF
C         CALL TIME (CHSTR) !OSF
C         CHDATE(15:19)=CHSTR !OSF
C      else !OSF
C         CHDATE(1:9)=CHSTR !OSF
C         CALL TIME (CHSTR) !OSF
C         CHDATE(13:17)=CHSTR !OSF
C      end if !OSF
C      end !OSF
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C      subroutine y2k !IRIX
C      INCLUDE 'lcmodel.inc' !IRIX
C      character chstr*40 !IRIX
c
C      CALL IDATE (KNUM(2), KNUM(1), KNUM(3)) !IRIX
C      CALL DATE (CHSTR) !IRIX
C      if (year4d) then !IRIX
C         chdate(1:7) = chstr !IRIX
C         if (knum(3) .lt. 99) then !IRIX
C            knum(3) = knum(3) + 2000 !IRIX
C         end if !IRIX
C         write (chstr, 5100) knum(3) !IRIX
C 5100    format (i4) !IRIX
C         chdate(8:11) = chstr !IRIX
C         CALL TIME (CHSTR) !IRIX
C         CHDATE(15:19)=CHSTR !IRIX
C      else !IRIX
C         CHDATE(1:9)=CHSTR !IRIX
C         CALL TIME (CHSTR) !IRIX
C         CHDATE(13:17)=CHSTR !IRIX
C      end if !IRIX
C      end !IRIX
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE MYCONT ()
C
Cvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv For user vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
C
C  Inputs changes to Control Variables.
C  If your compiler doesn't accept NAMELIST, then you will have to modify this
C    subprogram to use only standard I/O statements.
C  Below is illustrated how you can make your own special-purpose
c    modifications to input data.  In the example below, if QUICK has been
C    input .TRUE., then other Control Variables are changed to force the
C    fastest possible (but crude) analysis.
C
C^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ For user ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
C
      INCLUDE 'lcmodel.inc'
      external ilen
      parameter (mch_line_long=mchsimul+12)
      CHARACTER LINE*(mch_line_long)
      logical is_sptype, standard_refs
      include 'nml_lcmodl.inc'
      include 'nml_lcmodel.inc'
      CHSUBP='MYCONT'
C     -------------------------------------------------------------------------
c     Preliminary default settings based on preliminary reading of Namelist.
c     SPTYPE = 'version5 will be used after 2nd Namelist read (to overwrite
c                          earlier settings)
c                        These settings are dependent on the Block data
c                          settings of CHRATO, NRATIO, etc.
c     Copy LCONTR to LCONTR_SCRATCH, since Cygwin g77 (& NAG90) cannot rewind
c       STDIN.
C     -------------------------------------------------------------------------
      open(lcontr_scratch, status='scratch')
 5104 format(a)
      do 104 jline = 1, 9999
         read(lcontr, 5104, end=105) line
         llen = ilen(line)
         write(lcontr_scratch, 5104) line(1:llen)
 104  continue
 105  rewind lcontr_scratch
      READ (LCONTR_SCRATCH, NML=LCMODL, end=801, err=802)
c     -------------------------------------------------------------------------
c     At long TE, delete ratio prior for GSH/(Gln+GSH), which can get larger
c        than normal.
c     -------------------------------------------------------------------------
      if (echot .gt. 49.) nratio = 12
c     -------------------------------------------------------------------------
c     For high fields, reset Lip* & MM* to sharper values.
c     Also remove ratio constraint on Tau (assuming rodent).
c     This assumes that HZPPPM or HIFMM will not be set in any of the *.inc
c       files below.
c     -------------------------------------------------------------------------
      if (hzpppm .gt. hifmm) then
         chsimu(1)= 'Lip13a @ 1.28 +- .01 FWHM= .05 < .07 +- .02
     1               AMP= 2.'
         chsimu(2)= 'Lip13b @ 1.28 +- .01 FWHM= .029 < .03 +- .02
     1               AMP= 2.'
         chsimu(3)= 'Lip13c @ 1.30 +- .01 FWHM= .029 < .03 +- .02
     1               AMP= 2.'
         chsimu(4)= 'Lip13d @ 1.26 +- .01 FWHM= .029 < .03 +- .02
     1               AMP= 2.'
         chsimu(5)= 'Lip09 @ .89 +- .02 FWHM= .05 < .07 +- .02
     1               AMP= 3.'
         chsimu(6)= 'MM09 @ .91 +- .02 FWHM= .05 < .06 +- .01
     1               AMP= 3.'
         chsimu(7)= 'Lip20 @ 2.04 +- .005 FWHM=.05 < .07 +- .02
     1               AMP=1.33  @ 2.25 FWHM=.05 AMP=.67
     2               @ 2.8 FWHM=.07 AMP=.87'
         chsimu(8)= 'MM20 @ 2.08 +- .005 FWHM=.05 < .06 +- .01
     1               AMP=1.33  @ 2.25 FWHM=.07 AMP=.33
     2               @1.95 FWHM=.05 AMP=.33  @ 3. FWHM=.07 AMP=.4'
         chsimu(9)= 'MM12 @ 1.21 +- .01 FWHM= .05 < .07 +- .02 AMP= 2.'
         chsimu(10)= 'MM14 @ 1.43 +- .02 FWHM= .06 < .07 +- .02 AMP= 2.'
         chsimu(11)= 'MM17 @ 1.67 +- .03 FWHM= .05 < .06 +- .02 AMP= 2.'
         nnorat= 1
         norato(1)= 'Tau'
      end if
      if (nunfil .lt. 64) call errmes (12, 4, chsubp)
      call remove_blank_start (sptype)
      if (nchgam .gt. 0   .and.   chgam .ne. ' '   .and.
     1    dkngam .gt. 0.   .and.   nchgam .le. mchgam   .and.
     2    sptype .eq. ' ') then
         if (index(filbas, chgam(1:nchgam)) .gt. 0   .and.
     1       hzpppm .ge. hzpgam(1)   .and.  hzpppm .le. hzpgam(2))
     2      dkntmn(1) = dkngam
      end if
      call toupper_lower (.false., sptype)
      is_sptype= .false.
      if (sptype(:3) .eq. 'csf') then
         is_sptype= .true.
         nnorat = 5
         norato(1) = 'Asp'
         norato(2) = 'GABA'
         norato(3) = 'Glc'
         norato(4) = 'Scyllo'
         norato(5) = 'Tau'
         nratio = 13
         reflac = .true.
         useglc = .true.
      end if
      if (sptype(:6) .eq. 'nulled') then
         is_sptype= .true.
         badref = .true.
         incsmx = 1
         namrel = 'Lip13a+Lip13b'
         nobasi = .true.
         nratio = 6
         nrefpk(2) = 2
         nsidmn = 1
         nsidmx = 1
         nsimul = 11
         ppmref(1,2) = 1.28
         ppmref(2,2) = 0.90
         vitro = .true.
      end if
      if (sptype(:5) .eq. 'tumor') then
c        ----------------------------------------------------------------------
c        BADREF=T will use every metabloite in Prel, but only those with
c           NUSE1 & CHUSE1 will be used to determine Prel FWHMST, which
c           determines NSIDES.  Must have NUSE1>0 to determine NSIDES.  Can
c           only have NUSE1=0 when lineshape is not used, as with liver, etc.,
c           where NOBASI=T.
c        CHRATO & NRATIO must be adjusted below if there is any change of
c           these in BLOCK DATA.
c        ----------------------------------------------------------------------
         is_sptype= .true.
         badref = .true.
         chrato(13) = 'NAAG/NAA = .15 +- .15'
         chuse1(1) = 'GPC'
         chuse1(2) = 'Cr'
         dkntmn(1) = .35
         namrel = 'GPC'
         nrefpk(2) = 4
         nratio = 13
         nuse1 = 2
         ppmend = .2
         ppmref(1,2) = 3.03
         ppmref(2,2) = 3.22
         ppmref(3,2) = 1.28
         ppmref(4,2) = 0.90
         rbackg(1) = 12.
         shifmn(2) =  -.07
         shifmx(2) = .07
      end if
      include 'muscle-1.inc'
      include 'liver-1.inc'
      include 'lipid-1.inc'
      if (sptype(:7) .eq. 'muscle-'   .or.
     1    sptype(:6) .eq. 'liver-'   .or.
     2    sptype(:7) .eq. 'breast-'   .or.
     3    sptype(:6) .eq. 'lipid-') then
         biglip = .true.
         ppm_truncate_max = 3.5
         ppm_truncate_min = 2.2
      end if
      if (.not.(is_sptype   .or.
     1          sptype(:8) .eq. 'version5'   .or.
     2          sptype(:9) .eq. 'version-5'   .or.
     3          sptype(:1) .eq. ' ')) call errmes (8, 4, chsubp)
c     -------------------------------------------------------------------------
c     Overwrite above defaults by rereading Namelist
c     -------------------------------------------------------------------------
      REWIND LCONTR_SCRATCH
      fwhmba_sav = fwhmba
      fwhmba = -.1
      READ (LCONTR_SCRATCH, NML=LCMODL, end=801, err=802)
c     -------------------------------------------------------------------------
c     Red herring; nothing will be done here.
      if (ldwfft .gt. 0) nlin = nlin + 1024
c     -------------------------------------------------------------------------
c     DOECC must be set before call to AVERAGE
c     -------------------------------------------------------------------------
      doecc_active = doecc
      if (biglip) doecc = forecc
      call remove_blank_start (sptype)
      call toupper_lower (.false., sptype)
      if (sptype(:8) .eq. 'version5'   .or.
     1    sptype(:9) .eq. 'version-5') then
         nratio = 0
         nsimul = 0
         ppmend = 1.0
         ppmst = 3.85
      end if
      if (iauto .eq. 1   .and.   ppmend .gt. 9998.) then
         if (echot .ge. 100.) then
            ppmend = 1.
            nuse1 = 4
         end if
c        ---------------------------------------------------------------------
c        No longer truncate CSI analyses with PPMEND.
c         if (max0(ndslic, ndrows, ndcols) .gt. 1) ppmend = 1.8
c        ---------------------------------------------------------------------
      end if
      if (ppmst .lt. -9998.) ppmst= 4.
      if (ppmend .gt. 9998.) ppmend= .2
      fwhmba_in_control = fwhmba .gt. 0.
      if (.not.fwhmba_in_control) then
         fwhmba = fwhmba_sav
      end if
      if (sptype(:7) .eq. 'muscle-'   .or.
     1    sptype(:6) .eq. 'liver-'   .or.
     2    sptype(:7) .eq. 'breast-'   .or.
     3    sptype(:6) .eq. 'lipid-') then
         if (ppmend .ge. -0.9) call errmes(17, 2, chsubp)
         if (ppmst .ge. 5.) then
            if (ppmst .le. 7.9) call errmes(18, 2, chsubp)
         else
            if ((sptype(:6) .eq. 'liver-')   .and.
     3          (ppmst .ge. 4.01   .or.   ppmst .le. 3.59))
     4         call errmes(19, 2, chsubp)
            if ((sptype(:7) .eq. 'breast-')   .and.
     3          (ppmst .le. 3.79   .or.   ppmst .ge. 4.01))
     4         call errmes(20, 2, chsubp)
            if ((sptype(:6) .eq. 'lipid-')   .and.
     2          (ppmst .le. 3.39   .or.   ppmst .ge. 4.01))
     3         call errmes(21, 2, chsubp)
         end if
      end if
      if ((sptype(:10) .eq. 'only-cho-1'   .or.
     1     sptype(:10) .eq. 'only-cho-2')   .and.
     2    (ppmst .le. 3.79   .or.   ppmst .ge. 4.01   .or.
     3     ppmend .ge. 2.81   .or.   ppmend .le. 2.59))
     4   call errmes(22, 2, chsubp)
c     -------------------------------------------------------------------------
c     Setup for no baseline.
c     -------------------------------------------------------------------------
      if (nobase) then
         alpbmx = alpbmn
         alpbst = alpbmn
         alpbpn = 1.0001 * alpbmn
         idgppm = -1
         nbackg = 0
         usemxb = .false.
      end if
c     -------------------------------------------------------------------------
c     Reset RBASMX & RSDGP3.
c     IDGPPM = -1 (default in Block Data) to skip fixed-DEGPPM series and only
c                  do free analysis.
c            = 0 (default in lipid-2 & PPMST<5) for analyses stressing flat
c                baselines (by allowing medium SSQ/SSQMIN), where there is no
c                small peak that can be lost by incorrect DEGPPM.  This can
c                also be used to input any values for RBASMX & RSDGP3; only
c                differences between IDGPPM=0 & >0 are settings below.
c            = 1 (default in breast-2, only-cho-1 & liver-2) for analyses
c                stressing good phasing and fit (at expense of flat
c                baselines), to find small peaks (like Cho).  Forces
c                fixed-DEGPPM series, even if baseline in unconstrained
c                solution is flat.
c            = 2 (default in muscle-2) (actually between 0 and 1) stresses
c                good fit, but does not force fixed-DEGPPM series if
c                unconstrained solution has flat baseline.
c     -------------------------------------------------------------------------
      if (idgppm .gt. 0) rsdgp3 = amin1(rsdgp3, 1.1)
      if (idgppm .eq. 1) rbasmx(1) = 0.
c     -------------------------------------------------------------------------
c     With dongle, omit "Data of:" allowing blank line if nothing is input (by
c       Hitachi).
c     -------------------------------------------------------------------------
      OWNOUT='Data of: ' // OWNER
       ownout = owner!Cyg
      fwhmst = amin1(fwhmst, fwhmmx)
c     -------------------------------------------------------------------------
c     USEGLC = T to add Glc to Preliminary Analysis
c     -------------------------------------------------------------------------
      if (useglc   .and.   max0(nuse1, nkeep) .lt. mmetab_extra) then
         nkeep = max0(1, nkeep + 1)
         chkeep(nkeep) = 'Glc'
         do 110 juse1 = 1, nuse1
            if (chuse1(juse1) .eq. 'Glc') go to 115
 110     continue
         nuse1 = nuse1 + 1
         chuse1(nuse1) = 'Glc'
 115     continue
      end if
c     -------------------------------------------------------------------------
c     REFLAC = T to use Lac for referencing and for the  Preliminary
c                Analysis, provided PPMEND < 1.33.
c     -------------------------------------------------------------------------
      if (reflac   .and.   ppmend .lt. 1.33   .and.
     1    nuse1 .lt. mmetab_extra) then
         do 120 juse1 = 1, nuse1
            if (chuse1(juse1) .eq. 'Lac') go to 125
 120     continue
         nuse1 = nuse1 + 1
         chuse1(nuse1) = 'Lac'
 125     dorefs(2) = .true.
         do 130 j = 1, nrefpk(2)
            if (abs(ppmref(j,2) - 1.33) .le. .01   .and.
     1          abs(hzref(j,2) - 3.6) .le. .1) go to 140
 130     continue
         nrefpk(2) = min0(mrefpk, max0(2, nrefpk(2) + 2))
         do 135 j = nrefpk(2), 3, -1
            ppmref(j,2) = ppmref(j-2,2)
            hzref(j,2) = hzref(j-2,2)
 135     continue
         ppmref(1,2) = 1.33
         ppmref(2,2) = 1.33
         hzref(1,2) = -3.6
         hzref(2,2) = 3.6
 140     continue
      end if

      IF (QUICK) THEN
         NDEGZ(2)=3
         NDGPPM(2)=1
         NSHIFT=1
         DOREFS(1)=.FALSE.
         NREFPK(2)=3
         PPMREF(1,2)=2.01
         PPMREF(2,2)=3.03
         PPMREF(3,2)=3.22
         HZREF(1,2)=0.
         HZREF(2,2)=0.
         HZREF(3,2)=0.
         DOFULL=.FALSE.
      END IF
c     -------------------------------------------------------------------------
c     Change CV's for calibration.
c     -------------------------------------------------------------------------
      if (ncalib .gt. 0) then
         nratio = 0
         dorefs(2) = .true.
         ncalib = min0(ncalib, mmetab)
         nuse1 = ncalib
         vitro = .true.
         dkntmn(2) = 99.
         standard_refs = .true.
         do 210 j = 1, ncalib
            chuse1(j) = chcali(j)
            standard_refs = standard_refs  .and.
     1           (chcali(j) .eq. 'Lac'  .or.
     2            chcali(j) .eq. 'NAA'  .or.
     3            chcali(j) .eq. 'Cr'  .or.
     4            chcali(j) .eq. 'Cre'  .or.
     5            chcali(j) .eq. 'GPC'  .or.
     6            chcali(j) .eq. 'PCh'  .or.
     7            chcali(j) .eq. 'Cho')
 210     continue
         if (standard_refs) then
            nrefpk(2) = 0
            do 220 j = 1, ncalib
               if (chcali(j) .eq. 'Lac') then
                  nrefpk(2) = nrefpk(2) + 2
                  ppmref(nrefpk(2)-1, 2) = 1.33
                  ppmref(nrefpk(2), 2) = 1.33
                  hzref(nrefpk(2)-1, 2) = -3.6
                  hzref(nrefpk(2), 2) = 3.6
               else if (chcali(j) .eq. 'NAA') then
                  nrefpk(2) = nrefpk(2) + 1
                  ppmref(nrefpk(2), 2) = 2.01
                  hzref(nrefpk(2), 2) = 0.
               else if (chcali(j) .eq. 'Cr'  .or.
     1                  chcali(j) .eq. 'Cre' ) then
                  nrefpk(2) = nrefpk(2) + 1
                  ppmref(nrefpk(2), 2) = 3.03
                  hzref(nrefpk(2), 2) = 0.
               else if (chcali(j) .eq. 'Cho'  .or.
     1                  chcali(j) .eq. 'GPC'  .or.
     1                  chcali(j) .eq. 'PCh' ) then
                  nrefpk(2) = nrefpk(2) + 1
                  ppmref(nrefpk(2), 2) = 3.22
                  hzref(nrefpk(2), 2) = 0.
               end if
 220        continue
         end if
      end if
C     -------------------------------------------------------------------------
c     Change CV's for Basis calibration when BASCAL=T
C     -------------------------------------------------------------------------
      if (bascal) then
         sddegz=amin1(sddegz, 3.)
         sddegp=amin1(sddegp, 1.)
         doecc=.false.
         absval=.false.
         nsimul = 0
         nratio = 0
         ndslic = 1
         ndrows = 1
         ndcols = 1
      end if
C     -------------------------------------------------------------------------
c     Set IKNTMN DKNTMN & ALPB* for special cases.
C     -------------------------------------------------------------------------
      IKNTMN=1
      IF (VITRO) IKNTMN=2
      IF (DKNTMN(IKNTMN) .LE. 0.) call errmes (25, 4, chsubp)
c     -------------------------------------------------------------------------
c     Bring DKNTMN into a reasonable range, so that ALPBMX is reasonable.
c     DKNTMN cannot be greater than the limits below, because
c        NBACKG >= NBCKMN is imposed later.
c     -------------------------------------------------------------------------
      if (nbckmn .lt. 4) call errmes (24, 4, chsubp)
      dkntmn(ikntmn) = amin1((ppmst-ppmend) / float(nbckmn - 3),
     1                       dkntmn(ikntmn))
C     -------------------------------------------------------------------------
C     This rescaling is necessary, because the scaling of alphaB with
C       knot spacing is still not invariant.
c     Assume that the ALPB* are originally set for DKNTMN_STANDARD.
C     -------------------------------------------------------------------------
      scale = (DKNTMN(IKNTMN) / DKNTMN_standard)**3
      ALPBMX = ALPBMX * scale
      ALPBMn = ALPBMn * scale
      ALPBst = ALPBst * scale
      ALPBpn = ALPBpn * scale
C     -------------------------------------------------------------------------
c     Fix phases for absolute-value spectra.
C     -------------------------------------------------------------------------
      if (absval) then
         fwhmst = sqrt(3.) * fwhmst
         fwhmmx = sqrt(3.) * fwhmmx
         degzer = 0.
         degppm = 0.
         sddegz = 0.
         sddegp = 0.
      end if
      sddegp_input = sddegp
c     -------------------------------------------------------------------------
c     Red herring; nothing will be done here.
      if (lwfft .gt. 0) npar = npar + 32
c     -------------------------------------------------------------------------
C     -------------------------------------------------------------------------
c     Set DOWS according to IAVERG
C     -------------------------------------------------------------------------
      if (iaverg .eq. 1   .or.   iaverg .eq. 4) then
         dows = .true.
      else if (iaverg .eq. 2) then
         dows = .false.
      else if (iaverg .ne. 0   .and.   iaverg .ne. 3   .and.
     1         iaverg .ne. 31   .and.   iaverg .ne. 32) then
         call errmes (13, 4, chsubp)
      end if
C     -------------------------------------------------------------------------
c     Check and order dimensions ND* I* *SK
C     -------------------------------------------------------------------------
      if (min0(ndrows, ndcols, ndslic, icolst, icolen, irowst,
     1         irowen, islice) .le. 0) call errmes (9, 4, chsubp)
      i1 = irowst
      irowst = min0(irowst, irowen)
      irowen = max0(i1, irowen)
      i1 = icolst
      icolst = min0(icolst, icolen)
      icolen = max0(i1, icolen)
      if (icolen .gt. ndcols   .or.   irowen .gt.  ndrows   .or.
     1    islice .gt. ndslic) call errmes (10, 4, chsubp)
      nvoxsk = min0(nvoxsk, mvoxsk)
      do 310 j = 1, nvoxsk
         if (min0(irowsk(j), icolsk(j)) .le. 0   .or.
     1       irowsk(j) .gt. ndrows   .or.
     2       icolsk(j) .gt. ndcols) call errmes (14, 4, chsubp)
 310  continue
C     -------------------------------------------------------------------------
c     Check L* & FIL* (except FILBAS, because test conversion only will not
c       have it).
C     -------------------------------------------------------------------------
      if (lps .gt. 0   .and.   filps .eq. ' ')
     1      call errmes (3, -4, chsubp)
      if (lcoord .gt. 0   .and.   filcoo .eq. ' ')
     1      call errmes (4, 4, chsubp)
      if (lcoraw .gt. 0   .and.   filcor .eq. ' ')
     1      call errmes (11, 4, chsubp)
      if (lcsv .gt. 0   .and.   filcsv .eq. ' ')
     1      call errmes (15, 4, chsubp)
      if (ltable .gt. 0   .and.   filtab .eq. ' ')
     1      call errmes (5, 4, chsubp)
      if (lraw .le. 0   .or.   filraw .eq. ' ')
     1      call errmes (6, 4, chsubp)
      if ((dows .or. doecc   .or.   unsupr)   .and.
     1    (lh2o .le. 0   .or.   filh2o .eq. ' '))
     2      call errmes (7, 4, chsubp)
      if (imethd .eq. 2   .and.
     1    (ipowrg .ne. 1   .and.   ipowrg .ne. 2))
     2   call errmes (23, 4, chsubp)
      linerr_mycont = linerr
      return
 801  call errmes (1, -4, chsubp)
 802  call errmes (2, -4, chsubp)
      end
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      subroutine check_zero_voxels ()
c
c Go through all voxels RAW file and set ZERO_VOXEL(IVOXEL)=T for zero voxels.
c
      INCLUDE 'lcmodel.inc'
      CHARACTER FMTDAT*(MCHFmt), ID*(MCHID)
      LOGICAL bruker, seqacq
c
      NAMELIST /NMID/ ID, FMTDAT, TRAMP, VOLUME, SEQACQ, BRUKER
      CHSUBP='ZEROVX'
c
C     -------------------------------------------------------------------------
C     Open LRAW
c     (2cygwin does not left-shift below; others do)
C     -------------------------------------------------------------------------
C     IF (FILRAW .NE. ' ') OPEN (LRAW, FILE=FILRAW, STATUS='OLD',!sun
C    1                           err=803)!sun
      IF (FILRAW .NE. ' ') OPEN (LRAW, FILE=FILRAW, STATUS='OLD',!Cyg
     1                           err=803)!Cyg
C      IF (FILRAW .NE. ' ') OPEN (LRAW, FILE=FILRAW, STATUS='OLD',!OSF
C     1                           READONLY, err=803)!OSF
C      IF (FILRAW .NE. ' ') OPEN (LRAW, FILE=FILRAW, STATUS='OLD',!IRIX
C     1                           READONLY, err=803)!IRIX
C     -------------------------------------------------------------------------
C     Read time-domain data into DATAT.
C     -------------------------------------------------------------------------
      READ (LRAW, NML=NMID, err=804, end=804)
      IF (FMTDAT .EQ. ' ') CALL ERRMES (1, 4, CHSUBP)
      ivoxel = 0
      do 110 idslic = 1, ndslic
         do 120 idrow = 1, ndrows
            do 130 idcol = 1, ndcols
               ivoxel = ivoxel + 1
               if (ivoxel .gt. mvoxel) call errmes (2, 4, chsubp)
               zero_voxel(ivoxel) = .false.
               READ (LRAW, FMTDAT, err=805, end=805)
     1                 (DATAT(J),J=1,NUNFIL)
               do 150 j = 1, nunfil
                  if (real(datat(j))**2 + aimag(datat(j))**2 .gt. 0.)
     1                  go to 130
 150           continue
               zero_voxel(ivoxel) = .true.
 130        continue
 120     continue
 110  continue
      rewind lraw
      return
 803  call errmes (3, 4, chsubp)
 804  call errmes (4, 4, chsubp)
 805  call errmes (5, 4, chsubp)
      end
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      subroutine average ()
c
c Called when IAVERG>=1.
c
c IAVERG  normalize  weight
c    1       Y         Y  (need DOWS=T) (as in phased-array)
c    2       N         Y
c    3       N         N
c    4       Y         N  (hard to imagine a use)
c IAVERG = 2 or 3 could be used for a series of Philips or Elscint scans.
c          2 forces DOWS=F.
c          3 sums DATAT (and, if present) H2OT and then does ECC or WS with
c            final sums and not individual "voxels".
c          31 or 32 is the same as IAVERG=3, except that only the odd or even
c            voxels are summed.  These can be used with Philips data to
c            sum only the "OFF" spectra.
c
c Averages (phased-array) spectra stored in CSI format in DATAT, then
c    puts the average in DATAT and sets NDCOLS, etc to single-voxel values.
c Uses AREAWA for weighting according to signal strength.  All signals are 1st
c    normalized, so that the weights (for normalized DATAT) are 1/VAR.
C Cannot do weighted average of H2OT: phases vary greatly among channels.
c    However, normalizing DATAT means that AREA_WATER=1 (see Notes of 110311).
c
      INCLUDE 'lcmodel.inc'
      external areawa
      parameter (mchannel=2048)
      logical avgh2o
      real channel_rms(mchannel), channel_signal(mchannel)
      chsubp = 'AVERAG'
c     ------------------------------------------------------------------------
c     PPMINC, NDATA, FNDATA & RADIAN are needed by AREAWA
c     ------------------------------------------------------------------------
      PPMINC = DELTAT * float(2 * nunfil) * HZPPPM
      IF (PPMINC .LE. 0.) CALL ERRMES (1, 4, CHSUBP)
      PPMINC=1./PPMINC
      PI=3.141592654D0
      RADIAN=PI/180.
      NDATA=2*NUNFIL
      fndata = float(ndata)
      voxel1 = .true.
      lraw_at_top = .true.
      lprint_sav = lprint
      lprint = 0
      nterm = nback(1) - nback(2) + 1
      if (nterm .lt. 20   .or.   min0(nback(1), nback(2)) .lt. 0)
     1       call errmes (2, 4, chsubp)
      jvoxel = 0
      nchannel_used = 0
      avgh2o = (iaverg .eq. 3   .or.   iaverg .eq. 31   .or.
     1          iaverg .eq. 32)   .and.   (doecc .or. dows)
c     -------------------------------------------------------------------------
c     DATAT_WORK: weighted DATAT will be accumulated here.
c     H2OF_WORK: Unweighted sum of H2OTs accumulated here when
c                 IAVERG=3, 31 or 32.
c     -------------------------------------------------------------------------
      do 150 junfil = 1, nunfil
         datat_work(junfil) = (0.,0.)
         h2of_work(junfil) = (0.,0.)
 150  continue
      sumwt = 0.
      do 210 idslic = 1, ndslic
         do 220 idrow = 1, ndrows
            do 230 idcol = 1, ndcols
               jvoxel = jvoxel + 1
               call mydata ()
               avgh2o = avgh2o   .and.   havh2o
c              ----------------------------------------------------------------
c              DOWS=T is set in MYCONT if IAVERG=1 or 4.
c              ----------------------------------------------------------------
               if (.not.havh2o   .and.
     1             (iaverg .eq. 1   .or.   iaverg .eq. 4))
     2            call errmes (3, 4, chsubp)
               voxel1 = .false.
               lraw_at_top = .false.
               if (idrow .lt. irowst   .or.
     2             idrow .gt. irowen   .or.
     3             idcol .lt. icolst   .or.
     4             idcol .gt. icolen   .or.
     5             idslic .ne. islice   .or.
     6             zero_voxel(jvoxel)) go to 230
               do 235 j = 1, nvoxsk
                  if (idrow .eq. irowsk(j)   .and.
     2                idcol .eq. icolsk(j)) go to 230
 235           continue
               if (iaverg .eq. 31   .and.   mod(jvoxel, 2) .eq. 0)
     1            go to 230
               if (iaverg .eq. 32   .and.   mod(jvoxel, 2) .eq. 1)
     1            go to 230
               nchannel_used = nchannel_used + 1
               if (nchannel_used .gt. mchannel)
     1            call errmes (4, 4, chsubp)
               if (iaverg .eq. 1   .or.   iaverg .eq. 4) then
                  channel_signal(nchannel_used) = areawa(1)
               else
                  channel_signal(nchannel_used) = 1.
               end if
               if (channel_signal(nchannel_used) .le. 0.)
     1            call errmes (5, 4, chsubp)
c              ---------------------------------------------------------------
c              Normalize DATAT
c              ---------------------------------------------------------------
               do 240 j = 1, nunfil
                  datat(j) = datat(j) / channel_signal(nchannel_used)
 240           continue
               if (iaverg .gt. 2) then
                  channel_rms(nchannel_used) = 1.
               else
                  term = getvar()
                  if (term .le. 0.) call errmes (6, 4, chsubp)
                  channel_rms(nchannel_used) = sqrt(term /
     1                                             float(2 * nterm - 4))
                  if (channel_rms(nchannel_used) .le. 0.)
     1                 call errmes (7, 4, chsubp)
               end if
               term = channel_rms(nchannel_used)**2
               if (term .le. 0.) call errmes (9, 4, chsubp)
               channel_wt = 1. / term
c              --------------------------------------------------------------
c              The following is the popular weighting proportional to signal
c                 discussed by Wright & Wald
c                 channel_wt = channel_signal(nchannel_used)**2
c              --------------------------------------------------------------
               sumwt = sumwt + channel_wt
               do 250 junfil = 1, nunfil
                  datat_work(junfil) = datat_work(junfil) +
     1                                 channel_wt * datat(junfil)
                  if (avgh2o) h2of_work(junfil) = h2of_work(junfil) +
     1                                            h2ot(junfil)
 250           continue
 230        continue
 220     continue
 210  continue
      if (iaverg .eq. 31   .or.   iaverg .eq. 32)   then
         if (nchannel_used .lt. ndrows * ndcols / 2)
     1      call errmes (8, 2, chsubp)
      else if (nchannel_used .lt. ndrows * ndcols) then
         call errmes (8, 2, chsubp)
      end if
      if (ldump(1)) then
         write (6, 5310) (j, channel_signal(j), channel_rms(j),
     1                     1. / channel_rms(j),  j = 1, nchannel_used)
 5310    format('ch#', 8x, 'areawa', 11x, 'rms', 4x, 'sgnl/noise' /
     2          (i3, 1p3e14.4))
      end if
c     ------------------------------------------------------------------------
c     SUMWT = 0 would most likely be caused by excluding all (non-zero)
c               voxels.
c     ------------------------------------------------------------------------
      if (sumwt .le. 0) call errmes (10, 4, chsubp)
      do 360 j = 1, nunfil
         datat(j) = datat_work(j) / sumwt
         if (avgh2o) h2ot(j) = h2of_work(j) / sumwt
 360  continue
      if (doecc   .and.   avgh2o) call ecc_truncate ()
      lprint = lprint_sav
      ndslic = 1
      ndrows = 1
      ndcols = 1
      islice = 1
      irowst = 1
      irowen = 1
      icolst = 1
      icolen = 1
      end
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      real function getvar ()
c
c Computes variance of noise near end of DATAT, determined by NBACK(2), using
c    SSQ of linear regression (Draper & Smith, p 16).
c Must have already verified that NBACK(1)-NBACK(2) > 20
c Called (twice) from AVERAGE.
c
      INCLUDE 'lcmodel.inc'
      double precision dnterm, drn, sx, sxx, sy(2), sxy(2), syy(2),
     1                 yv(2)
c
      do 110 k = 1, 2
         sy(k) = 0.
         sxy(k) = 0.
         syy(k) = 0.
 110  continue
      sx = 0.
      sxx = 0.
      dnterm = 0.d0
      do 210 junfil = nunfil - nback(1), nunfil - nback(2)
         dnterm = dnterm + 1.d0
         sx = sx + dnterm
         sxx = sxx + dnterm**2
         yv(1) = dble(real(datat(junfil)))
         yv(2) = dble(aimag(datat(junfil)))
         do 220 k = 1, 2
            sy(k) = sy(k) + yv(k)
            sxy(k) = sxy(k) + dnterm * yv(k)
            syy(k) = syy(k) + yv(k)**2
 220     continue
 210  continue
      getvar = 0.
      drn = 1.d0 / dnterm
      do 310 k = 1, 2
c        ---------------------------------------------------------------------
c        From Draper & Smith, p 16.
c        ---------------------------------------------------------------------
         getvar = getvar + syy(k) - drn * sy(k)**2 -
     1                     (sxy(k) - drn * sx * sy(k))**2 /
     2                     (sxx - drn * sx**2)
 310  continue
      end
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      subroutine restore_settings ()
c
c When VOXEL1 = T, saves settings that will be changed.
c When VOXEL1 = F, restores settings that have been changed.
c
      INCLUDE 'lcmodel.inc'
      save chrato_sav, degppm_sav, degzer_sav,
     1     fcalib_sav, fwhmst_sav,
     1     hzref_sav, lcoord_sav, lcoraw_sav,
     1     lprint_sav,
     1     ltable_sav, miter1_sav, ndegz_sav, ndgppm_sav,
     1     nlin_sav, nnolsh_sav, nnot1_sav, npar_sav,
     1     nrefpk_sav, ppmref_sav, sdmshf_sav,
     1     title_sav
      character chrato_sav(mmetab)*(264), title_sav*244
      integer ndegz_sav(2), ndgppm_sav(3), nrefpk_sav(2)
      real hzref_sav(mrefpk,2), ppmref_sav(mrefpk,2)
c
      if (voxel1) then
         do 102 j = 1, nratio
            chrato_sav(j) = chrato(j)
 102     continue
         degppm_sav = degppm
         degzer_sav = degzer
c        ----------------------------------------------------------------------
C        DGPPM*_ORIG will be used globally and not reset (or restored)
c        ----------------------------------------------------------------------
         dgppmn_orig = dgppmn
         dgppmx_orig = dgppmx
         fcalib_sav = fcalib
         fwhmst_sav = fwhmst
         lcoord_sav = lcoord
         lcoraw_sav = lcoraw
c         ldwfft_sav = ldwfft
         lprint_sav = lprint
         ltable_sav = ltable
c         lwfft_sav = lwfft
         miter1_sav = miter(1)
         nlin_sav = nlin
         nnolsh_sav = nnolsh
         nnot1_sav = nnot1
         npar_sav = npar
         sdmshf_sav = sdmshf
         do 110 jset = 1, 2
            ndegz_sav(jset) = ndegz(jset)
            ndgppm_sav(jset) = ndgppm(jset)
            nrefpk_sav(jset) = nrefpk(jset)
            do 120 jpeak = 1, min0(mrefpk, nrefpk(jset))
               hzref_sav(jpeak, jset) = hzref(jpeak, jset)
               ppmref_sav(jpeak, jset) = ppmref(jpeak, jset)
 120        continue
c           -------------------------------------------------------------------
C           SHIFM*_ORIG will be used globally and not reset (or restored)
c           -------------------------------------------------------------------
            shifmn_orig(jset) = shifmn(jset)
            shifmx_orig(jset) = shifmx(jset)
 110     continue
         title_sav = title
      else
         do 202 j = 1, nratio
            chrato(j) = chrato_sav(j)
 202     continue
c        ---------------------------------------------------------------------
c             DEGPPM & DEGZER = 0 at the end of an analysis, because of calls
c        to REPHAS.  So, if they are input, they must be restrored from 0,
c        unless they are non-zero here, in which case they have been set in
c        UPDATE_PRIORS for this analysis and should be left unchanged.
c        ---------------------------------------------------------------------
         if (amax1(abs(degppm), abs(degzer)) .lt. 1.e-5) then
            degppm = degppm_sav
            degzer = degzer_sav
         end if
         fcalib = fcalib_sav
         fwhmst = fwhmst_sav
         lcoord = lcoord_sav
         lcoraw = lcoraw_sav
c         ldwfft = ldwfft_sav
c         linerr = 0
         linerr = linerr_mycont
         linetc = 0
         lintbl = 0
         lprint = lprint_sav
         ltable = ltable_sav
c         lwfft = lwfft_sav
         miter(1) = miter1_sav
         nermes = linerr_mycont
         nlin = nlin_sav
         nnolsh = nnolsh_sav
         nnot1 = nnot1_sav
         npar = npar_sav
         sdmshf = sdmshf_sav
         do 210 jset = 1, 2
            ndegz(jset) = ndegz_sav(jset)
            ndgppm(jset) = ndgppm_sav(jset)
            nrefpk(jset) = nrefpk_sav(jset)
            do 220 jpeak = 1, min0(mrefpk, nrefpk(jset))
               hzref(jpeak, jset) = hzref_sav(jpeak, jset)
               ppmref(jpeak, jset) = ppmref_sav(jpeak, jset)
 220        continue
 210     continue

         do 230 j = linerr_mycont + 1, mmerm9
            nerror(j) = 0
 230     continue
         title = title_sav
      end if
      area_met_norm = 0.
      istago = 0
      nratio_used = 0
      wsdone = .false.
      do 320 j = 1, 2
         phitot(j) = 0.
 320  continue
      end
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      subroutine update_priors ()
c
c      Use sample variances to update priors for DEGZER, DEGPPM & SHIFM*.
c      Only have to accumulate sums and sums of squares for SDDEGP & SHIFM*.
c      For SDDEGZ, must accumulate sums of sin & cos, then compute mean angle,
c and then compute variance from mean, since angle must be chosen to be
c closest to mean.
c SUM(J) & SUM2(J): J = 1 for shift
c                       2     DEGPPM
c                       3     cos(DEGZER) (no SUM2)
c                       4     sin(DEGZER)
c
      INCLUDE 'lcmodel.inc'
      parameter (msamples=4096)
      save degzer_sample, initial, nsamples, rppminc_shift,
     1     sddegp_min, sddegz_min, sum, sum2
      logical initial
      real degzer_sample(msamples), sd(2), smean(2),
     1     sum(4), sum2(3)
      data nsamples/0/, sum/4*0./, sum2/3*0./
      data initial/.true./
c     -------------------------------------------------------------------------
c     The following are somewhat arbitrary and may have to be changed.
c     -------------------------------------------------------------------------
      data rppminc_shift/5./, sddegp_min/1./, sddegz_min/3./
      chsubp = 'UPDPRI'

      if (nsamples .ge. msamples) return

      if (lcsi_sav_2 .eq. 13   .and.   initial) then
         initial = .false.
 5150    format (i5)
         read (13, 5150, err=150, end=160) nsamples
         read (13, 5160, err=150, end=150) sum, sum2,
     1      (degzer_sample(j), j = 1, nsamples)
 5160    format (1p5e16.6)
         go to 160
 150     call errmes (1, 4, chsubp)
      end if
 160  nsamples = nsamples + 1
      term = ppminc * float(ishifd)
      sum(1) = sum(1) + term
      sum2(1) = sum2(1) + term**2

      sum(2) = sum(2) + phitot(2)
      sum2(2) = sum2(2) + phitot(2)**2

      degzer_sample(nsamples) = phitot(1)
      term = cos(radian * phitot(1))
      sum(3) = sum(3) + term
      term = sin(radian * phitot(1))
      sum(4) = sum(4) + term

      if (lcsi_sav_2 .eq. 13) then
         rewind 13
         write (13, 5150) nsamples
         write (13, 5160) sum, sum2, (degzer_sample(j), j = 1, nsamples)
      end if

      if (nsamples .lt. max0(2, mnsamp)) return

c     ------------------------------------------------------------------------
c     j = 1 for shift; j = 2 for DEGPPM
c     ------------------------------------------------------------------------
      do 210 j = 1, 2
         smean(j) = sum(j) / float(nsamples)
         sd(j) = rsdsam(j) *
     1           sqrt(amax1(0.,
     1                      (sum2(j) - smean(j)**2 * float(nsamples)) /
     2                      float(nsamples - 1)))
 210  continue
      sd(1) = amax1(rppminc_shift * ppminc, sd(1))
c     ------------------------------------------------------------------------
c     Keep SHIFM* within bounds of SHIFM*, to avoid excessive shift ranges.
c     ------------------------------------------------------------------------
      do 220 j = 1, 2
         shifmn(j) = amin1(shifmx_orig(j),
     1                     amax1(smean(1) - sd(1), shifmn_orig(j)))
         shifmx(j) = amax1(shifmn_orig(j),
     1                     amin1(smean(1) + sd(1), shifmx_orig(j)))
 220  continue
      degppm = smean(2)
      dgppmx = amax1(degppm, dgppmx_orig)
      dgppmn = amin1(degppm, dgppmn_orig)
c     ------------------------------------------------------------------------
c     Do not allow SDDEGP to exceed SDDEGP_INPUT (presumably <=20) to avoid
c     destabilizing the analysis (Notes of 090201)
c     ------------------------------------------------------------------------
      sddegp = amin1(sddegp_input, amax1(sd(2), sddegp_min))
c     ------------------------------------------------------------------------
c     DEGZER
c     ------------------------------------------------------------------------
      degzer = atan2(sum(4), sum(3)) / radian
c     ------------------------------------------------------------------------
c     Make DEGZER between 0 and 360 (as DEGZER_SAMPLE already is).
c     ------------------------------------------------------------------------
      if (degzer .lt. 0.) degzer = degzer + 360.
      sum2(3) = 0.
      do 250 j = 1, nsamples
         term = degzer_sample(j) - degzer
         sum2(3) = sum2(3) + amin1(abs(term), abs(term + 360.),
     1                                        abs(term - 360.))**2
 250  continue
      sd(1) = rsdsam(3) * sqrt(sum2(3) / float(nsamples - 1))
      sddegz = amax1(sd(1), sddegz_min)

      if (lcsi_sav_1 .eq. 12) then
         rewind 12
         read (12, 5150) j
         write (12, 5160) degppm, degzer, dgppmn, dgppmx,
     1                    sddegp, sddegz, shifmn, shifmx
      end if
      end
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      subroutine open_output ()
      INCLUDE 'lcmodel.inc'
      EXTERNAL ILEN
      save lchcol, lchrow, lchslic,
     1     lchcol_st, lchrow_st, lchslic_st,
     2     splcoo, splcor, splpri, splps, spltab
      CHARACTER CHSTR*40, chidcol*6, chidrow*6, chidslic*6,
     1          chinsert*36, ch256*256,
     2          splcoo(2)*(mchfil+1), splcor(2)*(mchfil+1),
     3          splpri(2)*(mchfil+1),
     4          splps(2)*(mchfil+1), spltab(2)*(mchfil+1)
      integer jtitle(2)
C
      include 'nml_lcmodl.inc'
      include 'nml_lcmodel.inc'
      CHSTR = ' '
      chsubp = 'OPENOU'
C     -------------------------------------------------------------------------
c     Get date & time info.
C     -------------------------------------------------------------------------
      CHDATE=' '
C      call idate (knum) !sun
C      call getdate(chdate) !sun
       call fdate(chdate)!Cyg
C      call y2k !OSF
C      call y2k !IRIX
C     -------------------------------------------------------------------------
c     Modify TITLE and filenames to include information on voxel coordinates.
c     This will be done unless the data set is a single-voxel one, i.e.,
c       unless SINGLE_VOXEL = T.
C     -------------------------------------------------------------------------
      if (.not.single_voxel) then
         if (voxel1) then
            if (lcoord .gt. 0) call split_filename(filcoo, 'coord',
     1                           'COORD', 'Coord', 5, splcoo)
            if (lcoraw .gt. 0) call split_filename(filcor, 'coraw',
     1                           'CORAW', 'Coraw', 5, splcor)
            if (lprint .gt. 0) call split_filename(filpri, 'print',
     1                           'PRINT', 'Print', 5, splpri)
            if (lps .gt. 0) call split_filename(filps, 'ps',
     1                                          'PS', 'Ps', 2, splps)
            if (ltable .gt. 0) call split_filename(filtab, 'table',
     1                           'TABLE', 'Table', 5, spltab)
            lchslic_st = icharst(chslic, len(chslic))
            lchrow_st = icharst(chrow, len(chrow))
            lchcol_st = icharst(chcol, len(chcol))
            lchcol = ilen(chcol)
            lchrow = ilen(chrow)
            lchslic = ilen(chslic)
         end if
         call chstrip_int6(idcol, chidcol, lidcol)
         call chstrip_int6(idrow, chidrow, lidrow)
         call chstrip_int6(idslic, chidslic, lidslic)
         if (ndslic .gt. 1) then
            ch256 = 'Slice#' // chidslic(:lidslic) //
     1              ' Row#' // chidrow(:lidrow) //
     2              ' Col#' // chidcol(:lidcol) // '  ' // title
         else
            ch256 = 'Row#' // chidrow(:lidrow) //
     1              ' Col#' // chidcol(:lidcol) // '  ' // title
         end if
         title = ch256

         if (lchslic_st .gt. 0) then
            chinsert = chslic(lchslic_st:lchslic) // chidslic(:lidslic)
         else
            chinsert = chidslic(:lidslic)
         end if
         if (lchrow_st .gt. 0) then
            lstr = ilen(chinsert)
            chinsert = chinsert(:lstr) // chrow(lchrow_st:lchrow)
         end if
         lstr = ilen(chinsert)
         chinsert = chinsert(:lstr) // chidrow(:lidrow)
         if (lchcol_st .gt. 0) then
            lstr = ilen(chinsert)
            chinsert = chinsert(:lstr) // chcol(lchcol_st:lchcol)
         end if
         lstr = ilen(chinsert)
         chinsert = chinsert(:lstr) // chidcol(:lidcol)
         linsert = ilen(chinsert)

         if (lcoord .gt. 0) then
            lsplit1 = ilen(splcoo(1))
            lsplit2 = ilen(splcoo(2))
            if (lsplit1 + linsert + lsplit2 .gt. mchfil)
     1         call errmes (1, 4, chsubp)
            filcoo = splcoo(1)(:lsplit1) // chinsert(:linsert) //
     1               splcoo(2)(:lsplit2)
         end if
         if (lcoraw .gt. 0) then
            lsplit1 = ilen(splcor(1))
            lsplit2 = ilen(splcor(2))
            if (lsplit1 + linsert + lsplit2 .gt. mchfil)
     1         call errmes (1, 4, chsubp)
            filcor = splcor(1)(:lsplit1) // chinsert(:linsert) //
     1               splcor(2)(:lsplit2)
         end if
         if (lprint .gt. 0) then
            lsplit1 = ilen(splpri(1))
            lsplit2 = ilen(splpri(2))
            if (lsplit1 + linsert + lsplit2 .gt. mchfil)
     1         call errmes (1, 4, chsubp)
            filpri = splpri(1)(:lsplit1) // chinsert(:linsert) //
     1               splpri(2)(:lsplit2)
         end if
         if (lps .gt. 0) then
            lsplit1 = ilen(splps(1))
            lsplit2 = ilen(splps(2))
            if (lsplit1 + linsert + lsplit2 .gt. mchfil)
     1         call errmes (1, 4, chsubp)
            filps = splps(1)(:lsplit1) // chinsert(:linsert) //
     1               splps(2)(:lsplit2)
         end if
         if (ltable .gt. 0) then
            lsplit1 = ilen(spltab(1))
            lsplit2 = ilen(spltab(2))
            if (lsplit1 + linsert + lsplit2 .gt. mchfil)
     1         call errmes (1, 4, chsubp)
            filtab = spltab(1)(:lsplit1) // chinsert(:linsert) //
     1               spltab(2)(:lsplit2)
         end if
      end if
      if (skip_voxel) then
c        ---------------------------------------------------------------------
c        Temporarily prevent opening output files and return.
c        LPS is left unchanged, because it would only be produced on
c          an error exit.
c        ---------------------------------------------------------------------
         lcoord = 0
         lcoraw = 0
         lprint = 0
         ltable = 0
         return
      end if
c     -------------------------------------------------------------------------
c     NLIN = 16384
c     -------------------------------------------------------------------------
      if (nratio_used .gt. 0) then
         nlin = 4 * nlin + 8192
      else
         nlin = 4 * nlin + 16384
      end if
c     -------------------------------------------------------------------------
c     Split TITLE into TITLE_LINE(1) & TITLE_LINE(2).
c     -------------------------------------------------------------------------
      call split_title ()
      JOWNER=ILEN(OWNOUT)
      JDATE=ILEN(CHDATE)
      JVERSI=INDEX(VERSIO,'Copyright')-2
      JTITLE(1)=ILEN(TITLE_line(1))
      JTITLE(2)=ILEN(TITLE_line(2))
      IF (LPRINT .GT. 0) THEN
         IF (FILPRI .NE. ' ') OPEN (LPRINT, FILE=FILPRI,
     1                              STATUS='UNKNOWN', err=802)
         if (nlines_title .eq. 1) then
            WRITE (LPRINT,5000) VERSIO,
     1                          TITLE_line(1)(1:JTITLE(1)),
     2                          OWNOUT(1:JOWNER), CHDATE(1:JDATE)
 5000       FORMAT (///10X,A//1X,A//1X,A//1X,A////)
         else
            WRITE (LPRINT,5002) VERSIO,
     1            (TITLE_line(j)(1:JTITLE(j)), j=1,2),
     2            OWNOUT(1:JOWNER), CHDATE(1:JDATE)
 5002       FORMAT (///10X,A//1X,A/1x,a//1X,A//1X,A////)
         end if
         if (mermes .eq. 8000) then
            mermes = mmerms
            WRITE (LPRINT, NML=LCMODL)
         else
            WRITE (LPRINT, NML=LCMODeL)
         END IF
      END IF
      IF (LCOORD .GT. 0) THEN
         IF (FILCOO .NE. ' ') OPEN (LCOORD, FILE=FILCOO,
     1                              STATUS='UNKNOWN', err=803)
         WRITE (LCOORD,5580) VERSIO,
     1            (TITLE_line(j)(1:JTITLE(j)), j=1,nlines_title)
C         write (lcoord, 5580) OWNOUT(1:JOWNER), CHDATE(1:JDATE)!sun
C         write (lcoord, 5580) OWNOUT(1:JOWNER), CHDATE(1:JDATE)!IRIX
C         write (lcoord, 5580) OWNOUT(1:JOWNER), CHDATE(1:JDATE)!OSF
 5580    FORMAT (1X, A)
      END IF
      IF (LCORAW .GT. 0) THEN
         IF (FILCOR .NE. ' ') OPEN (LCORAW, FILE=FILCOR,
     1                              STATUS='UNKNOWN', err=805)
      END IF
      IF (LTABLE .GT. 0) THEN
         IF (FILTAB .NE. ' ') OPEN (LTABLE, FILE=FILTAB,
     1                              STATUS='UNKNOWN', err=804)
         WRITE (LTABLE,5580) VERSIO(1:JVERSI),
     1            (TITLE_line(j)(1:JTITLE(j)), j=1,nlines_title)
C         write (ltable, 5580) OWNOUT(1:JOWNER), CHDATE(1:JDATE)!sun
C         write (ltable, 5580) OWNOUT(1:JOWNER), CHDATE(1:JDATE)!IRIX
C         write (ltable, 5580) OWNOUT(1:JOWNER), CHDATE(1:JDATE)!OSF
      END IF
c     -------------------------------------------------------------------------
c     NPAR = 20
c     -------------------------------------------------------------------------
      if (ldwfft .gt. 0) then
         npar = 2 * npar + 40
      else
         npar = npar + 20
      end if
      return
 802  call errmes (2, 4, chsubp)
 803  call errmes (3, 4, chsubp)
 804  call errmes (4, 4, chsubp)
 805  call errmes (5, 4, chsubp)
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE split_filename (filename, chtype1, chtype2, chtype3,
     1                           lchtype, split)
C
c Splits FILENAME into 2 parts into SPLIT for insertion of voxel
c   identifier between the 2 parts.
c CHTYPE1-3 are the 3 typical variations in the file type, e.g., ps PS Ps.
c LCHTYPE = length of strings chtype*; they must all have the same length.
c There are 3 cases for the multi-voxel identifier (CHINSERT) to be inserted.
c
      EXTERNAL ILEN
      character char*1, chtype1*5, chtype2*5, chtype3*5, filename*(*),
     1          split(2)*(*)
c
      lfile = ilen(filename)
      ichtype = lfile - lchtype + 1
      if (max0(index(filename(ichtype:), chtype1(:lchtype)),
     1         index(filename(ichtype:), chtype2(:lchtype)),
     2         index(filename(ichtype:), chtype3(:lchtype))) .eq. 1)
     3      then
c        ---------------------------------------------------------------------
c        CHTYPE is at the end of filename, as it normally should be.  Check
c          for two cases:
c        ---------------------------------------------------------------------
         islash_dot = ichtype - 1
         char = filename(islash_dot: islash_dot)
         if (char .eq. '/') then
c           ------------------------------------------------------------------
c           (1) Default LCMgui FILENAME, e.g., (...)/ps.  Split as
c               (...)/ | ps and insert (chinsert). to get
c               (...)/(chinsert).ps
c           ------------------------------------------------------------------
            split(1) = filename(:islash_dot)
            split(2) = '.' // filename(ichtype:)
            return
         end if
         if (char .eq. '.') then
c           ------------------------------------------------------------------
c           (2) Alternate LCMgui FILENAME, e.g., (...).ps.  Split as
c               (...) | .ps and insert _(chinsert) to get
c               (...)_(chinsert).ps
c           ------------------------------------------------------------------
            split(1) = filename(:islash_dot - 1) // '_'
            split(2) = filename(islash_dot:)
            return
         end if
      end if
c     ------------------------------------------------------------------------
c     (3) Exceptional FILENAME, e.g., (...).  Split as
c         (...) | ' ' and insert _(chinsert) to get
c         (...)_(chinsert)
c     ------------------------------------------------------------------------
      split(1) = filename(:lfile) // '_'
      split(2) = ' '
      end
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      integer function icharst(ch, lch)
c
c Returns index of first non-space charcter in CH
c         -1 if ch(1:lch) are all spaces
c Normally this should be called by ICHARST(CH, LEN(CH)), but the 2nd argument
c   could also be < LEN(CH).
c
      character ch(*)
      do 110 j = 1, lch
         if (ch(j) .ne. ' ') then
            icharst = j
            return
         end if
 110  continue
      icharst = -1
      end
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      subroutine chstrip_int6(iarg, chi, leni)
c
c CHI = string with IARG value and no spaces of length LENI.
c     will be restricted to 6 characters, i.e., -99999 <= CHI value <= 999999
c     must be at least 6 characters long in calling program
c
      character chi*(*)
      i = max0(-99999, min0(999999, iarg))
      if (i .ge. 0   .and.   i .le. 9) then
         write(chi, 5001) i
         leni = 1
 5001    format(i1)
      else if (i .ge. -9   .and.   i .le. 99) then
         write(chi, 5002) i
         leni = 2
 5002    format(i2)
      else if (i .ge. -99   .and.   i .le. 999) then
         write(chi, 5003) i
         leni = 3
 5003    format(i3)
      else if (i .ge. -999   .and.   i .le. 9999) then
         write(chi, 5004) i
         leni = 4
 5004    format(i4)
      else if (i .ge. -9999   .and.   i .le. 99999) then
         write(chi, 5005) i
         leni = 5
 5005    format(i5)
      else
         write(chi, 5006) i
         leni = 6
 5006    format(i6)
      end if
      end
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE split_title ()
C
C  Split TITLE into TITLE_LINE(1) & TITLE_LINE(2).
c  TITLE_LINE(1), after call to STRCHK, will not have more than 122 characters.
C
      INCLUDE 'lcmodel.inc'
      EXTERNAL ILEN
      ltitle=ilen(title)
c     -------------------------------------------------------------------------
c     STRCHK can at most double the number of characters (if all have to be
c       escaped).
c     -------------------------------------------------------------------------
      if (ntitle .eq. 1   .or.   ltitle .le. 61) then
         nlines_title = 1
         title_line(1) = title
         return
      end if
      iend_line1 = min0(ltitle,122)
c     -------------------------------------------------------------------------
c     NESCAPE1 = extra escape characters that will be added to BUFOUT [and
c                therefore will reduce the allowed length of TITLE_LINE(1)].
c     -------------------------------------------------------------------------
      nescape = 0
      nescape1 = 0
      do 110 i = 1, ltitle
         IF (title(I:I).EQ.'('
     1     .OR.title(I:I).EQ.')'
     2     .OR.title(I:I).EQ.'%'
     3     .OR.title(I:I).EQ.'\') then
c
c          A ' to correct error in emacs display
c
            nescape = nescape + 1
            if (i .le. iend_line1) nescape1 = nescape1 + 1
         end if
 110  continue
      if (ltitle + nescape .le. 122) then
         nlines_title = 1
         title_line(1) = title
         return
      end if
c     -------------------------------------------------------------------------
c     Go backwards on TITLE_LINE(1) to find a space for a break.
c     MAX_BACK < 122, because above test ensures (LTITLE + NESCAPE) > 122
c     -------------------------------------------------------------------------
      max_back = 244 - ltitle - nescape
      iend_line1 = iend_line1 - nescape1
      ibreak = iend_line1
      istart2 = iend_line1 + 1
      do 120 i = iend_line1, max0(4, iend_line1 - max_back), -1
         if (title(i:i) .eq. ' ') then
            ibreak = i - 1
            istart2 = i + 1
            go to 150
         end if
 120  continue
 150  nlines_title = 2
      title_line(1) = title(1:ibreak)
      title_line(2) = title(istart2:ltitle)
      return
      end
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE LOADCH ()
C
C  Loads changes input in standard input into CHANGE for later output.
C
      INCLUDE 'lcmodel.inc'
      parameter (mch_line_long=mchsimul+12)
      EXTERNAL ILEN
      CHARACTER CH*(mCHLIN), CHLONG*(mch_line_long), DOLLAR*1,
     1          LINE*(mch_line_long), line_compact*(mch_line_long)
      LOGICAL ATEND
      CHSUBP='LOADCH'
      DOLLAR='$'
      IF (MERMES .GT. MMERMS) THEN
         CALL ERRMES (1, 3, CHSUBP)
         MERMES=MMERMS
      END IF
c     -------------------------------------------------------------------------
c     NLIN = 4 * 16384 - 1 = 65535
c     -------------------------------------------------------------------------
      if (lwfft .gt. 0) then
         nlin = 2 * nlin - 3
      else
         nlin = 4 * nlin - 1
      end if
      do 100 jpage = 1, 2
c        ----------------------------------------------------------------------
c        Put NCHLIN within the limits fixed below.
c        ----------------------------------------------------------------------
         nchlin(jpage) = min0(mchlin, max0(30, nchlin(jpage)))
         REWIND LCONTR_SCRATCH
         ATEND=.FALSE.
         LINCHG(JPAGE)=0
         DO 110 JLINE=1,9999
            READ (LCONTR_SCRATCH,5110, err=810, end=810) LINE
 5110       FORMAT (A)
            L=INDEX(LINE,DOLLAR)
            IF (L.GE.1 .AND. L.LE.mch_line_long-6) THEN
               IF((LINE(L+1:L+1).EQ.'L' .OR. LINE(L+1:L+1).EQ.'l') .AND.
     1            (LINE(L+2:L+2).EQ.'C' .OR. LINE(L+2:L+2).EQ.'c') .AND.
     1            (LINE(L+3:L+3).EQ.'M' .OR. LINE(L+3:L+3).EQ.'m') .AND.
     1            (LINE(L+4:L+4).EQ.'O' .OR. LINE(L+4:L+4).EQ.'o') .AND.
     1            (LINE(L+5:L+5).EQ.'D' .OR. LINE(L+5:L+5).EQ.'d') .AND.
     1            (LINE(L+6:L+6).EQ.'L' .OR. LINE(L+6:L+6).EQ.'l'))
     2                                                       GO TO 120
            END IF
 110     CONTINUE
         RETURN
C        ---------------------------------------------------------------------
C        $LCMODL has been found; $ is at position L.
C        ---------------------------------------------------------------------
 120     LEND=ILEN(LINE)
         DO 130 JLINE=1,MLINES
            IF (JLINE.GT.1 .OR. L+6.EQ.LEND) READ (LCONTR_SCRATCH, 5110,
     1                                             END=200) LINE
            IF (ilen(line).le.1 .AND. LINE(1:1).EQ.' ') GO TO 130
            call compact_string(line, line_compact, len_compact)
            if (ldump(3)) then
               j = ilen(line)
               write (6, 5130) line(1:j), len_compact,
     1                         line_compact(1:len_compact)
 5130          format (5x, a/ i3, 2x, a/)
            end if
            IF (MAX0(INDEX(line_compact,'TITLE='),
     1               INDEX(line_compact,'title='),
     2               INDEX(line_compact,'Title='),
     3               INDEX(line_compact,'OWNER='),
     4               INDEX(line_compact,'owner='),
     5               INDEX(line_compact,'Owner='),
     6               INDEX(line_compact,'KEY='),
     7               INDEX(line_compact,'key='),
     8               INDEX(line_compact,'Key=')) .GT. 0) GO TO 130
            if (index(line, '/.lcmodel/temp/') .gt. 0) then
               if (max0( index(line, 'filcoo='), index(line, 'filh2o='),
     1                   index(line, 'filpri='), index(line, 'filps='),
     2                   index(line, 'filraw='), index(line, 'filtab='),
     3                   index(line, 'filcor='), index(line, 'filcsv='),
     4                   index(line, 'lcsi_sav'),
     5                   index(line, 'filcsi_sav'))
     6             .gt. 0 )  go to 130
            end if
            L=INDEX(LINE,DOLLAR)
            IF (L.GE.1 .AND. L.LE.mch_line_long-3) THEN
               IF((LINE(L+1:L+1).EQ.'E' .OR. LINE(L+1:L+1).EQ.'e') .AND.
     1            (LINE(L+2:L+2).EQ.'N' .OR. LINE(L+2:L+2).EQ.'n') .AND.
     1            (LINE(L+3:L+3).EQ.'D' .OR. LINE(L+3:L+3).EQ.'d')) THEN
                  IF (L .le. 2) GO TO 200
                  CHLONG=LINE(1:L-1)
                  IF (ILEN(CHLONG) .LE. 1) GO TO 200
                  LINE=CHLONG
                  ATEND=.TRUE.
               END IF
            END IF
            LEND=ILEN(LINE)
            IF (LEND.le.1 .AND. LINE(1:1).EQ.' ') GO TO 130
            IF (LEND .LE. NCHLIN(JPAGE)) THEN
               NPARTS=1
            ELSE
               NPARTS=(LEND-NCHLIN(JPAGE)-1)/(NCHLIN(JPAGE)-3)+2
            END IF
            LINCHG(JPAGE)=LINCHG(JPAGE)+NPARTS
            IF (LINCHG(JPAGE) .GT. MLINES) GO TO 200
            LSTOP=MIN0(NCHLIN(JPAGE),LEND)
            CHANGE(LINCHG(JPAGE), jpage)=LINE(1:LSTOP)
            DO 150 JCHG=LINCHG(JPAGE)-1,LINCHG(JPAGE)-NPARTS+1,-1
               LSTART=LSTOP+1
               LSTOP=min0(lend, LSTART+NCHLIN(JPAGE)-4)
               CHANGE(JCHG, jpage)='   ' // LINE(LSTART:LSTOP)
 150        CONTINUE
            IF (ATEND) GO TO 200
 130     CONTINUE
C        ----------------------------------------------------------------------
C        Reverse order in CHANGE.
C        ----------------------------------------------------------------------
 200     K=LINCHG(JPAGE)
         DO 210 J=1,LINCHG(JPAGE)/2
            CH=CHANGE(K, jpage)
            CHANGE(K, jpage)=CHANGE(J, jpage)
            CHANGE(J, jpage)=CH
            K=K-1
 210     CONTINUE
 100  continue
c     -------------------------------------------------------------------------
c     NPAR = 2 * 20 + 10 = 50
c     -------------------------------------------------------------------------
      if (lwfft .gt. 0) then
         npar = 3 * npar + 40
      else
         npar = 2 * npar + 10
      end if
      IF (LPRINT .GT. 0) WRITE (LPRINT,5210)
     1                         (CHANGE(J,2),J=1,LINCHG(2))
 5210 FORMAT (/// 10X, 'Input changes to Control Variables'/ (1X,A))
      return
 810  call errmes (2, 4, chsubp)
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      subroutine compact_string (str_in, str_out, len_out)
c
c
c Remove all white space before, after and within a string.
c
      EXTERNAL ILEN
      character str_in*(*), str_out*(*)
      len_in = ilen(str_in)
      len_out = len_in
      str_out(1:len_in) = str_in(1:len_in)
      do 110 jtest = len_in, 1, -1
         if (str_in(jtest:jtest) .eq. ' ') then
            do 120 k = jtest, len_out - 1
               str_out(k:k) = str_out(k+1:k+1)
 120        continue
            len_out = len_out - 1
         end if
 110  continue
      end
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE DCFFT_R (DATAT, FT, N, LDWFFT,
     1                  DWFFTC)
C
C  Input:
C    DATAT(J), J=1,N
C    LDWFFT = argument in last call to CALL DFFTCI (LDWFFT, DWFFTC)
C  Output:
C    FT = FFT of DATAT WITH rearrangement.  The FFT is normalized; i.e.,
C             the sum is divided by sqrt(N).  This is compatible with CFFT
C             and CFFTIN and Siemens FFTs.
C
      COMPLEX*16 cterm, DATAT(N), FT(N)
      DOUBLE PRECISION DWFFTC(4*N+15)
      IF (N .NE. LDWFFT) THEN
         CALL DFFTCI (N, DWFFTC)
         LDWFFT=N
      END IF
      CALL DF2TCF (N, DATAT, FT, DWFFTC)
C     ------------------------------------------------------------------------
C     Scale & rearrange
C     ------------------------------------------------------------------------
      FACT=1./SQRT(FLOAT(N))
      nunfil = n / 2
      DO 210 J=1,nunfil
         CTERM=FT(NUNFIL+J)
         FT(NUNFIL+J)=FT(J) * fact
         FT(J)=CTERM * fact
  210 CONTINUE
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE ERRMES (NUMBER, ILEVEL, CHSUBP)
C  Prints error message and, if IABS(ILEVEL)=4 or 5, aborts (first calling
C    EXITPS if ILEVEL>0).
C  |ILEVEL| = 1 for information.
C           = 2 for a warning.
C           = 3 for a non-fatal error.
C           = 4 for a fatal error.
C           = 5 for an illogical stop.
C           < 0 means that the error message was called while EXITPS was being
C               executed.  Thus, it cannot be called again (to avoid an
C               infinite recursive loop) and the run must be stopped here
C               without producing a PS plot file.  The error messages can only
C               be obtained on unit LPRINT.
      INCLUDE 'lcmodel.inc'
      save ertype
      CHARACTER ERTYPE(5)*15
      DATA ERTYPE/'    INFORMATION', '        WARNING',
     1            'NON-FATAL ERROR', '    FATAL ERROR',
     2            ' ILLOGICAL STOP'/
      DO 110 JERR=1,LINERR
         IF (CHERR(JERR).EQ.CHSUBP .AND. IERRNO(JERR).EQ.NUMBER
     1       .AND. LEVERR(JERR).EQ.ILEVEL) THEN
            NERROR(JERR)=NERROR(JERR)+1
            GO TO 120
         END IF
  110 CONTINUE
c     ------------------------------------------------------------------------
c     Normal case.
c     ------------------------------------------------------------------------
      LINERR=LINERR+1
      NERROR(LINERR)=1
      CHERR(LINERR)=CHSUBP
      IERRNO(LINERR)=NUMBER
      LEVERR(LINERR)=ILEVEL
c     ------------------------------------------------------------------------
c     Illogical stop.
c     ------------------------------------------------------------------------
  120 IF (IABS(ILEVEL).LT.1 .OR. IABS(ILEVEL).GT.5) THEN
 5000    FORMAT (/' Illogical Stop In ERRMES.  ',A6,I3)
         IF (LPRINT .GT. 0) WRITE (LPRINT,5000) CHSUBP, NUMBER
         WRITE (*,5000) CHSUBP, NUMBER
         LINERR=LINERR+1
         NERROR(LINERR)=1
         CHERR(LINERR)='ERRMES'
         IERRNO(LINERR)=1
         LEVERR(LINERR)=5
         IF (ILEVEL .LT. 0) THEN
 5050       FORMAT ('***  ',A15,2X,A6,I3,/
     1              '     This error occurred before the plot could ',
     2              'be produced.'/
     3              '     See the Diagnostics list in the LCModel ',
     4              'Manual.  ***')
            IF (LPRINT .GT. 0) WRITE (LPRINT,5050) ERTYPE(IABS(ILEVEL)),
     1                                             CHSUBP, NUMBER
            WRITE (*,5050) ERTYPE(IABS(ILEVEL)), CHSUBP, NUMBER
            STOP
         END IF
         CALL EXITPS (.true.)
      END IF
c     ------------------------------------------------------------------------
c     Normal case.
c     ------------------------------------------------------------------------
 5100 FORMAT (1X,A15,2X,A6,I3,'.   (Check LCModel Manual).  ',36(2H**)/)
      IF (LPRINT .GT. 0) WRITE (LPRINT,5100) ERTYPE(IABS(ILEVEL)),
     1                                       CHSUBP, NUMBER
      NERMES=NERMES+1
c     ------------------------------------------------------------------------
c     Maximum error messages.
c     ------------------------------------------------------------------------
      IF (NERMES .GE. MERMES) THEN
 5800    FORMAT (//' Stopping after',I5,' diagnostic messages.')
         IF (LPRINT .GT. 0) WRITE (LPRINT,5800) MERMES
         LINERR=LINERR+1
         NERROR(LINERR)=1
         CHERR(LINERR)='ERRMES'
         IERRNO(LINERR)=2
         LEVERR(LINERR)=4
         IF (ILEVEL .LT. 0) THEN
            IF (LPRINT .GT. 0) WRITE (LPRINT,5050) ERTYPE(IABS(ILEVEL)),
     1                                             CHSUBP, NUMBER
            WRITE (*,5050) ERTYPE(IABS(ILEVEL)), CHSUBP, NUMBER
            STOP
         END IF
         CALL EXITPS (.true.)
      END IF
c     ------------------------------------------------------------------------
c     Abort on FATAL.
c     ------------------------------------------------------------------------
      IF (IABS(ILEVEL) .GE. 4) THEN
         IF (ILEVEL .LT. 0) THEN
            IF (LPRINT .GT. 0) WRITE (LPRINT,5050) ERTYPE(IABS(ILEVEL)),
     1                                             CHSUBP, NUMBER
            WRITE (*,5050) ERTYPE(IABS(ILEVEL)), CHSUBP, NUMBER
            STOP
         END IF
         CALL EXITPS (.true.)
      END IF
      END
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE INITIA ()
C
C  Initialization at start of run.
C
      INCLUDE 'lcmodel.inc'
      EXTERNAL DIFF
      DOUBLE PRECISION DIFF
      CHSUBP='INITIA'
      PI=3.141592654D0
      RADIAN=PI/180.
      NDATA=2*NUNFIL
      FNDATA=FLOAT(NDATA)
c     -------------------------------------------------------------------------
c     NLIN = 65535 + 14 = 65549
c     -------------------------------------------------------------------------
      if (ldwfft .gt. 0) then
         nlin = 2 * nlin + 15
      else
         nlin = nlin + 14
      end if
      PPMINC=DELTAT*FNDATA*HZPPPM
      IF (PPMINC .LE. 0.) CALL ERRMES (1, 4, CHSUBP)
      PPMINC=1./PPMINC
      IF (PPMINC.LE.0. .OR. NUNFIL.GT.MUNFIL) THEN
         IF (LPRINT .GT. 0) THEN
            J=MUNFIL
            WRITE (LPRINT, 5110) NUNFIL, J
 5110       FORMAT (//' NUNFIL =', I6, ';   it cannot exceed', I6/)
         END IF
         CALL ERRMES (2, 4, CHSUBP)
      END IF
      LDATST=NINT((PPMCEN-PPMST)/PPMINC)+1+nunfil
      LDATEN=NINT((PPMCEN-PPMEND)/PPMINC)+1+nunfil
      NY=LDATEN-LDATST+1
      IF (LDATST.LE.0 .OR. LDATEN.GT.ndata) CALL ERRMES (3, 4, CHSUBP)
      IF (LDATST.GE.LDATEN .OR. NY.GT.MY) CALL ERRMES (4, 4, CHSUBP)
      DELPPM(1)=-PPMINC*FLOAT(LDATST-1-nunfil)
      ppm(1) = ppmst
      DO 110 JY=2,NY
         DELPPM(JY)=DELPPM(JY-1)-PPMINC
         ppm(jy) = ppm(jy - 1) - ppminc
  110 CONTINUE
C     -------------------------------------------------------------------------
c     Count & order PPMGAP (in the usual descending order in ppm)
c     LCY_SKIP(JY) = T if CY(JY) is to be skipped because it is in a gap.
C     -------------------------------------------------------------------------
      ngap = 0
      do 112 jgap = 1, mgap
         gmax = amax1(ppmgap(1, jgap), ppmgap(2, jgap))
         if (gmax .gt. 9.e36) go to 115
         ngap = ngap + 1
         gmin = amin1(ppmgap(1, jgap), ppmgap(2, jgap))
         ppmgap(1, jgap) = gmax
         ppmgap(2, jgap) = gmin
         if (jgap .gt . 1) then
            if (gmax .ge. ppmgap(2, jgap - 1))
     1         call errmes (9, 4, chsubp)
         end if
         do 114 jy = 1, ny
            lcy_skip(jy) = lcy_skip(jy)   .or.
     1                     (ppm(jy) .le. gmax   .and.
     2                      ppm(jy) .ge. gmin)
 114     continue
 112  continue
C     -------------------------------------------------------------------------
c     NYUSE = # points in Analysis Window actually used (i.e., with gaps
c             removed).
c     Compact array PPM to NYUSE array with the gaps removed.
C     -------------------------------------------------------------------------
 115  nyuse = 0
      do 116 jy = 1, ny
         if (lcy_skip(jy)) go to 116
         nyuse = nyuse + 1
         ppm(nyuse) = ppm(jy)
 116  continue
      if (nyuse .lt. 64) call errmes(8, 3, chsubp)
C     -------------------------------------------------------------------------
C     Convert SDMSHF from ppm to radians/s.
C     -------------------------------------------------------------------------
      SDMSHF=SDMSHF*2.*PI*HZPPPM
      ALOG2=ALOG(2.)
      TOFWHM=SQRT(4.*ALOG2)/(PI*HZPPPM)
c     -------------------------------------------------------------------------
c     NPAR = 2 * 50 + 20 = 120
c     -------------------------------------------------------------------------
      if (ldwfft .gt. 0) then
         npar = 4 * npar + 60
      else
         npar = 2 * npar + 20
      end if
      PRECIS=1.D-6
      DO 120 J=1,100
         IF (DIFF(1.D0+PRECIS, 1.D0) .LE. 0.D0) GO TO 125
         PRECIS=.1D0*PRECIS
  120 CONTINUE
      CALL ERRMES (5, 5, CHSUBP)
  125 PRECIS=100.D0*PRECIS
      IF (LPRINT .GT. 0) WRITE (LPRINT,5125) PPMINC, NYuse, PRECIS
 5125 FORMAT (///10X, ' Other quantities'/
     1           ' PPMINC =', 1PE10.3/
     2           ' NY =', I5/
     3           ' PRECIS =', E9.2)
      IF (PRECIS .GE. .99D-10) CALL ERRMES (6, 2, CHSUBP)
      IF (PRECIS .GE. .99D-5) CALL ERRMES (7, 4, CHSUBP)
      END
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE DATAIN ()
C
      INCLUDE 'lcmodel.inc'
      parameter (mdevx=400)
      save havlin, wdone
      logical havlin, wdone
C      CHARACTER CHLI(MDEV)*6!OSF
C      INTEGER IGETAD!OSF
      INTEGER LDEV(MDEV), ldevx(mdevx)
       EXTERNAL ILEN!Cyg
C     EXTERNAL ILEN!sun
C      EXTERNAL ILEN!IRIX
C      EXTERNAL ILEN, IGETAD!OSF
      data havlin/.false./, wdone/.false./
      CHSUBP='DATAIN'
C     -------------------------------------------------------------------------
C     Get time-domain data, scale them, and get non-H2O-suppressed time-domain
C       data.
C     -------------------------------------------------------------------------
      if (iaverg .le. 0) CALL MYDATA ()
C     -------------------------------------------------------------------------
C     ISTAGO = 1 when DATAT is loaded with time-domain data.
C     -------------------------------------------------------------------------
      ISTAGO=1
      if (skip_voxel) return
c     ------------------------------------------------------------------------
c     Change spectral data to absolute value.  The zero-filling below is
c       necesary to avoid huge high-frequency oscillations in spectrum.
c       Presumably zero-filling brings in enough info, so that these symmetric
c       parts can be discarded.
c     The 2.0 * CABS below is to compensate for discarding the
c       symmetric/antisymmetric 2nd half in points NUNFIL+1--NDATA.
c     1st time-data point (the integral over the spectrum) must be halved,
c       to remove the offset produced by halving the number of points.  See
c       Notes of 010819.
c     ------------------------------------------------------------------------
      if (absval) then
         do 130 j = nunfil+1, ndata
            datat(j) = 0.
 130     continue
         call cfft (datat, dataf, ndata, lwfft, wfftc)
         do 135 j = 1, ndata
            dataf(j) = 2. * cabs(dataf(j))
 135     continue
         call cfftin (dataf, datat, ndata, lwfft, wfftc)
         datat(1) = .5 * datat(1)
      end if
C
C     ----------------------------------------------------------------------
C     Test license.
C     LI = host identification number initially; later this is modifed by
C          OWNER information.
C     LLINE = T if the run is to be aborted because of no license, and this is
c               not the Test Data.
c     COUNTC used instead of GETID for routine name for getting ID.
c     NOLINE = T if there is no license; used instead of NOLIC for security.
C     ----------------------------------------------------------------------
      CALL FTDATA(0)
c     -----------------------------------------------------------------------
c     Skip license tests with Intel Windows version & dongle.
c     -----------------------------------------------------------------------
       if (nlin .gt. 0) go to 200!Cyg
c     -----------------------------------------------------------------------
c     Check for Master KEY.
c     -----------------------------------------------------------------------
      if (key(1) .eq. 210387309) go to 200
      LLINE=.FALSE.
      NOLINE=.FALSE.
c     -------------------------------------------------------------------------
c     The numerical year & month below should be updated to foil backdating.
c     -------------------------------------------------------------------------
      IF (KNUM(3) .LT. 100) KNUM(3)=KNUM(3)+2000
      if (knum(3) .lt. 2018   .or.
     1    (knum(3) .eq. 2018   .and.   knum(2) .lt. 7)) go to 195
c     -------------------------------------------------------------------------
c     GETFFT produces a segmentation fault if called more than once (although
c        NPAR & NLIN were verified to be correct.
c     Therefore, HAVLIN=T (set below) if Linux valid license was found, and
c        this allows skipping a 2nd test.
c     -------------------------------------------------------------------------
      if (havlin) go to 200
c     -------------------------------------------------------------------------
c     Initialize LDEVX, since some may be commented out in DEVX*.INC
c     -------------------------------------------------------------------------
      do 250 j = 1, mdevx
         ldevx(j) = -2
 250  continue
      ndevx = 999999
c     ------------------------------------------------------------------------
c     The following statement will never be reached with the Cyg flag, but
c        the start of the IF must be there to avoid diagnostics with Sun,
c        etc.  Should use INCLUDEs instead.
c     -------------------------------------------------------------------------
C     if (nlin .gt. 0) then!Linux
       if (nlin .gt. 0) then!Cyg
C      if (nlin .lt. 0) then!sun
C      if (nlin .lt. 0) then!IRIX
C      if (nlin .lt. 0) then!OSF
c        --------------------------------------------------------------------
c        LETT = STATUS for ERRMES from GETFFT (GETLIC) = 0 for valid license.
c        NPAR = 120 = NSTART in GETLIC
c        NLIN = 65549 = ARG1 in GETLIC
c        --------------------------------------------------------------------
         len_owner = 0
C        call getfft(npar, nlin, lett, owner, len_owner, knum3, !Linux
C    1               knum2, idevx, version_lcm)!Linux
         if (len_owner .gt. 0) then
c           -----------------------------------------------------------------
c           The following 2 lines are a clumsy way to properly fill OWNER with
c              blanks, avoiding the output of a binary character in the
c              Namelist output of OWNER.
c           -----------------------------------------------------------------
            ownout = OWNER(1:len_owner) // ' '
            owner = ownout
            OWNOUT='Data of: ' // OWNER(1:len_owner)
            JOWNER=ILEN(OWNOUT)
            JDATE=ILEN(CHDATE)
            if (ltable .gt. 0)
     1         write (ltable, 5410) OWNOUT(1:JOWNER), CHDATE(1:JDATE)
 5410       format(1x, a)
            IF (LCOORD .GT. 0)
     1         write (lcoord, 5410) OWNOUT(1:JOWNER), CHDATE(1:JDATE)
         end if
C        include 'devx_linux.inc'!Linux
         do 410 j = 1, ndevx
            if (idevx .eq. ldevx(j)) lett = 40
 410     continue
         if (lett .eq. 0) then
            if (knum(3) .gt. knum3   .or.
     1          (knum(3) .eq. knum3   .and.   knum(2) .gt. knum2))
     2           lett = 50
         end if
         havlin = lett .eq. 0
         if (havlin) go to 200
      else
         NDEV=1
         L=0
C         CALL countc (L)!sun
C         CALL countc (L)!IRIX
         LDEV(1)=L
C        ------------------------------------------------------------------
C        Initialize LDEV1 to only output NDEV LDEV1 values in One-Page Output.
C        ------------------------------------------------------------------
         DO 185 JDEV=2,MDEV
            LDEV1(JDEV)=-1
 185     CONTINUE
C        ------------------------------------------------------------------
C        OSF IGETAD can return NDEV>1 LDEV values.
C        ------------------------------------------------------------------
C         MDEVAR=MDEV!OSF
C         NDEV=IABS(IGETAD (CHLI, MDEVAR))!OSF
C         DO 186 JDEV=1,NDEV!OSF
C            LDEV(JDEV)=77*ICHAR(CHLI(JDEV)(1:1))+!OSF
C     1                 7*ICHAR(CHLI(JDEV)(2:2))+!OSF
C     2                 26*ICHAR(CHLI(JDEV)(3:3))+!OSF
C     3                 65536*ICHAR(CHLI(JDEV)(4:4))+!OSF
C     4                 256*ICHAR(CHLI(JDEV)(5:5))+!OSF
C     5                 ICHAR(CHLI(JDEV)(6:6))!OSF
C  186    CONTINUE!OSF
C         NDEV=MAX0(1, NDEV)!OSF
C
C         include 'devx.inc'!IRIX
C         include 'devx.inc'!OSF
C         include 'devx.inc'!sun
         DO 187 JDEV=1,NDEV
            LDEV1(JDEV) = IGETP (34481 + IABS(LDEV(JDEV)), 35)
c           -------------------------------------------------------------
c           Reject license if LDEV1 is on blacklist in LDEVX
c           -------------------------------------------------------------
            do 1875 jdevx = 1, ndevx
               if (LDEV1(JDEV) .eq. ldevx(jdevx)) go to 195
 1875       continue
            LDEV(JDEV)=LDEV1(JDEV)
C        ----------------------------------------------------------------
C        Modify LDEV(JDEV) with OWNER info.
C        ----------------------------------------------------------------
            DO 188 J=1,ILEN(OWNER)
               LDEV(JDEV)=LDEV(JDEV)-(J+9)*ICHAR(OWNER(J:J))
 188        CONTINUE
            LDEV(JDEV)=IABS(LDEV(JDEV))
C        ----------------------------------------------------------------
C        Test LDEV(JDEV) for lifetime license.
C        ----------------------------------------------------------------
            K = IGETP (LDEV(JDEV) + 8829, 59)
            DO 189 J = 1, MKEY
               IF (KEY(J) .EQ. K) GO TO 200
 189        CONTINUE
C           -------------------------------------------------------------
C           Test host identification number for license for next 25 months.
C           KNUM(2) = month
C           KNUM(3) = year
C           -------------------------------------------------------------
            KJ = 100*(KNUM(3) - 1997)
            KM = KNUM(2) - 1
            DO 191 JPAR = 1, 25
               KM = KM + 1
               IF (KM .GT. 12) THEN
                  KM = KM - 12
                  KJ = KJ + 100
               END IF
               K = IGETP (LDEV(JDEV) + (KJ + KM)*3678, 41)
               DO 193 J = 1, MKEY
                  IF (KEY(J) .EQ. 0) GO TO 191
                  IF (KEY(J) .EQ. K) GO TO 200
 193           CONTINUE
 191        CONTINUE
 187     CONTINUE
      end if
C     ----------------------------------------------------------------------
C     There is no license.  Check if this is demo data.
C     ----------------------------------------------------------------------
 195  NOLINE=.TRUE.
      PPM1=3.4
      PPM2=2.8
      SUML=0.
      DO 9210 J=NINT((4.65-PPM1)/PPMINC)+1+nunfil,
     1     NINT((4.65-PPM2)/PPMINC)+1+nunfil
         SUML=AMAX1(SUML,CABS(DATAF(J)))
 9210 CONTINUE
C
      PPM1=2.8
      PPM2=2.2
      SUMM=0.
      DO 9220 J=NINT((4.65-PPM1)/PPMINC)+1+nunfil,
     1     NINT((4.65-PPM2)/PPMINC)+1+nunfil
         SUMM=AMAX1(SUMM,CABS(DATAF(J)))
 9220 CONTINUE
C
      PPM1=2.2
      PPM2=1.8
      SUMR=0.
      DO 9230 J=NINT((4.65-PPM1)/PPMINC)+1+nunfil,
     1     NINT((4.65-PPM2)/PPMINC)+1+nunfil
         SUMR=AMAX1(SUMR,CABS(DATAF(J)))
 9230 CONTINUE
C
      TEST=SUML-SUMM
      LLINE=ABS(TEST).LE.0.
      IF (.NOT.LLINE) THEN
         TEST=(SUMR-SUMM)/TEST
C         write (*, 5230) test!delete
C5230     format (1pe15.6)!delete
C         if (nunfil .gt. 0) stop!delete
C         LLINE=MOD(NINT(3.*TEST),2) .EQ. 0
          LLINE=TEST.LT.2.16 .OR. TEST.GT.2.17
      END IF
C     -------------------------------------------------------------------------
c     NOLINE = T if there is no license.
C     LLINE = T if the run is to be aborted because of no license, and this is
c               not the Test Data.
c     fndata = 0. causes the run to be aborted in MYBASI.  This will sabotage
c                 the run, even if the abort is stopped.
C     -------------------------------------------------------------------------
      if (lline) fndata = 0.
 200  RETURN
      END
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      INTEGER FUNCTION ICYCLE_r (J, NDATA)
C
C  Computes the subscript from J for a rearranged array of length NDATA.
c  Simply sets extensions beyond array to the endpoint.
C
      ICYCLE_R=max0(1,min0(ndata,j))
      END
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      INTEGER FUNCTION ICYCLE (J, NDATA)
C
C  Computes the subscript from J for a cyclic array of length NDATA.
C  J > -NDATA must be satisfied.
C
      CHARACTER CHSUBP*6
      CHSUBP='ICYCLE'
      K=J-1+NDATA
      IF (K .LT. 0) CALL ERRMES (1, 4, CHSUBP)
      ICYCLE=MOD(K,NDATA)+1
      END
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE MYDATA ()
C
Cvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv For user vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
C
C  Read the NUNFIL complex time-domain data into DATAT.
C  Scale DATAT.
C  Read the NUNFIL complex time-domain non-H2O-suppressed data into H2OT.
c  If DOECC, then do ECC.
C
C  If your compiler doesn't accept NAMELIST, then you will have to modify
C    this subprogram to use only standard I/O statements.
C
C^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ For user ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
C
      INCLUDE 'lcmodel.inc'
      save BRUKER_h2o, BRUKER_raw, fmtdat_h2o, fmtdat_raw, id,
     1     scale_h2o, scale_raw, seqacq_h2o, seqacq_raw
      CHARACTER FMTDAT*(MCHFmt), FMTDAT_h2o*(MCHFmt),
     1          FMTDAT_raw*(MCHFmt), ID*(MCHID), seq*5
      LOGICAL bruker, BRUKER_h2o, BRUKER_raw,
     1        seqacq, seqacq_h2o, seqacq_raw
      namelist /seqpar/ hzpppm, echot, seq
      NAMELIST /NMID/ ID, FMTDAT, TRAMP, VOLUME, SEQACQ, BRUKER
      CHSUBP='MYDATA'
      if (voxel1) then
c        ---------------------------------------------------------------------
c        If not present in seqpar, then echot_raw = -1., and seq_raw = ' '.
c        ---------------------------------------------------------------------
         hzpppm_sav=hzpppm
         hzpppm=-1.
         seq=' '
         echot=-1.
         read (lraw, nml=seqpar, err=102, end=102)
 102     rewind lraw
         if (hzpppm .gt. 0.) then
            if (abs(hzpppm_sav / hzpppm - 1.) .gt. .05) call errmes
     1                                                  (4, 2, chsubp)
         end if
         hzpppm=hzpppm_sav
         echot_raw=echot
         seq_raw=seq
      end if
      if (voxel1   .or.   lraw_at_top) then
c        ---------------------------------------------------------------------
c        Read NMID.
c        ---------------------------------------------------------------------
         tramp = 1.
         volume = 1.
         id = ' '
         FMTDAT=' '
         BRUKER=.FALSE.
         SEQACQ=.FALSE.
         READ (LRAW, NML=NMID, err=807, end=807)
         IF (FMTDAT .EQ. ' ') CALL ERRMES (1, 4, CHSUBP)
         FMTDAT_RAW=fmtdat
         BRUKER_RAW=bruker
         SEQACQ_RAW=seqacq
      end if
      READ (LRAW, FMTDAT_RAW, err=808, end=808) (DATAT(J),J=1,NUNFIL)
      IF (LPRINT .GT. 0) then
         if (nlines_title .eq. 1) then
            WRITE (LPRINT,5110) TITLE_line(1), ID
 5110       FORMAT (1X,A//' Data set ID = ',A////)
         else
            WRITE (LPRINT,5112) TITLE_line, ID
 5112       FORMAT (1X,A/1x,a//' Data set ID = ',A////)
         end if
      end if
C
Cvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv For user vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
C
C     TRAMP and VOLUME are the transmitter amplitude and VOI used for scaling
C       the spectra to get absolute concentrations, as discussed in MRM.  If
C       you do not have this data, then you can leave TRAMP and VOLUME out of
C       NAMELIST NMID, and leave them at their default values of
C       TRAMP=VOLUME=1; the spectrum data will remain unscaled (with SCALE=1.)
C       below.
C
C^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ For user ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
C
      if (voxel1) then
         IF (AMIN1(TRAMP,VOLUME,fcalib) .LE. 0.)
     1      CALL ERRMES (2, 4, CHSUBP)
         SCALE_RAW=fcalib*TRAMP/VOLUME
      end if
      if (skip_voxel) go to 190
      DO 110 JDATA=1,NUNFIL
         DATAT(JDATA)=DATAT(JDATA)*SCALE_RAW
  110 CONTINUE
      if (fwhmsm .gt. 0.) then
         RSD = PI* fwhmsm * deltat * hzpppm / sqrt(2.*alog(2.))
         DO 112 JUNFIL=1,NUNFIL
            DATAt(JUNFIL)=DATAT(JUNFIL)*
     1                    EXP(-.5*(RSD*FLOAT(JUNFIL-1))**2)
 112     CONTINUE
      endif

      IF (SEQACQ_RAW) THEN
         CALL SEQTOT (DATAT, DATAF, NUNFIL, LWFFT, WFFTC)
      ELSE IF (BRUKER_RAW) THEN
         DO 115 JDATA=1,NUNFIL
            DATAT(JDATA)=CONJG(DATAT(JDATA))
  115    CONTINUE
      END IF
      if (smtail) call smooth_tail(datat)
 190  havh2o = .false.
      IF (filh2o .ne. ' ') THEN
         if (voxel1) then
C           -------------------------------------------------------------------
C           Read time-domain non-H2O-suppressed data into H2OT.
C           -------------------------------------------------------------------
             OPEN (LH2O, FILE=FILH2O, STATUS='OLD', err=800)!Cyg
C           OPEN (LH2O, FILE=FILH2O, STATUS='OLD', err=800) !sun
C            OPEN (LH2O, FILE=FILH2O, STATUS='OLD', READONLY, err=800)!OSF
C            OPEN (LH2O, FILE=FILH2O, STATUS='OLD', READONLY, err=800)!IRIX
         end if
         if (voxel1   .or.   lraw_at_top) then
            FMTDAT=' '
            BRUKER=.FALSE.
            SEQACQ=.FALSE.
            READ (LH2O, NML=NMID, err=809, end=809)
            IF (FMTDAT .EQ. ' ') CALL ERRMES (3, 4, CHSUBP)
            FMTDAT_H2O=fmtdat
            BRUKER_H2O=bruker
            SEQACQ_H2O=seqacq
         end if
         READ (LH2O, FMTDAT_H2O, err=810, end=810) (H2OT(J),J=1,NUNFIL)
         havh2o = .true.
         if (voxel1) then
            if (amin1(tramp, volume) .le. 0.) then
c              ----------------------------------------------------------------
c              This could cause an error in water-scaling, if water-reference
c                & suppresed TRAMP & VOLUME do not match.
c              ----------------------------------------------------------------
               if (dows) call errmes (11, 2, chsubp)
               scale_h2o = scale_raw
            else
               SCALE_H2O=TRAMP/VOLUME
            end if
         end if
         if (skip_voxel) go to 800
         DO 210 JDATA=1,NUNFIL
            H2OT(JDATA)=H2OT(JDATA)*SCALE_H2O
 210     CONTINUE
         IF (SEQACQ_H2O) THEN
            CALL SEQTOT (H2OT, DATAF, NUNFIL, LWFFT, WFFTC)
         ELSE IF (BRUKER_H2O) THEN
            DO 215 JDATA=1,NUNFIL
               H2OT(JDATA)=CONJG(H2OT(JDATA))
  215       CONTINUE
         END IF
         if (smtail) call smooth_tail(h2ot)
         if (fwhmsm .gt. 0.) then
            RSD = PI* fwhmsm * deltat * hzpppm / sqrt(2.*alog(2.))
            DO 220 JUNFIL=1,NUNFIL
               h2ot(JUNFIL)=h2ot(JUNFIL)*
     1                      EXP(-.5*(RSD*FLOAT(JUNFIL-1))**2)
 220        CONTINUE
         endif
c        ----------------------------------------------------------------------
c        UNSUPR = T to use H2OT as DATAT.  Cannot be used with phased arrays,
c                   because DOECC=F would sum incoherently.
c        ----------------------------------------------------------------------
         if (unsupr) then
            doecc = .false.
            do 250 JDATA=1,NUNFIL
               datat(jdata) = H2OT(JDATA)
 250        CONTINUE
         end if
      END IF
      if (havh2o   .and.   biglip   .and.   iaverg .gt. 0   .and.
     1    .not.doecc) then
         call phase_with_max_real ()
      else if (doecc_active   .and.   .not.doecc) then
         doecc_active = .false.
         sddegz = amin1(999., 333. * sddegz)
      end if
      IF (DOECC   .and.   havh2o   .and.   (iaverg .ne. 3   .and.
     1     iaverg .ne. 31   .and.   iaverg .ne. 32))
     2   call ecc_truncate ()
 800  if (.not.havh2o   .and.   (doecc .or. dows)) then
         call errmes (5, 3, chsubp)
         doecc = .false.
         dows = .false.
      end if
      if (.not.havh2o   .and.   unsupr) call errmes (12, 4, chsubp)
      RETURN
 807  call errmes (7, 4, chsubp)
 808  call errmes (8, 4, chsubp)
 809  call errmes (9, 4, chsubp)
 810  call errmes (10, 4, chsubp)
      END
C
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      subroutine  phase_with_max_real ()
c
c Phase (zero-order)  DATAT & H2OT so that integral from ppmst_phalip &
c    ppmend_phalip of real part of H2OF is max.
c Assumes that H2OT is positive (as with lipid spectra).
c
      include 'lcmodel.inc'
      complex cfact, cfact_best, delta_cfact
      logical sddegz_done
      save sddegz_done
      data sddegz_done/.false./
      chsubp = 'PHALIP'
c     ------------------------------------------------------------------------
c     Account for increased uncertainty in DEGZER compared to using ECC.
c     ------------------------------------------------------------------------
      if (.not.sddegz_done) then
         sddegz_done = .true.
         sddegz = 2. * sddegz
      end if
c     ------------------------------------------------------------------------
c     PPMINC, NDATA, FNDATA & RADIAN initialized in AVERAGE.
c     ------------------------------------------------------------------------
      do 150 jdata = nunfil + 1, ndata
         h2ot(jdata) = cmplx(0., 0.)
 150  continue
      call csft_r (h2ot, h2of, ndata)
c     ------------------------------------------------------------------------
c     Increment is 1 degree
c     ------------------------------------------------------------------------
      delta_cfact = cexp(cmplx(0., radian))
      cfact = 1.
      cfact_best = cfact
      ldatst = max0(1, NINT((PPMCEN - PPMST_phalip)/PPMINC)+1+nunfil)
      LDATEN = min0(ndata,
     1              nint((PPMCEN - PPMEND_phalip)/PPMINC)+1+nunfil)
      if (ldaten .le. ldatst) call errmes (1, 4, chsubp)
      sum_best = -1.e30
      ldeg = -1
      do 210 jdeg = 0, 359
         sum = 0.
         do 250 jdata = ldatst, ldaten
            sum = sum + real(h2of(jdata) * cfact)
 250     continue
         if (sum .ge. sum_best) then
            sum_best = sum
            cfact_best = cfact
            ldeg = jdeg
         end if
         cfact = cfact * delta_cfact
  210  continue
      do 310 junfil = 1, nunfil
         datat(junfil) = datat(junfil) * cfact_best
         h2ot(junfil) = h2ot(junfil) * cfact_best
 310  continue
c      write (6, 5310) ldeg
c 5310 format ('zero-order phase =', i4)
      end
C
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      subroutine smooth_tail(cdatat)
c
c Smooth tail to get rid of oscillations at end with Siemens (and sometimes
c   Bruker) time-domain data.
c CDATAT = DATAT or H2OT
c
      include 'lcmodel.inc'
      complex cdatat(munfil)
      real out_imag(munfil), out_real(munfil), work_in(munfil)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      common out_imag, out_real, work_in
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
      do 110 j = 1, nunfil
         work_in(j) = real(cdatat(j))
 110  continue
      call smooth_tail_2(work_in, out_real,
     1                   munfil, nunfil, lprint, voxel1)

      do 210 j = 1, nunfil
         work_in(j) =  aimag(cdatat(j))
 210  continue
      call smooth_tail_2(work_in, out_imag,
     1                   munfil, nunfil, lprint, voxel1)

      do 310 j = 1, nunfil
         cdatat(j) = cmplx(out_real(j), out_imag(j))
 310  continue
C      write(6, 9310) (cdatat(j), j = 1, nunfil)!DELETE
C 9310 format(1p2e15.6)!DELETE
      end
C
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      subroutine smooth_tail_2(work_in, out,
     1                         munfil, nunfil, lprint, voxel1)
c
c Average over next neighbors as long as zig-zag pattern holds.
c j = point at which pattern is broken; out(j) is not computed.
c
      logical voxel1
      real out(munfil), work_in(munfil)
c
      do 110 j = nunfil - 1, 2, -1
         if ((work_in(j + 1) - work_in(j)) *
     1       (work_in(j) - work_in(j - 1)) .gt. 0.) go to 210
         out(j) = .5 * work_in(j) +
     1            .25 * (work_in(j + 1) + work_in(j - 1))
 110  continue
      j = 1
 210  if (j .lt. nunfil - 1) then
         out(nunfil) = out(nunfil - 1)
      else
         out(nunfil) = work_in(nunfil)
      end if
      do 220 junfil = 1, j
         out(junfil) = work_in(junfil)
 220  continue
      if (lprint. gt. 0   .and.   voxel1)
     1      write(lprint, 5210) nunfil - j
 5210 format(/i4, ' points in tail smoothed')
      end
C
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      subroutine ecc_truncate ()
      include 'lcmodel.inc'
      real awork(munfil)
      complex h2ot_ecc(munfil)
      common awork, h2ot_ecc
c
      chsubp = 'ECC'
      PPMINC2 = DELTAT * float(nunfil) * HZPPPM
      IF (PPMINC2 .LE. 0.) CALL ERRMES (1, 4, CHSUBP)
      PPMINC2=1./PPMINC2
      nunfil_half = nunfil / 2
      if (ppm_truncate_max .lt. 0.   .or.
     1    ppm_truncate_min .gt. ppmh2o) then
         do 130 junfil = 1, nunfil
            h2ot_ecc(junfil) = h2ot(junfil)
 130     continue
      else
         lmin = nunfil_half + 1 + (ppmcen - ppm_truncate_max) / ppminc2
         lmax = nunfil_half + 1 + (ppmcen - ppm_truncate_min) / ppminc2
         if (lmin .lt. 3   .or.   lmax .gt. ndata -2   .or.
     1       lmin .ge. lmax) call errmes (2, 4, chsubp)
         call csft_r(h2ot, h2of_work, nunfil)
         do 240 j = 1, nunfil
            awork(j) = cabs(h2of_work(j))
 240     continue
         absmin = 1.e30
         ltruncate = 0
         do 250 j = lmin, lmax
c           ------------------------------------------------------------------
c           TEST = least-squares line at j (Hildebrand, p 295)
c           ------------------------------------------------------------------
            test = awork(j-2) + awork(j-1) + awork(j) +
     1             awork(j+1) + awork(j+2)
            if (test .lt. absmin) then
               absmin = test
               ltruncate = j
            end if
 250     continue
         ppm_truncate = ppmcen - (ltruncate - nunfil_half -1) * ppminc2
         if (lprint .gt. 0) write (lprint, 5250) ppm_truncate
 5250    format (/'Truncated at ', f6.3, ' ppm for ECC')
         do 270 j = ltruncate + 1, nunfil
            h2of_work(j) = (0.,0.)
 270     continue
         call csftin_r (h2of_work, h2ot_work, h2ot_ecc, nunfil)
      end if
C     -------------------------------------------------------------------------
C     Klose's eddy-current correction.
C     -------------------------------------------------------------------------
      DO 310 JUNFIL=1,NUNFIL
         XX=REAL(H2OT_ecc(JUNFIL))
         YY=AIMAG(H2OT_ecc(JUNFIL))
         ABSSQ=XX*XX+YY*YY
         IF (ABSSQ .gt. 0.) THEN
C           -------------------------------------------------------------------
C           Zero points can occur when SEQACQ=T.  This will only be at the
C             end of the t-range, and is therefore not serious.
C           -------------------------------------------------------------------
            DATAT(JUNFIL)=DATAT(JUNFIL)*CMPLX(XX,-YY)/SQRT(ABSSQ)
         END IF
 310  CONTINUE
      end
C
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      FUNCTION IGETP (ISTART, NITER)
C
C  Uses RANDOM to encode ISTART and produce IGETP (max. 9 digits) for hostid
C    tests.
C
C  RANDOM PRODUCES A PSEUDORANDOM REAL ON THE OPEN INTERVAL (0.,1.).
C  DIX (IN DOUBLE PRECISION) will BE INITIALIZED TO A WHOLE NUMBER
C      BETWEEN 1.D0 AND 2147483646.D0 BEFORE THE FIRST CALL TO RANDOM
C      AND NOT CHANGED BETWEEN SUCCESSIVE CALLS TO RANDOM.
C  BASED ON L. SCHRAGE, ACM TRANS. ON MATH. SOFTWARE 5, 132 (1979).
C-----------------------------------------------------------------------
C
C  PORTABLE RANDOM NUMBER GENERATOR
C   USING THE RECURSION
C    DIX = DIX*A MOD P
C
      DOUBLE PRECISION A,P,DIX,B15,B16,XHI,XALO,LEFTLO,FHI,K
C
C  7**5, 2**15, 2**16, 2**31-1

      DATA A/16807.D0/,B15/32768.D0/,B16/65536.D0/,P/2147483647.D0/
C
      IF (ISTART .EQ. 8829) THEN
C        ----------------------------------------------------------------------
C        Special return for hostid=0
C        ISTART = hostid + 8829 must be in call from LCModel.
C        ----------------------------------------------------------------------
         IGETP = 0
         RETURN
      ENDIF
      DIX = DBLE(MAX0(1, MOD(IABS(ISTART), 2147483647)))
      DO 110 JITER = 1, MAX0(1, NITER)
C
C        GET 15 HI ORDER BITS OF DIX
C
         XHI = DIX / B16
         XHI = XHI - DMOD(XHI,1.D0)
C
C        GET 16 LO BITS IF DIX AND FORM LO PRODUCT
C
         XALO=(DIX-XHI*B16)*A
C
C        GET 15 HI ORDER BITS OF LO PRODUCT
C
         LEFTLO = XALO/B16
         LEFTLO = LEFTLO - DMOD(LEFTLO,1.D0)
C
C        FORM THE 31 HIGHEST BITS OF FULL PRODUCT
C
         FHI = XHI*A + LEFTLO
C
C        GET OVERFLO PAST 31ST BIT OF FULL PRODUCT
C
         K = FHI/B15
         K = K - DMOD(K,1.D0)
C
C        ASSEMBLE ALL THE PARTS AND PRESUBTRACT P
C        THE PARENTHESES ARE ESSENTIAL
C
         DIX = (((XALO-LEFTLO*B16) - P) + (FHI-K*B15)*B16) + K
C
C        ADD P BACK IN IF NECESSARY
C
         IF (DIX .LT. 0.D0) DIX = DIX + P
  110 CONTINUE
C
C     MULTIPLY BY 1/(2**31-1)
C
      DIX=DIX*4.656612875D-10
      IGETP=1.D9*DIX
      RETURN
      END
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE MYBASI (LSTAGE)
C
Cvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv For user vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
C
C  Most of this subprogram you should not have to change (or understand).
C    Only those parts set off by the usual lines of "v" and "^" characters are
C    intended for you to possibly change.
C
C  Read the basis set on unit LBASIS (file FILBAS).  There are 3 read
C    statements:
C      (1) NAMELIST BASIS1 (the main header).
C      (2) NAMELIST BASIS (a header for the basis spectrum to be read next)
C      (3) BASISF the basis spectrum.
C      Item (1) is read only once. Items (2) and (3) are read consecutively in
C        a loop until there are no more spectra left.
C
C^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ For user ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
C
C  Input and scale (also to unit concentrations) frequency-domain basis
C    vectors obtained with zero-filling.
C  Put their time-domain vectors into BASIST(JDATA,JMETAB).
C  LSTAGE = 1 for initial analyses with restricted model.
C         = 2 for analyses with full model.
C
      INCLUDE 'lcmodel.inc'
      external areaba, ilen
      save hzpppm_basis
      PARAMETER (MCHIDB=80)
      CHARACTER file_basout*262, FMTBAS*(MCHFMT), ID*(MCHID),
     1          IDBASI*(MCHIDB), METABO*(MCHMET), seq*5
      COMPLEX BASISF, offset_end, offset_start
      double precision dix
      LOGICAL corr_areaba, dows_now, encryp, ppmmet_in_gap(2),
     1        US1FUL(MMETAB)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      COMMON BASISF(8*MDATA)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      namelist /seqpar/ fwhmba, hzpppm, echot, seq
      NAMELIST /BASIS1/ IDBASI, FMTBAS, BADELT, NDATAB
      NAMELIST /BASIS/ ID, METABO, CONC, TRAMP, VOLUME, ISHIFT
      CHSUBP='MYBASI'
      IF (LSTAGE .EQ. 1) THEN
C        ----------------------------------------------------------------------
C        Abort if no license and no test data; FNDATA = 0. (from DATAIN)
c           causes abort.
C        ----------------------------------------------------------------------
         IF (AMIN1(PPMINC, FNDATA, TOFWHM) .LE.0. .OR.
     1       LDATST.GT.LDATEN .OR. LWFFT.LT.0)
     2       CALL ERRMES (max0(1, lett), 4, 'DEMO  ')
C        ----------------------------------------------------------------------
C        LETT > 0 at this stage is only possible with linux with Test Data.
C        ----------------------------------------------------------------------
         if (lett .gt. 0) call errmes (lett, 1, 'DEMO  ')
      END IF

      if ((scafwh   .or.  imethd .eq. 3)   .and.
     1    (.not.nobasi .or. badref)) call errmes (40, 5, chsubp)
C     -------------------------------------------------------------------------
c     RT2_SCALE: SDRT2 & EXRT2 will be scaled by
c                RT2_SCALE = sqrt(HZPPPM / HZPPPM_RT2_REF), assuming
c                that 1/T2 is roughly proportional to sqrt(HZPPPM).
c     Input values of SDRT2 will then pertain to HZPPPM_RT2_REF, which is
c       set to 2T below.
C     -------------------------------------------------------------------------
      RT2_SCALE = sqrt(hzpppm / 85.16)
      IF (LSTAGE .EQ. 1) THEN
         DO 105 JUSE1=1,NUSE1
            US1FUL(JUSE1)=.FALSE.
  105    CONTINUE
      END IF
c     -------------------------------------------------------------------------
c     NONNEG below must be later reset for all JPAR>NMETAB and when BASIST
c            correspond to Taylor expansion terms when TAYLOR=T
c     LSHAPE below must be later reset when convolution with Lineshape is
c            being suppressed.
c     -------------------------------------------------------------------------
      do 107 jmetab = 1, mmetab
         nonneg(jmetab) = .true.
         lshape(jmetab) = .true.
 107  continue
      NMETAB=0
      IF (LPRINT .GT. 0) THEN
         IF (LSTAGE .EQ. 1) THEN
            WRITE (LPRINT, 5105)
 5105       FORMAT (/////20X, 'Basis Spectra used for the ',
     1              'Preliminary Analysis')
         ELSE
            WRITE (LPRINT, 5106)
 5106       FORMAT (/////20X, 'Basis Spectra used for the ',
     1              'Final Analysis')
         END IF
      END IF
c     -------------------------------------------------------------------------
c     NOBASI=T to skip BASIS file and only use simulated spectra.
c     -------------------------------------------------------------------------
      if (nobasi) then
         if (bascal   .or.   ncalib .gt. 0   .or.   nsimul .le. 0)
     1      call errmes (27, 4, chsubp)
         scasim = .false.
c        ----------------------------------------------------------------------
c             Set DESDSH if it has not been input positive or set positive in
c        Block Data.  Of course, PPMINC (not PPMINC_BASIS) must be used here.
c        ----------------------------------------------------------------------
         if (desdsh .le. 0.) then
            if (rincsh .le. 0.   .or. sdshmn .le. 0.   .or.
     1          sdshmx .lt. sdshmn) call errmes (26, 4, chsubp)
            desdsh = amin1(sdshmx, amax1(sdshmn, rincsh * ppminc))
         end if
         IF (LPRINT .GT. 0) WRITE (LPRINT, 5110)
 5110    FORMAT (/' No.   Metabolite',3X,
     1            'Expec[delta(1/T2)](1/s)', 3X, 'SDdelta(1/T2)]',
     2            3X, 'Shift(Pts)', 3X, 'SD[Shift](ppm)   ID')
         go to 300
      end if
C     -------------------------------------------------------------------------
C     BASISF(JDATA) = unshifted, unscaled frequency-domain basis vector with
C                      zero-filling and marker peaks removed.
c     (2cygwin does not left-shift below; others do)
C     -------------------------------------------------------------------------
      if (lbasis .le. 0   .or.   filbas .eq. ' ')
     1      call errmes (33, 4, chsubp)
C     IF (FILBAS .NE. ' ') OPEN (LBASIS, FILE=FILBAS, STATUS='OLD',!sun
C    1                           err=810)!sun
      IF (FILBAS .NE. ' ') OPEN (LBASIS, FILE=FILBAS, STATUS='OLD',!Cyg
     1                           err=810)!Cyg
C      IF (FILBAS .NE. ' ') OPEN (LBASIS, FILE=FILBAS, STATUS='OLD',!OSF
C     1                           READONLY, err=810)!OSF
C      IF (FILBAS .NE. ' ') OPEN (LBASIS, FILE=FILBAS, STATUS='OLD',!IRIX
C     1                           READONLY, err=810)!IRIX
C
c     -------------------------------------------------------------------------
c     BASCAL=T for analyzing the CHBCAL basis spectrum as the data.
c       Since the basis spectra are also divided by CONC, the LCModel
c         concentration should be 1.0, e.g., if CHBCAL=PCh or NAAG and
c         CHCALI(1)=GPC or NAA.
c       When BASCAL=T, anything can be submitted as FILRAW, since it is not
c         read.  With LCMgui, one can use the "Other" fidType and enter
c         HZPPPM, etc., by hand.
c     -------------------------------------------------------------------------
      bascal = bascal .and. lstage.eq.1
      if (bascal) then
         if (ncalib.le.0 .or. chbcal.eq.' ') call errmes (12, 4, chsubp)
         do 108 jcalib = 1, ncalib
            if (chbcal .eq. chcali(jcalib)) call errmes (13, 4, chsubp)
 108     continue
      end if
      if (lstage .eq. 1  .and.  .not.bascal) then
         hzpppm_sav=hzpppm
         hzpppm=-1.
         seq=' '
         echot=-1.
         fwhmba_sav = fwhmba
         fwhmba = -1.
         read (lbasis, nml=seqpar, err=110, end=110)
         go to 120
 110     rewind lbasis
 120     hzpppm_basis = hzpppm
         hzpppm=hzpppm_sav
         if (amin1(echot,echot_raw) .gt. 0.) then
            test=abs(echot - echot_raw)
            if (test .ge. 3.001) call errmes (10, 3, chsubp)
         end if

         if (echot .le. temm   .and.   ppmend .gt. .6   .and.
     1       (sptype(:1) .eq. ' '   .or.
     2        sptype(:5) .eq. 'tumor'   .or.
     3        sptype(:6) .eq. 'nulled')) then
c           -----------------------------------------------------------------
c           Modify PPMMET so that MMs are also included, even though MM09
c             (and its ratio priors) is excluded, since especially MM20 is
c             important for NAA, NAAG, Glx, etc.
c           Settings below must be coordinated with BLOCK DATA. <<<<<<<<<<<<
c           -----------------------------------------------------------------
            call errmes (41, 2, chsubp)
C           ppmmet(1, 45) = 1.41 !MM12 @ 1.21; FWHM=.2
            ppmmet(2, 45) = 1.21
            ppmmet(3, 45) = 1.21
            ppmmet(4, 45) = 1.01
C           ppmmet(1, 46) = 1.63 !MM14 @ 1.43; FWHM=.2
            ppmmet(2, 46) = 1.43
            ppmmet(3, 46) = 1.43
            ppmmet(4, 46) = 1.23
C           ppmmet(1, 47) = 1.84 !MM17 @ 1.67; FWHM=.17
            ppmmet(2, 47) = 1.67
            ppmmet(3, 47) = 1.67
            ppmmet(4, 47) = 1.50
C           ppmmet(1, 48) = 2.43 !MM20 @ 2.08 & 2.25 & 1.95; FWHM=.18
C           ppmmet(2, 48) = 1.81 !PPMEND often 1.8
            ppmmet(3, 48) = 2.43
            ppmmet(4, 48) = 1.81
         end if

         call toupper_lower (.true., seq)
         call toupper_lower (.true., seq_raw)
         if ( (seq .eq. 'PRESS'  .and. seq_raw .eq. 'STEAM')  .or.
     1        (seq .eq. 'STEAM'  .and. seq_raw .eq. 'PRESS') )
     2        call errmes (11, 3, chsubp)
         if (fwhmba_in_control .or. fwhmba.le.0.) fwhmba = fwhmba_sav
c        ----------------------------------------------------------------------
c        For Lorentzians, FWHM_absv/FWHM_real = sqrt(3) = 1.73.  Use 2.0 below
c        to give more freedom to lineshape to fit strange (apparently)
c        Gaussian windowed Friedman spectra when ABSVAL=T.
c        ----------------------------------------------------------------------
         if (.not.fwhmba_in_control  .and.  absval) fwhmba = 2. * fwhmba
      end if
c
      READ (LBASIS, NML=BASIS1, err=820, end=820)
C
      IF (LPRINT .GT. 0)  WRITE (LPRINT, 5210) IDBASI
 5210 FORMAT (/' Basis set ID = ',A//' No.   Metabolite',3X,
     1        'Expec[delta(1/T2)](1/s)', 3X, 'SD[delta(1/T2)]', 3X,
     2        'Shift(Pts)', 3X, 'SD[Shift](ppm)   ID')
c     -----------------------------------------------------------------------
c     ENCRYP = T to decrypt basis spectra
c     -----------------------------------------------------------------------
      encryp = badelt .lt. 0.
      badelt = abs(badelt)
      IF (AMIN1(DELTAT,BADELT).LE.0. .OR. MIN0(NDATA,NDATAB).LE.0  .or.
     1    ndatab .gt. mdata) CALL ERRMES (1, 4, CHSUBP)
c     ------------------------------------------------------------------------
c     Compare bandwidths.
c     IERROR_BW = 0 if the BWs are equal (and BASIS_BW does not need to be
c                   changed);
C                 1 if BASIS_BW != DATA_BW, which means that the BASIS_BW
c                                           must be converted to the DATA_BW;
c                 2 if BASIS_BW < DATA_BW and 90% of the BASIS_BW is needed
c                   for the Analysis Window, which means that there will very
c                   likely be distortions near the edge.
c                 4 if BASIS_BW < range needed by PPMEND.
c     ------------------------------------------------------------------------
      if (hzpppm_basis .gt. 0.) then
         ppminc_basis = 1. / (badelt * float(ndatab) * hzpppm_basis)
      else
         ppminc_basis = 1. / (badelt * float(ndatab) * hzpppm)
      end if
c     -------------------------------------------------------------------------
c     Set DESDSH if it has not been input positive or set positive in Block
c       Data.
c     -------------------------------------------------------------------------
      if (desdsh .le. 0.) then
         if (rincsh .le. 0.   .or. sdshmn .le. 0.   .or.
     1       sdshmx .lt. sdshmn) call errmes (26, 4, chsubp)
         desdsh = amin1(sdshmx, amax1(sdshmn, rincsh * ppminc_basis))
      end if
      ierror_bw = 0
      IF (ABS(1.-DELTAT/BADELT).GT.1.E-4 .and. .not.bascal) then
         if (BADELT .GT. DELTAT) then
            DATEN = (PPMCEN-PPMEND)/ppmINC_basis + 1.
            if (daten .gt. .45*float(ndatab)) then
               ierror_bw = 2
               if (nint(daten) .ge. ndatab / 2) ierror_bw = 4
               if (lstage .eq. 1   .and.  ierror_bw .ge. 2)
     1            call errmes (2, ierror_bw, chsubp)
            end if
         end if
      END IF
      corr_areaba = .false.
      DO 210 JMETAB=1,999
C
Cvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv For user vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
C
C     TRAMP and VOLUME are the transmitter amplitude and VOI used for scaling
C       the spectra to get absolute concentrations, as discussed in MRM.  If
C       you do not have this data, then you can input TRAMP=VOLUME=1. in
C       NAMELIST BASIS, and the basis spectra will only be normalized to unit
C       concentration (with SCALE=1./CONC) below.  See the User's Manual for
C       the other input.
C
C        Don't forget the END=300 in your READ statement.
C
         READ (LBASIS, NML=BASIS, END=300, err=830)
C
C^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ For user ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
C
         if (metabo .eq. 'GSH'   .and.   gshgua   .and.
     1       nomit .lt. mpmet) then
            nomit = nomit + 1
            chomit(nomit) = 'Gua'
         end if
C        ----------------------------------------------------------------------
C        Omit this spectrum from the basis set, according to the
C          specifications in CHCALI, CHKEEP, PPMMET, CHUSE1, SYNUS1, or CHOMIT.
C        ----------------------------------------------------------------------
         if (ncalib .gt. 0) then
            do 211 j = 1, ncalib
               if (chcali(j) .eq. metabo) go to 216
 211        continue
            if (bascal  .and.  chbcal .eq. metabo) then
               nmetab = nmetab + 1
               go to 245
            end if
            go to 210
         end if
         DO 213 JOMIT=1,NOMIT
            IF (CHOMIT(JOMIT) .EQ. METABO) GO TO 210
  213    CONTINUE
         DO 214 J=1,NKEEP
            IF (CHKEEP(J) .EQ. METABO) GO TO 216
  214    CONTINUE
         DO 215 J=1,MPMET
            IF (CHPMET(J) .EQ. METABO) THEN
               IF ((PPMMET(1,J).GT.PPMST .OR. PPMMET(2,J).LT.PPMEND)
     1             .AND.
     2             (PPMMET(3,J).GT.PPMST .OR. PPMMET(4,J).LT.PPMEND))
     3               GO TO 210
               ppmmet_in_gap(1) = .false.
               ppmmet_in_gap(2) = .false.
               do 2152 jgap = 1, ngap
                  ppmmet_in_gap(1) = ppmmet_in_gap(1)   .or.
     1              (ppmmet(1, j) .le. ppmgap(1, jgap)   .and.
     1               ppmmet(1, j) .ge. ppmgap(2, jgap))   .or.
     1              (ppmmet(2, j) .le. ppmgap(1, jgap)   .and.
     1               ppmmet(2, j) .ge. ppmgap(2, jgap))
                  ppmmet_in_gap(2) = ppmmet_in_gap(2)   .or.
     1              (ppmmet(3, j) .le. ppmgap(1, jgap)   .and.
     1               ppmmet(3, j) .ge. ppmgap(2, jgap))   .or.
     1              (ppmmet(4, j) .le. ppmgap(1, jgap)   .and.
     1               ppmmet(4, j) .ge. ppmgap(2, jgap))
 2152          continue
               if (ppmmet_in_gap(1)   .and.   ppmmet_in_gap(2))
     1            go to 210
            END IF
  215    CONTINUE
 216     IF (LSTAGE .EQ. 1) THEN
            DO 217 JUSE1=1,NUSE1
               IF (US1FUL(JUSE1)) GO TO 217
               IF (CHUSE1(JUSE1) .EQ. METABO) THEN
                  US1FUL(JUSE1)=.TRUE.
                  GO TO 219
               END IF
               DO 218 JSYN=1,MPMET
                  IF (SYNUS1(1,JSYN).EQ.' ' .OR. SYNUS1(2,JSYN).EQ.' ')
     1                 GO TO 217
                  IF ((SYNUS1(1,JSYN).EQ.CHUSE1(JUSE1) .AND.
     1                 SYNUS1(2,JSYN).EQ.METABO)  .OR.
     2                (SYNUS1(2,JSYN).EQ.CHUSE1(JUSE1) .AND.
     3                 SYNUS1(1,JSYN).EQ.METABO)) THEN
                     US1FUL(JUSE1)=.TRUE.
                     GO TO 219
                  END IF
  218          CONTINUE
  217       CONTINUE
            do 2182 j = 1, nnot1
               if (chnot1(j) .eq. metabo) go to 210
 2182       continue
c           -------------------------------------------------------------------
c           BADREF = T will include every metabolite into the Preliminary
c                      Analysis, unless it has been eliminated above.  The
c                      included metabolites will have CHNOLS; i.e., no
c                      lineshape convolution.
c           -------------------------------------------------------------------
            if (badref   .and.   nnolsh .lt. MMETAB_extra) then
c              ----------------------------------------------------------------
c              Must not let a SYNUS1 of another METABO in, since one could fit
c                the peak and the other create havoc.  This is mainly if
c                it is line-shape-enabled, but even if not, there is no sense
c                in ever having two SYNUS1 together in a Preliminary Analysis.
c              ----------------------------------------------------------------
               do 2184 KMETAB=1,NMETAB
                  DO 2185 JSYN=1,MPMET
                     IF (SYNUS1(1,JSYN).EQ.' ' .OR.
     1                   SYNUS1(2,JSYN).EQ.' ') GO TO 2184
                     IF ((SYNUS1(1,JSYN).EQ.NACOMB(kmetab) .AND.
     1                    SYNUS1(2,JSYN).EQ.METABO)  .OR.
     2                   (SYNUS1(2,JSYN).EQ.NACOMB(kmetab) .AND.
     3                    SYNUS1(1,JSYN).EQ.METABO)) go to 210
 2185             CONTINUE
 2184          CONTINUE
               nnolsh = nnolsh + 1
               chnols(nnolsh) = metabo
               go to 219
            end if
            GO TO 210
         else
            do 2188 j = 1, nnot2
               if (chnot2(j) .eq. metabo) go to 210
 2188       continue
         END IF
  219    IF (NMETAB .GE. MMETAB) CALL ERRMES (5, 4, CHSUBP)
         NMETAB=NMETAB+1
         NACOMB(NMETAB)=METABO
         table_top(nmetab) = .true.
         DO 230 J=1,NSDSH
            IF (CHSDSH(J) .EQ. METABO) THEN
               SDSHIF(NMETAB)=ALSDSH(J)
               GO TO 232
            END IF
  230    CONTINUE
         SDSHIF(NMETAB)=DESDSH
  232    DO 234 J=1,NSDT2
            IF (CHSDT2(J) .EQ. METABO) THEN
               SDRT2(NMETAB)=ALSDT2(J)
               GO TO 236
            END IF
  234    CONTINUE
         SDRT2(NMETAB)=DESDT2
  236    DO 238 J=1,NEXT2
            IF (CHEXT2(J) .EQ. METABO) THEN
               EXRT2(NMETAB)=ALEXT2(J)
               GO TO 240
            END IF
  238    CONTINUE
         EXRT2(NMETAB)=DEEXT2
  240    EXRT2(NMETAB) = EXRT2(NMETAB) * RT2_SCALE
         SDRT2(NMETAB) = SDRT2(NMETAB) * RT2_SCALE
         IF (LPRINT .GT. 0) THEN
            IF (LSTAGE .EQ. 1) THEN
               WRITE (LPRINT,5234) NMETAB, METABO, ISHIFT, ID
 5234          FORMAT (1X, I3, 7X, A6, I57, 20X, A20)
            ELSE
               WRITE (LPRINT,5235) NMETAB, METABO, EXRT2(NMETAB),
     1                             SDRT2(NMETAB), ISHIFT,
     2                             SDSHIF(NMETAB), ID
 5235          FORMAT (1X, I3, 7X, A6, 1PE26.4, E18.4, I13, E17.2, 3X,
     1                 A20)
            END IF
         END IF
C        ----------------------------------------------------------------------
C        Convert SDSHIF from ppm to radians/s.
C        ----------------------------------------------------------------------
         SDSHIF(NMETAB)=SDSHIF(NMETAB)*2.*PI*HZPPPM
C        ----------------------------------------------------------------------
C        NCOMPO(JCONC) = no. of metabolites for concentration JCONC
C                      = 1, except for combinations.
C        LCOMPO(J,JCONC) = the subscript for the Jth metabolite in
C                            concentration JCONC, J=1,NCOMPO(JCONC),
C                            JCONC=1,NCONC.
C        ----------------------------------------------------------------------
         NCOMPO(NMETAB)=1
         LCOMPO(1,NMETAB)=NMETAB
C        ----------------------------------------------------------------------
C        BASISF(JDATA) = frequency-domain basis spectrum (COMPLEX).  BASISF
C                          is multiplied by SCALE=TRAMP/(VOLUME*CONC), but not
C                          rearranged and not shifted.
C                        By also dividing by CONC, the solution is already in
C                          concentration units (e.g. mM).
C        ISHIFT = referencing shift for frequency-domain spectrum NMETAB; a
C                 positive ISHIFT shifts the spectrum ISHIFT grid points to
C                 the left, i.e., toward larger ppm.
C        BASIST(JDATA,NMETAB) = inverse FFT of BASISF (COMPLEX).
C        ----------------------------------------------------------------------
C
Cvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv For user vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
C
C        Read full basis array into BASISF.
C
 245     READ (LBASIS, FMTBAS, err=831, end=831) (BASISF(J),J=1,NDATAb)
C
C^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ For user ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

         if (encryp) then
            dix = 1499.d0
            do 247 j = 1, ndatab
               basisf(j) = -basisf(j) * exp(-20. * random(dix) + 10.)
 247        continue
         end if
C
         IF (AMIN1(TRAMP,VOLUME,CONC) .LE. 0.) CALL ERRMES (6, 4,
     1                                                      CHSUBP)
         SCALE=TRAMP/(VOLUME*CONC)
C        ----------------------------------------------------------------------
C        Temporarily put the scaled, but unshifted, frequency-domain data into
C          BASIST(*,NMETAB).
C        ----------------------------------------------------------------------
         DO 250 J=1,NDATAb
            BASIST(J,NMETAB)=BASISF(J)*SCALE
  250    CONTINUE
C        ----------------------------------------------------------------------
c        Take absolute value of basis spectra.  This must be done here, and
c          not below, because full zero-filling of the time data is needed to
c          preserve full information in the absolute value spectrum.
c        The factor of 2. * CABS is to compensate for discarding the
c          symmetric/antisymmetric 2nd half in points NUNFIL+1--NDATA.
c        1st time-data point (the integral over the spectrum) must be halved,
c          to remove the offset produced by cutting off the 2nd half of
c          time data.  See Notes of 010819.
C        ----------------------------------------------------------------------
         if (absval) then
            do 256 j = 1, ndatab
               basisf(j) = 2. * cabs(BASIST(J,NMETAB))
 256        continue
            CALL CFFTIN (BASISF, BASIST(1,NMETAB), NDATAb,
     1           LWFFT, WFFTC)
            BASIST(1,NMETAB) = .5 * BASIST(1,NMETAB)
            do 258 j = (1 + ndatab/2), ndatab
               BASIST(j,NMETAB) = 0.
 258        continue
            call cfft (basist(1,nmetab), basist(1,nmetab), ndatab,
     1           lwfft, wfftc)
         end if
C        ----------------------------------------------------------------------
C        Put shifted frequency-domain data into BASISF.
C        ----------------------------------------------------------------------
         jshift = ishift + nint((4.65 - ppmcen) / ppminc_basis)
         DO 260 J=1,NDATAb
            jshift = jshift + 1
            BASISF(J)=BASIST(ICYCLE(JSHIFT,NDATAb), NMETAB)
  260    CONTINUE

c        ----------------------------------------------------------------------
c        AREABA_ORIG_BASISF = T in the normal case; else, AREABA with
c           transformed BASISF can be inaccurate, e.g., with basis spectra
c           that are truncated because of large AQ and have a peak that is
c           difficult to integrate.  (See Notes of 120929.)
c        Much code is repeated from below, to allow (inaccurate) case to be
c           tested below when AREABA_ORIG_BASISF=F.
c        ----------------------------------------------------------------------
         if (.not.areaba_orig_basisf) go to 269
         dows_now = dows   .and.   lstage .eq. 2   .and.   havh2o  .and.
     1              .not.bascal   .and.
     2              fcalib .gt. .999999   .and.   fcalib .lt. 1.000001
         if (.not.(dows_now .or. (scasim .and. nsimul.gt.0))) go to 269
         if (wsmet .ne. metabo) then
            DO 262 JSYN=1,MPMET
               IF (SYNUS1(1,JSYN).EQ.' ' .OR. SYNUS1(2,JSYN).EQ.' ')
     1              GO TO 269
               IF ((SYNUS1(1,JSYN).EQ.wsmet .AND.
     1              SYNUS1(2,JSYN).EQ.METABO)  .OR.
     2              (SYNUS1(2,JSYN).EQ.wsmet .AND.
     3              SYNUS1(1,JSYN).EQ.METABO)) go to 264
 262        CONTINUE
         end if
 264     area_met_norm = areaba(basisf, ppminc_basis, ndatab/2)
         corr_areaba = .true.

c        ----------------------------------------------------------------------
c        Check (and correct for) inconsistent BWs or field strengths.
c        ----------------------------------------------------------------------
 269     if (bascal) then
            ndata_freq = ndatab
         else
c           ------------------------------------------------------------------
c           Choose NDATA_FREQ so that bw_basis_new = bw_data.
c           If HZPPPM_BASIS is available, then the bandwidth will be adjusted
c             to compensate for the difference between HZPPPM & HZPPPM_BASIS.
c           The following reasoning is used:
c           The basis spectra must be adjusted so that 2 conditions are
c             matched:
c             (1) Basis bandwidth must be changed to data bandwidth.
c                 This is done by truncating or zero-filling the basis
c                   spectra.  The spacing of the basis spectra remains fixed
c                   in this step at 1/(ndatab*badelt*hzpppm_basis).
c                 RNDATA_FREQ = the number of points in DATAT such that the
c                               total time range of DATAT equals that of
c                               BASIST; i.e., such that DATAF has the same
c                               spacing as BASISF
c                             = NDATAB*BADELT*HZPPPM_BASIS/(DELTAT*HZPPPM)
c                 Zero-filling or truncating BASISF to NDATA_FREQ points and
c                   doing an FFTINV produces a BASIST with the same spacing as
c                   DATAT.  This part is independent of NDATA.
c             (2) Basis frequency spacing must be changed to data spacing.
c                   BASIST is zero-filled or truncated to NDATA points, so
c                   that BASISF matches the spacing of DATAF (as calculated in
c                   Step (1)).
c                 This could cause significant errors due to inconsistencies
c                   in the scaling of the basis spectra caused by (differing
c                   effects of truncation).  There should be a warning to be
c                   consistent with NUNFIL*DELTAT with all in vivo data.  In
c                   practice, could partially reduce this effect with FWHMSM
c                   in MakeBasis, especially if AUTOSC=T, but it is nice to
c                   have sharp basis spectra, with plenty of possibility of
c                   lineshape convolution to correct for lineshape.
c           ------------------------------------------------------------------
            if (hzpppm_basis .gt. 0.) then
               rndata_freq = float(ndatab) * badelt * hzpppm_basis /
     1                       (deltat * hzpppm)
               if (lstage .eq. 1   .and.   nmetab .eq. 1) then
c                 -------------------------------------------------------------
c                 Test consistency of field strengths
c                 Variations of GE field strengths among sites seems to be
c                   only  about 1 part in 3000, corresponding to TEST = .00033
c                 However, Danielsen's 1.5 T Siemens was about 0.995 * 1.5T.
c                 Furthermore, the BW correction means that the only
c                   differences will be in the coupling.  So, the threshold
c                   for warning was raised to .05 (from .005).
c                 -------------------------------------------------------------
                  test=abs(hzpppm_basis/hzpppm - 1.)
                  if (test .ge. .2) then
                     call errmes (9, 4, chsubp)
                  else if (test .ge. .05) then
                     call errmes (9, 2, chsubp)
                   end if
               end if
            else
               rndata_freq = float(ndatab) * badelt / deltat
            end if
c           -------------------------------------------------------------------
c           NDATA_FREQ must be even
c           -------------------------------------------------------------------
            ndata_freq = 2 * nint(.5 * rndata_freq)
c           -------------------------------------------------------------------
c           Leave NDATA_FREQ=NDATA if their ratio is within BWTOLR.
c           -------------------------------------------------------------------
            if (abs(1. - rndata_freq / float(ndata)) .le. bwtolr)
     1         ndata_freq = ndata
            if (ndata_freq .gt. mdata) call errmes (35, 4, chsubp)
c           -------------------------------------------------------------------
c           Correct for different lengths of FFTs.  The FFTs must be
c              multiplied by sqrt(N), where N is the number of points.  The
c              factor is sqrt(ndata_freq/ndata).  (See also Notes of 120929.)
c           -------------------------------------------------------------------
            if (corr_areaba) then
               area_met_norm = area_met_norm *
     1            sqrt(float(ndata_freq) / float(ndata))
               corr_areaba = .false.
            end if
            if (ndata_freq .ne. ndatab) then
c              ----------------------------------------------------------------
c              Change bw_basis to bw_data, and put result temporarily into
c                BASIST.  This part is independent of NDATA.  It is Step (1)
c                described after 260 above.
c              ----------------------------------------------------------------
               if (ndata_freq .gt. ndatab) then
                  do 270 j = 1, ndata_freq
                     basist(j, nmetab) = 0.
 270              continue
               end if
c              ----------------------------------------------------------------
c              1st into 1st half
c              ----------------------------------------------------------------
               nhalf = min0(ndata_freq, ndatab) / 2
               do 272 j = 1, nhalf
                  basist(j, nmetab) = basisf(j)
 272           continue
c              ----------------------------------------------------------------
c              Now into 2nd half
c              ----------------------------------------------------------------
               jin = ndatab
               do 274 jout = ndata_freq, ndata_freq - nhalf + 1, -1
                  basist(jout, nmetab) = basisf(jin)
                  jin = jin - 1
 274           continue
c              ----------------------------------------------------------------
c              Now everything back into BASISF
c              ----------------------------------------------------------------
               do 275 j = 1, ndata_freq
                  basisf(j) = basist(j, nmetab)
 275           continue
            end if
         end if
C        ----------------------------------------------------------------------
C        Do an inverse FFT of BASISF to put the time-domain data
C          into BASIST(*,NMETAB).
C        ----------------------------------------------------------------------
         if (bascal  .and.  chbcal .eq. metabo) then
            CALL CFFTIN (BASISF, datat, NDATA_freq,
     1                LWFFT, WFFTC)
            nmetab = nmetab - 1
            go to 210
c            go to 9999
         else
            CALL CFFTIN (BASISF, BASIST(1,NMETAB), NDATA_freq,
     1           LWFFT, WFFTC)
         end if
C        ----------------------------------------------------------------------
c        The following was used from 5.2-3B to 6.0-2C based on the incorrect
c          reasoning.  See Notes 040118.
C        ----------------------------------------------------------------------
c         basist(1, nmetab) = basist(1, nmetab) * float(ndata) /
c     1                                           float(ndata_freq)
C        ----------------------------------------------------------------------
c        Zero-fill BASIST.  This is (the final) Step (2) described after 260
c          above.
C        ----------------------------------------------------------------------
         if (ndata_freq .lt. ndata) then
            do 280 j = ndata_freq + 1, ndata
               basist(j, nmetab) = 0.
 280        continue
         end if
C        ----------------------------------------------------------------------
c        BASOUT = T to write out modified BASIS file.
c        ABSVAL = T is not permitted when BASOUT=T
C        ----------------------------------------------------------------------
         if (basout   .and.   absval) call errmes (14, 3, chsubp)
         if (basout   .and.   ndata_freq .eq. ndata   .and.
     1       ndata_freq .eq. ndatab) call errmes (15, 1, chsubp)
         if (basout   .and.   (ndata_freq .ne. ndata   .or.
     1                         ndata_freq .ne. ndatab)   .and.
     2       lstage .eq. 2   .and.   .not.absval) then
            if (nmetab .eq. 1) then
               lfilbas = ilen(filbas)
               lastdot = 0
               lastslash = 0
               do 282 j = 1, lfilbas
                  if (filbas(j:j) .eq. '.') lastdot = j
                  if (filbas(j:j) .eq. '/') lastslash = j
 282           continue
               if (lastdot .gt. lastslash) then
                  file_basout = filbas(1:lastdot-1) // '-new-bw' //
     1                          filbas(lastdot:lfilbas)
               else
                  file_basout = filbas(1:lfilbas) // '-new-bw'
               end if
               OPEN (21, FILE=file_basout, STATUS='UNKNOWN', err=832)
               write (21, nml=seqpar)
               j = min0(ilen(idbasi),mchidb-3)
               idbasi(j+2:j+3) = 'BW'
               badelt_save = badelt
               badelt = deltat
               ndatab_save = ndatab
               ndatab = ndata
               write (21, nml=basis1)
               badelt = badelt_save
               ndatab = ndatab_save
            end if
            conc=1.
            tramp=1.
            volume=1.
            ishift = nint((ppmcen - 4.65) / ppminc)
            write (21, nml=basis)
            call cfft (basist(1,nmetab), basisf, ndata, lwfft, wfftc)
            write (21, FMTBAS) (BASISF(J),J=1,NDATA)
         end if
c        --------------------------------------------------------------------
c        Suppress convolution with Lineshape (and broaden with a Gaussian
c          with FWHM=FWHMST) according to CHNOLS, when LSTAGE=1.
c        This is mainly for Lac & Ala when simulated lipids are being used.
c        Broadening from CHANGE-RAW.f is used below
c        --------------------------------------------------------------------
         if (lstage .eq. 1   .and.   nnolsh .gt. 0) then
            do 285 j = 1, nnolsh
               if (metabo .eq. chnols(j)) then
                  call set_lshape_false ()
                  go to 289
               end if
 285        continue
         end if
 289     continue
c        --------------------------------------------------------------------
c        Try scaling, if needed.
c        (The 2 statements containing 9999 can be uncommented to test the
c          SCASIM=T scaling using BASCAL with CHCALI(1)='SimCr' & CHBCAL='Cr'.)
c        --------------------------------------------------------------------
c9999     continue
         dows_now = dows   .and.   lstage .eq. 2   .and.   havh2o  .and.
     1              .not.bascal   .and.
     2              fcalib .gt. .999999   .and.   fcalib .lt. 1.000001
         if (.not.(dows_now .or. (scasim .and. nsimul.gt.0))) go to 210
         if (wsmet .ne. metabo) then
            DO 290 JSYN=1,MPMET
               IF (SYNUS1(1,JSYN).EQ.' ' .OR. SYNUS1(2,JSYN).EQ.' ')
     1              GO TO 210
               IF ((SYNUS1(1,JSYN).EQ.wsmet .AND.
     1              SYNUS1(2,JSYN).EQ.METABO)  .OR.
     2              (SYNUS1(2,JSYN).EQ.wsmet .AND.
     3              SYNUS1(1,JSYN).EQ.METABO)) go to 295
 290        CONTINUE
         end if
c        --------------------------------------------------------------------
c        Get BASISF for the new BW.
c        Scaling by sqrt(ndata_freq/ndata) leads to absurd results in extreme
c           cases.
c        --------------------------------------------------------------------
 295     if (ndata_freq .ne. ndata)
     1      call cfft (basist(1, nmetab), basisf, ndata, lwfft, wfftc)
c        --------------------------------------------------------------------
c        This call to AREABA is superceded.  It will normally be skipped,
c           because AREA_MET_NORM will have been calculated above in the
c           normal case that the original basis spectrum instead of the
c           transformed spectrum is integrated above, because
c           AREABA_ORIG_BASISF = T.
c        --------------------------------------------------------------------
         if (area_met_norm .le. 0.)
     1          area_met_norm = areaba(basisf, ppminc, nunfil)
C        ----------------------------------------------------------------------
c        Try water scaling
C        ----------------------------------------------------------------------
         if (dows_now   .and.   area_met_norm .gt. 0.)
     1      call water_scale ()
  210 CONTINUE
c     -------------------------------------------------------------------------
c     NSIMUL <= MMETAB = # extra model spectra to be synthesized
c     MGAU = 20 = max # of Gaussian components in a synthesized model spectrum
c     CHSIM(JSIMUL)*6 = name
c     SIFWMN(JGAU,JSIMUL) = FWHM of Gaussian JGAU
c                         < 0 for SIFWMN=FWHMBA and EXRT2 SDRT2 SDSH = DE*
c     SIFWEX(JSIMUL) = Expected FWHM of Gaussian JGAU=1  This determines EXRT2
c                      (of course, for the whole simulated spectrum, not just
C                       JGAU=1)
c     SIFWSD(JSIMUL) = SD of FWHM of Gaussian JGAU=1.  This determines SDRT2
c                      (of course, for the whole simulated spectrum, not just
C                       JGAU=1)
c     NGAU(JSIMUL) = # of Gaussian components in a synthesized model spectrum
c                    JSIMUL
c     SISDSH(JSIMUL) = SD of shift (ppm) (as ALSDSH & DESDSH)
c     SIAMP(JGAU, JSIMUL) = amplitude
c     SIPPM(JGAU, JSIMUL) = chemical shift, except for IMETHD=2:

c     IMETHD = 2 to replace lineshape regularizor with a linewidth
c                regularizor  minimizing
c                c_j/c^0_j * (gamma^0_j + RLRNTZ*gamma_j)**IPOWRG, where
c                c_j = CONC parameter (as usual)
c                gamma_j = 1/RT2 (as usual)
c                gamma^0_j = pi * HZPPPM * SIFWMN(1, JSIMUL)
c                Single-peaked simulations are assumed.
c                c^0_jsimul = SIAMP(2, JSIMUL).  This is signaled by:
c                SIPPM(2, JSIMUL) >= 999, which causes NGAU=1 to be used.
c                So, 2nd component is: @999. FWHM=1. AMP=c^0_jsimul

c     IMETHD = 3 to broaden by multiplying DATAT by factors of form
c                exp(-PARNLN(J) * T ** POWER(K)), where model NMETAB has
c                POWER(1), ... POWER(NPOWER(NMETAB)) powers.
c

c     SIDUMP(JSIMUL) = T to abort and produce a plot of the real part of
c                        simulated model spectrum JSIMUL.
c
c     -------------------------------------------------------------------------
  300 if (nsimul .gt. 0) then
         if (nsimul .gt. mmetab - nmetab) call errmes (16, 4, chsubp)
         if (lstage .eq. 1) call parse_chsimu ()
         if (gauss_rt2   .and.   lprint .gt. 0) write(lprint, 5305)
 5305    format(' No.   Metabolite', 9x, 'EXRT2', 6x,
     1          'SIFWEX  input', 3x, 'SIFWMN', 14x, 'SDRT2', 6x,
     1          'SIFWSD   input', 3x, 'SD[Shift](ppm)')
         do 310 jsimul = 1, nsimul
            metabo = chsim(jsimul)
            if (ncalib .gt. 0) then
               do 312 j = 1,ncalib
                  if (chcali(j) .eq. metabo) go to 316
 312           continue
               go to 310
            end if
c           -------------------------------------------------------------------
c           Omit spectrum according to CHOMIT.
c           -------------------------------------------------------------------
            DO 303 JOMIT=1,NOMIT
               IF (CHOMIT(JOMIT) .EQ. METABO) GO TO 310
 303        CONTINUE
            DO 314 J=1,NKEEP
               IF (CHKEEP(J) .EQ. METABO) GO TO 316
 314        CONTINUE
            DO 315 J=1,MPMET
               IF (CHPMET(J) .EQ. METABO) THEN
                  IF ((PPMMET(1,J).GT.PPMST .OR. PPMMET(2,J).LT.PPMEND)
     1                 .AND.
     2                (PPMMET(3,J).GT.PPMST .OR. PPMMET(4,J).LT.PPMEND))
     3                 GO TO 310
               END IF
 315        CONTINUE
c           -------------------------------------------------------------------
c           Omit spectrum according to SIPPM and [PPMST,PPMEND]
c           Could set
c             DISTMX = .5 * SIFWEX(JSIMUL)
c             since it could intrude.  However, user should be sensible enough
c             to include the whole peak.
c           -------------------------------------------------------------------
            if (chksim) then
               distmx = 0.
               do 305 jgau = 1, ngau(jsimul)
                  do 307 jgap = 1, ngap
                     if (sippm(jgau,jsimul) .le. ppmgap(1, jgap)   .and.
     1                   sippm(jgau,jsimul) .ge. ppmgap(2, jgap))
     2                  go to 310
 307               continue
                  if (sippm(jgau,jsimul) - distmx .lt. ppmst   .and.
     1                sippm(jgau,jsimul) + distmx .gt. ppmend) go to 316
 305           continue
               go to 310
            end if
 316        if (lstage .eq. 1) then
c              ----------------------------------------------------------------
c              Omit spectrum according to CHNOT1 & CHUSE1
c              ----------------------------------------------------------------
               do 3182 j = 1, nnot1
                  if (chnot1(j) .eq. metabo) go to 310
 3182          continue
               DO 317 JUSE1=1,NUSE1
                  IF (US1FUL(JUSE1)) GO TO 317
                  IF (CHUSE1(JUSE1) .EQ. METABO) THEN
                     US1FUL(JUSE1)=.TRUE.
                     GO TO 329
                  END IF
                  DO 318 JSYN=1,MPMET
                     IF (SYNUS1(1,JSYN).EQ.' ' .OR.
     1                   SYNUS1(2,JSYN).EQ.' ') GO TO 317
                     IF ((SYNUS1(1,JSYN).EQ.CHUSE1(JUSE1) .AND.
     1                    SYNUS1(2,JSYN).EQ.METABO)  .OR.
     2                    (SYNUS1(2,JSYN).EQ.CHUSE1(JUSE1) .AND.
     3                    SYNUS1(1,JSYN).EQ.METABO)) THEN
                        US1FUL(JUSE1)=.TRUE.
                        GO TO 329
                     END IF
 318              CONTINUE
 317           CONTINUE
c              ----------------------------------------------------------------
c              BADREF = T will include every metabolite into the Preliminary
c                         Analysis, unless it has been eliminated above.  The
c                         included metabolites will have CHNOLS; i.e., no
c                         lineshape convolution.
c              Arbitrarily set SIFWSD; it will not be used (but will
c                still be checked below when LSTAGE=2).
c              ----------------------------------------------------------------
               if (badref) then
c                 -------------------------------------------------------------
c                      Must not let a SYNUS1 of another METABO in, since one
c                 could fit the peak and the other create havoc.  This is
c                 mainly if it is line-shape-enabled, but even if not,
c                 there is no sense in ever having two SYNUS1 together in a
c                 Preliminary Analysis.
c                 -------------------------------------------------------------
                  do 3184 KMETAB=1,NMETAB
                     DO 3185 JSYN=1,MPMET
                        IF (SYNUS1(1,JSYN).EQ.' ' .OR.
     1                       SYNUS1(2,JSYN).EQ.' ') GO TO 3184
                        IF ((SYNUS1(1,JSYN).EQ.NACOMB(kmetab) .AND.
     1                       SYNUS1(2,JSYN).EQ.METABO)  .OR.
     2                      (SYNUS1(2,JSYN).EQ.NACOMB(kmetab) .AND.
     3                       SYNUS1(1,JSYN).EQ.METABO)) go to 310
 3185                CONTINUE
 3184             CONTINUE
                  do 322 j = 1, nnot2
                     if (chnot2(j) .eq. metabo)
     1                  sifwsd(jsimul) = .5 * sifwex(jsimul)
 322              continue
                  go to 329
               end if
               GO TO 310
            else
c              ----------------------------------------------------------------
c              LSTAGE=2.  Omit spectrum according to CHNOT2
c              ----------------------------------------------------------------
               do 325 j = 1, nnot2
                  if (chnot2(j) .eq. metabo) go to 310
 325           continue
               if (scafwh) then
c                 ------------------------------------------------------------
c                 Scale SIFW* by FWHMST from LSTAGE=1
c                 ------------------------------------------------------------
                  term = amax1(fwhmst, fwhmmn)
                  sifwmn(1, jsimul) = sifwmn(1, jsimul) * term
                  sifwex(jsimul) = sifwex(jsimul) * term
                  sifwsd(jsimul) = sifwsd(jsimul) * term
               end if
            END IF
 329        nmetab = nmetab + 1
            if (nmetab .gt. mmetab) call errmes (25, 4, chsubp)
            NACOMB(NMETAB)=METABO
c           ----------------------------------------------------------------
c           Use Lineshape only if simulating basis spectrum or if specified
c             by CHLSHA & NLSHAP (or if NOBASI=T ???)
c           ----------------------------------------------------------------
            lshape(nmetab) = sifwmn(1, jsimul) .le. 0.
            table_top(nmetab) = lshape(nmetab)
            if (.not.lshape(nmetab)) then
               do 330 j = 1, nlshap
                  if (chlsha(j) .eq. metabo) lshape(nmetab) = .true.
 330           continue
            end if
c           -------------------------------------------------------------------
c           Compute SDRT2 & EXRT2 from the 3 SIFW*, assuming additivity of
c             variances.
c           *_EXTRA are the ranges needed; SDRT2 should be about HZ_EXTRA/3.
c           EXRT2_MIN, SDRT2_MIN & SDSHIF_MIN are defined here rather than
c             input.  They are to avoid ill-conditioning due to too strong
c             priors.
c           -------------------------------------------------------------------
            if (sifwmn(1, jsimul) .le. 0.) then
c              ----------------------------------------------------------------
c              Special case for simulating basis spectra, using FWHMBA and
c                DE* for broadening & shift priors.
c              In this case, only CHSIM, SIPPM & SIAMP are used from CHSIMU;
c                SISDSH, SIFWEX & SIFWSD are not used (and must have SIFWMN<0).
c              ----------------------------------------------------------------
               exrt2(nmetab) = deext2 * RT2_SCALE
               sdrt2(nmetab) = desdt2 * RT2_SCALE
               sdshif(nmetab) = desdsh
            else
               if (imethd .eq. 3) then
c                 -------------------------------------------------------------
c                 Special use of SIFWSD = NPOWER
c                 -------------------------------------------------------------
                  npower(nmetab) = nint(sifwsd(jsimul))
                  if (.not.nobasi   .or.   npower(nmetab) .lt. 1
     1                .or.   npower(nmetab) .gt. mmpowr)
     2                 call errmes (39, 4, chsubp)
               else
c                 -------------------------------------------------------------
c                 SIFWMN (and all other SI*) input (not simulating with
c                    FWHMBA, etc)
c                 -------------------------------------------------------------
                  if (sifwmn(1,jsimul) .ge. sifwex(jsimul)  .or.
     1               sifwsd(jsimul) .le. 0.) call errmes (18, 4, chsubp)
c                 -------------------------------------------------------------
c                 GAUSS_RT2 = T only for old computation of EXRT2 & SDRT2
c                              based (incorrectly) on Gaussian broadening,
c                              instead of Lorentzian broadening.  This will be
c                              the default, for backward compatibility.
c                 -------------------------------------------------------------
                  if (gauss_rt2) then
                     fwhm_ex = sqrt(sifwex(jsimul)**2 -
     1                              sifwmn(1,jsimul)**2)
                  else
                     fwhm_ex = sifwex(jsimul) - sifwmn(1,jsimul)
                  end if
                  exrt2(nmetab) = pi * hzpppm * fwhm_ex
                  EXRT2_MIN = .5
                  if (exrt2(nmetab) .lt. EXRT2_MIN) then
                     call errmes (19, 2, chsubp)
                     exrt2(nmetab) = EXRT2_MIN
                  end if
                  if (gauss_rt2) then
c                 -------------------------------------------------------------
c                 GAUSS_RT2 led to excessive SIFWSD.
c                 The following formula is the solution of the quadratic
c                   equation requiring that (EXRT2 + SDRT2) produce a
c                   broadened peak with FWHM = SIFWEX + SIFWSD; i.e.,
c                 sqrt{SIFWMN**2 + [(EXRT2+SDRT2)/pi*HZPPPM]**2} = SIFWEX +
c                                                                  SIFWSD
c                 It was also checked numerically
c                 -------------------------------------------------------------
                     sdrt2(nmetab) = pi * hzpppm *
     1                               sqrt((sifwex(jsimul) +
     2                                     sifwsd(jsimul))**2 -
     3                              sifwmn(1,jsimul)**2) - exrt2(nmetab)
                  else
                     sdrt2(nmetab) = pi * hzpppm * sifwsd(jsimul)
                  end if
                  SDRT2_MIN = .25
                  if (sdrt2(nmetab) .lt. SDRT2_MIN) then
                     call errmes (20, 2, chsubp)
                     sdrt2(nmetab) = SDRT2_MIN
                  end if
               end if
c              ----------------------------------------------------------------
c              SISDSH is only necessary when LSTAGE=2 is used.  With BADREF=T,
c                it may be that it is only used when LSTAGE=1.
c              ----------------------------------------------------------------
               if (sisdsh(jsimul) .le. 0.  .and.  lstage .eq. 2)
     1              call errmes (21, 4, chsubp)
               sdshif(nmetab) = sisdsh(jsimul)
c              ----------------------------------------------------------------
c              Might have to change SDSHIF_MIN for other nuclei.
c              ----------------------------------------------------------------
               SDSHIF_MIN = ppminc / 10.
               if (sdshif(nmetab) .lt. SDSHIF_MIN   .and.
     1             lstage .eq. 2) then
                  if (sptype(:7) .ne. 'muscle-')
     1               call errmes (21, 2, chsubp)
                  sdshif(nmetab) = SDSHIF_MIN
               end if
            end if

            IF (LPRINT .GT. 0) THEN
               IF (LSTAGE .EQ. 1) THEN
                  WRITE (LPRINT,5334) NMETAB, METABO
 5334             FORMAT (1X, I3, 7X, A6)
               ELSE
                  if (imethd .eq. 3) then
 5337                format(1X, I3, 7X, A6, i4, f9.3)
                     write (lprint, 5337) NMETAB, METABO,
     1                                    npower(nmetab), sdshif(nmetab)
                  else
                     if (gauss_rt2) then
                        write(lprint, 5336) NMETAB, METABO,
     1                     EXRT2(NMETAB),
     2                     exrt2(nmetab)/(pi*hzpppm) + sifwmn(1,jsimul),
     3                     sifwex(jsimul), sifwmn(1, jsimul),
     4                     sdrt2(nmetab), sdrt2(nmetab)/(pi*hzpppm),
     5                     sifwsd(jsimul), sdshif(nmetab)
 5336                   format(1X, I3, 7X, A6, f14.3, f12.3, f7.3, f9.3,
     1                         f19.3, f12.4, f8.4, f17.3)
                     else
                        WRITE (LPRINT,5335) NMETAB, METABO,
     1                  EXRT2(NMETAB), SDRT2(NMETAB), SDSHIF(NMETAB)
 5335                   FORMAT (1X, I3, 7X, A6, 1PE26.4, E18.4, 13x,
     1                          E17.2)
                     end if
                  end if
               END IF
            END IF
C           -------------------------------------------------------------------
C           Convert SDSHIF from ppm to radians/s.
C           -------------------------------------------------------------------
            SDSHIF(NMETAB)=SDSHIF(NMETAB)*2.*PI*HZPPPM
C           -------------------------------------------------------------------
C           NCOMPO(JCONC) = no. of metabolites for concentration JCONC
C                         = 1, except for combinations.
C           LCOMPO(J,JCONC) = the subscript for the Jth metabolite in
C                             concentration JCONC, J=1,NCOMPO(JCONC),
C                             JCONC=1,NCONC.
C           -------------------------------------------------------------------
            NCOMPO(NMETAB)=1
            LCOMPO(1,NMETAB)=NMETAB
c           -------------------------------------------------------------------
c           Simulate (real) spectrum, using strategy from
c             real-spectra-only/make-raw.f
c           SUM = sum over spectrum, for direct comparison with PPMINC*sum in
c                 AREA_MET_NORM
c           -------------------------------------------------------------------
            if (ngau(jsimul) .le. 0   .or.
     1          ngau(jsimul) .gt. mgau) call errmes (17, 4, chsubp)

            do 340 jdata = 1, ndata
               basisf(jdata) = (0.,0.)
 340        continue
            expmax = 2. * alog(rrange)
c            sum = 0.
            kpower = 0
            if (imethd .eq. 2   .and.    ngau(jsimul) .ne. 2)
     1         call errmes (40, 4, chsubp)
            do 350 jgau = 1, ngau(jsimul)
               if (sifwmn(1, jsimul) .le. 0.) then
c                 -------------------------------------------------------------
c                 Special case for simulating basis spectra.
c                 -------------------------------------------------------------
                  if (nobasi   .or.   imethd .eq. 2   .or.
     1               imethd .eq. 3) call errmes (37, 4, chsubp)
                  rsd = 2. * sqrt(2. * alog(2.)) / fwhmba
               else
                  if (sifwmn(jgau, jsimul) .le. 0.)
     1                  call errmes (24, 4, chsubp)
                  rsd = 2. * sqrt(2. * alog(2.)) / sifwmn(jgau, jsimul)
               end if
               if (imethd .eq. 2   .and.  jgau .eq. 2) then
                  if (sippm(2, jsimul) .le. 998.   .or.
     1                siamp(2, jsimul) .le. 0.   .or.   .not.nobasi)
     2               call errmes (36, 4, chsubp)
                  if (lstage .eq. 1) then
                     conc_expect(nmetab) = siamp(2, jsimul)
                  else
                     if (fconc_expect .le. 0.)
     1                   call errmes (38, 4, chsubp)
                     conc_expect(nmetab) = siamp(2, jsimul) *
     1                                     fconc_expect
                  end if
                  rt2min(nmetab) = pi * hzpppm * sifwmn(1, jsimul)
                  go to 350
               else if (imethd .eq. 3) then
                  if (sippm(jgau, jsimul) .gt. 998.) then
                     kpower = kpower + 1
                     fract_power_sd(kpower, nmetab) =
     1                  sifwmn(jgau, jsimul)
                  end if
               else
                  if (abs(siamp(jgau,jsimul)) .le. 0.   .or.
     1                abs(sippm(jgau,jsimul)) .gt. 998.)
     2               call errmes (22, 4, chsubp)
               end if
               if (sippm(jgau, jsimul) .le. 998.) then
                  anorm = siamp(jgau,jsimul) * rsd / sqrt(2. * pi)
                  xppm = ppmcen + nunfil * ppminc
                  do 360 jdata = 1, ndata
                     expon = (rsd * (xppm - sippm(jgau,jsimul)))**2
                     if (expon .lt. expmax) then
                        term = anorm * exp(-.5 * expon)
                        basisf(jdata) = basisf(jdata) + term
c                        sum = sum + term
                     end if
                     xppm = xppm - ppminc
 360              continue
               end if
 350        continue
c           -------------------------------------------------------------------
c           Arrange (as BASISF normally is, i.e., "not rearranged").
c           -------------------------------------------------------------------
            do 370 j = 1, nunfil
               cterm(1) = basisf(nunfil + j)
               basisf(nunfil + j) = basisf(j)
               basisf(j) = cterm(1)
 370        continue
            if (absval) then
c              ----------------------------------------------------------------
c              Take absolute value of basis spectra and compute BASIST.
c              ----------------------------------------------------------------
               do 372 j = 1, ndata
                  basisf(j) = cabs(BASISf(J))
 372           continue
               CALL CFFTIN (BASISF, BASIST(1,NMETAB), NDATA,
     1                      LWFFT, WFFTC)
               BASIST(1,NMETAB) = .5 * BASIST(1,NMETAB)
            else
               call  CFFTin (basisf, basist(1, nmetab), NDATA, LWFFT,
     1                       WFFTC)
            end if
c           -------------------------------------------------------------------
c           Replace 2nd half with zeroes.
c           See comments after 250 explaining that the factor of 2 below
c           is needed, apparently because the 2nd half of the
c           symmetric/antisymmetric part is zeroed.
c                This factor of 2 also gave correct calibration between a
c           simulated Cr and a basis Cr, both with ABSVAL=T & F.
c           -------------------------------------------------------------------
            do 373 junfil = 1, nunfil
               basist(junfil, nmetab) = 2. * basist(junfil, nmetab)
               basist(nunfil + junfil, nmetab) = (0.,0.)
 373        continue
c           -------------------------------------------------------------------
c                Correct possible remaining offset, apparently due to the
c           finiteness of the frequency range.  It is bigger with broad
c           simulated peaks.
c           -------------------------------------------------------------------
            call cfft_r (basist(1, nmetab), basisf, ndata, lwfft, wfftc)
            offset_start = (0., 0.)
            offset_end = (0., 0.)
            do 375 j = 1, 5
               offset_start = offset_start + basisf(j)
               offset_end = offset_end + basisf(ndata - j + 1)
 375        continue
            if (abs(real(offset_start)) .lt. abs(real(offset_end))) then
               basist(1, nmetab) = basist(1, nmetab) - .2 *
     1                             sqrt(float(ndata)) * offset_start
            else
               basist(1, nmetab) = basist(1, nmetab) - .2 *
     1                             sqrt(float(ndata)) * offset_end
            end if
c           -------------------------------------------------------------------
c           For more realistic LSTAGE=1 (and initial FWHM and lineshape),
c             exponentially broaden model spectrum according to EXRT2
c           SCAFWH assumes that there is Gaussian broadening in Prel (to
c             determine FWHMST and broadness of models.
c           -------------------------------------------------------------------
            if (lstage .eq. 1   .and.   .not.lshape(nmetab)   .and.
     1          .not.scafwh   .and.   imethd .ne. 3) then
               factor = exp(-deltat * exrt2(nmetab))
               term = 1.
               do 380 junfil = 1, nunfil
                  basist(junfil, nmetab) = term * basist(junfil, nmetab)
                  term = term * factor
 380           continue
            end if
c           ------------------------------------------------------------------
c           Scale spectrum to be consistent with Basis Set.  If total SIAMP is
c             the number of visible protons, then CONC should be in mM.
c           Correct normalization (to 5 places) was verified by checking that
c           PPMINC*SUM = SIAMP(1, JSIMUL) when NGAU=1, by evaluating SUM above.
c           ------------------------------------------------------------------
            if (scasim) then
               if (area_met_norm .le. 0.) then
c                 ------------------------------------------------------------
c                      This error message will be called once for each
c                 simulated metabolite that cannot be scaled in the
c                 Final Analysis.
c                 ------------------------------------------------------------
                  if (.not.dofull) call errmes (34, 3, chsubp)
               else
c                  factor = siamp(1,jsimul) / (ppminc * sum)
c                  if (lprint .gt. 0) then
c                     write (lprint, 5380) factor
c 5380                format (/'The following normalization check ',
c     1                        'should equal 1:', 1pe12.4)
c                  end if
                  do 385 junfil = 1, nunfil
                     basist(junfil, nmetab) = area_met_norm *
     1                                        basist(junfil, nmetab)
 385              continue
               end if
            end if
c           -------------------------------------------------------------------
c           Dump model spectrum for viewing absolute value.
c           -------------------------------------------------------------------
            if (sidump(jsimul)) then
               do 390 jdata = 1, ndata
                  datat(jdata) = basist(jdata, nmetab)
 390           continue
c               open (22, file='/tmp/tmp/dump.raw', status='unknown')
c               write (22, 9370)
c 9370          format (' $NMID fmtdat=''(1p2e15.6)'' $END')
c               write (22, 9375) (datat(j), j=1,ndata)
c 9375          format (1p2e15.6)
               istago = 1
               call errmes (23, 4, chsubp)
            end if
c           -------------------------------------------------------------------
c           Add 2 additional BASIST for 1st-order Taylor terms for shift &
c             broadening for Preliminary Analysis.
c           -------------------------------------------------------------------
            if (lstage .eq. 1   .and.   sitayl(jsimul)) then
               if (nmetab + 2 .gt. mmetab) call errmes (36, 4, chsubp)
               rtime = 0.
               do 410 junfil = 1, nunfil
                  cterm(1) = rtime * basist(junfil, nmetab)
                  basist(junfil, nmetab + 1) = cterm(1)
                  basist(junfil, nmetab + 2) = cmplx(-aimag(cterm(1)),
     1                                               real(cterm(1)))
                  basist(junfil + nunfil, nmetab + 1) = (0.,0.)
                  basist(junfil + nunfil, nmetab + 2) = (0.,0.)
                  rtime = rtime + deltat
 410           continue
               if (jsimul .lt. 10) then
                  write (metabo, 5410) jsimul
 5410             format ('Brod-', i1)
               else
                  write (metabo, 5415) jsimul
 5415             format ('Brod', i2)
               end if
               NMETAB=NMETAB+1
               table_top(nmetab) = .false.
               NACOMB(NMETAB)=METABO
               NCOMPO(NMETAB)=1
               LCOMPO(1,NMETAB)=NMETAB
               nonneg(nmetab) = .false.

               if (jsimul .lt. 10) then
                  write (metabo, 5420) jsimul
 5420             format ('Shif-', i1)
               else
                  write (metabo, 5425) jsimul
 5425             format ('Shif', i2)
               end if
               NMETAB=NMETAB+1
               table_top(nmetab) = .false.
               NACOMB(NMETAB)=METABO
               NCOMPO(NMETAB)=1
               LCOMPO(1,NMETAB)=NMETAB
               nonneg(nmetab) = .false.
            end if
 310     continue
      end if
      IF (NMETAB .LE. 0) CALL ERRMES (7, 4, CHSUBP)
      IF (NMETAB.LT.NUSE1 .AND. LSTAGE.EQ.1   .and.   .not.omit_chless)
     1     CALL ERRMES (8, 2, CHSUBP)
c     -------------------------------------------------------------------------
c     Make CPRIOR_SHIFT for constraining shifts of a group from its mean.
c     -------------------------------------------------------------------------
      if (lstage .eq. 2) call make_cgroup_shift()
c     -------------------------------------------------------------------------
c     Water-scaling when NOBASI=T
c     -------------------------------------------------------------------------
      if (nobasi   .and.   dows   .and.   lstage .eq. 2   .and.
     1    havh2o  .and.
     2    fcalib .gt. .999999   .and.   fcalib .lt. 1.000001) then
         area_met_norm = 1.
         call water_scale ()
      end if
      if (basout   .and.   ndata_freq .ne. ndata   .and.
     1    lstage .eq. 2   .and.   .not.absval) then
c        ---------------------------------------------------------------------
c        Intel Windows version outputs Namelists that cannot be read; so do
c           not bother to fix Cyg Namelist.
c        ---------------------------------------------------------------------
C        call fix_g77_namelist(21) !sun
         close (21)
      end if
      CLOSE (LBASIS)
      return
 810  call errmes (28, 4, chsubp)
 820  call errmes (29, 4, chsubp)
 830  call errmes (30, 4, chsubp)
 831  call errmes (31, 4, chsubp)
 832  call errmes (32, 4, chsubp)
      END
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      subroutine make_cgroup_shift()
c
      INCLUDE 'lcmodel.inc'
      external ilen
c
      chsubp = 'GRPSHF'
      nrow_group_shift = 0
      if (ngrsh .gt. mgroup_shift) then
         call errmes (1, 3, chsubp)
         ngrsh = mgroup_shift
      end if
      do 110 jgroup = 1, ngrsh
         nin_group = 0
         do 130 jmetab = 1, nmetab
            lchgr = ilen(chgrsh(jgroup))
            if (lchgr .le. 0) go to 130
            if (index(nacomb(jmetab), chgrsh(jgroup)(:lchgr)) .eq. 1)
     1           nin_group = nin_group + 1
 130     continue
         if (nin_group .le. 1) go to 110
         if (sdgrsh(jgroup) .le. 0.) call errmes(2, 4, chsubp)
c        ----------------------------------------------------------------------
c        Might have to change SDSHIF_MIN  for other nuclei.
c        ----------------------------------------------------------------------
         SDSHIF_MIN = ppminc / 50.
         if (sdgrsh(jgroup) .lt. SDSHIF_MIN) then
            call errmes (3, 2, chsubp)
            sdgrsh(jgroup) = SDSHIF_MIN
         end if
         term = 1. / float(nin_group)
         do 140 kmetab = 1, nmetab
            lchgr = ilen(chgrsh(jgroup))
            if (lchgr .le. 0) go to 140
            if (index(nacomb(kmetab), chgrsh(jgroup)(:lchgr)) .ne. 1)
     1           go to 140
            nrow_group_shift = nrow_group_shift + 1
            lmetab_shift_prior(nrow_group_shift) = kmetab
C           -------------------------------------------------------------------
C           Convert SD from ppm to radians/s.
C           -------------------------------------------------------------------
            sdgroup_shift_row(nrow_group_shift) = sdgrsh(jgroup) * 2. *
     1                                            PI * HZPPPM
            do 150 j = 1, mmetab
               cgroup_shift(nrow_group_shift, j) = 0.
 150        continue
            do 160 jmetab = 1, nmetab
               lchgr = ilen(chgrsh(jgroup))
               if (lchgr .le. 0) go to 160
               if (index(nacomb(jmetab), chgrsh(jgroup)(:lchgr)) .ne. 1)
     1              go to 160
               cgroup_shift(nrow_group_shift, jmetab) = -term
 160        continue
            cgroup_shift(nrow_group_shift, kmetab) =
     1           cgroup_shift(nrow_group_shift, kmetab) + 1.
 140     continue
 110  continue
c     -------------------------------------------------------------------------
c     Dump matrix of group-shift priors (if IPDUMP >= 3)
c     -------------------------------------------------------------------------
      if (min0(nrow_group_shift, lprint) .gt. 0) then
         if (ipdump .ge. 3) then
            write (lprint, 5210) (nacomb(j), j = 1, nmetab)
 5210       format (//20x, 'Prior matrix for group shifts'//
     1             (8x, (10(6x, a6))))
            do 210 j = 1, nrow_group_shift
               write (lprint, 5220) nacomb(lmetab_shift_prior(j)),
     1                  (cgroup_shift(j, jmetab), jmetab = 1, nmetab)
 5220          format (/2x, a6, 1p10e12.3 / (8x, 1p10e12.3))
 210        continue
         else
            write (lprint, 5230) (nacomb(lmetab_shift_prior(jrow)),
     1           jrow = 1, nrow_group_shift)
 5230       format (//' Group-shift priors used for:'/(a6))
         end if
      end if
      end
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      subroutine parse_chsimu ()
c
c     Parse CHSIMU input strings into component parts shown below:
c     CHSIMU must be of the form (all in one record):
c CHSIM @ SIPPM +- SISDSH FWHM= SIFWMN < SIFWEX +- SIFWSD AMP= SIAMP
C       @ SIPPM           FWHM= SIFWMN                    AMP= SIAMP
c
      INCLUDE 'lcmodel.inc'
      external ilen
      character chreturn*(mchmet)
c
      chsubp = 'PARSIM'
      do 210 jsimul = 1, nsimul
         ngau(jsimul) = 1
         len_chsimu = ilen(chsimu(jsimul))
         istart = 1
         call get_field ('@', 1, 1, 0, chsim(jsimul), freturn,
     1                   istart, len_chsimu, chsimu(jsimul))
         if (istart .le. 0) then
            ierr = 0
            go to 800
         end if
         call get_field ('+-', 2, 2, 0, chreturn, sippm(1, jsimul),
     1                   istart, len_chsimu, chsimu(jsimul))
         if (istart .le. 0) then
            ierr = 1
            go to 800
         end if
         call get_field ('FWHM=', 5, 2, 0, chreturn, sisdsh(jsimul),
     1                   istart, len_chsimu, chsimu(jsimul))
         if (istart .le. 0) then
            ierr = 2
            go to 800
         end if
         call get_field ('<', 1, 2, 0, chreturn, sifwmn(1, jsimul),
     1                   istart, len_chsimu, chsimu(jsimul))
         if (istart .le. 0) then
            ierr = 3
            go to 800
         end if
         call get_field ('+-', 2, 2, 0, chreturn, sifwex(jsimul),
     1                   istart, len_chsimu, chsimu(jsimul))
         if (istart .le. 0) then
            ierr = 4
            go to 800
         end if
         call get_field ('AMP=', 4, 2, 0, chreturn, sifwsd(jsimul),
     1                   istart, len_chsimu, chsimu(jsimul))
         if (istart .le. 0) then
            ierr = 5
            go to 800
         end if
         call get_field ('@', 1, 2, 1, chreturn, siamp(1, jsimul),
     1                   istart, len_chsimu, chsimu(jsimul))
         if (istart .le. 0) then
            ierr = 6
            go to 800
         end if
         if (istart .gt. len_chsimu) go to 210
         do 310 jgau = 2, mgau
            ngau(jsimul) = jgau
            call get_field ('FWHM=', 5, 2, 0, chreturn,
     1                      sippm(jgau, jsimul),
     1                      istart, len_chsimu, chsimu(jsimul))
            if (istart .le. 0) then
               ierr = 7
               go to 800
            end if
            call get_field ('AMP=', 4, 2, 0, chreturn,
     1                      sifwmn(jgau, jsimul),
     1                      istart, len_chsimu, chsimu(jsimul))
            if (istart .le. 0) then
               ierr = 8
               go to 800
            end if
            call get_field ('@', 1, 2, 1, chreturn,
     1                      siamp(jgau, jsimul),
     1                      istart, len_chsimu, chsimu(jsimul))
            if (istart .le. 0) then
               ierr = 9
               go to 800
            end if
            if (istart .gt. len_chsimu) go to 210
 310     continue
c        ----------------------------------------------------------------------
c        Error -- NGAU > MGAU
c        ----------------------------------------------------------------------
         if (lprint .gt. 0) write (lprint, 5210)
     1        chsimu(jsimul)(1:132), chsimu(jsimul)(133:264),
     2        chsimu(jsimul)(265:396), chsimu(jsimul)(397:528), istart
 5210    format ('Incorrect CHSIMU follows:', / a132 / a132 / a132 /
     1           a132 / 'ISTART =', i3)
         call errmes (0, 4, chsubp)
 210  continue
      return
 800  if (lprint .gt. 0) write (lprint, 5210)
     1     chsimu(jsimul)(1:132), chsimu(jsimul)(133:264),
     2     chsimu(jsimul)(265:396), chsimu(jsimul)(397:528), istart
      call errmes (100*ierr + jsimul, 4, chsubp)
      end
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      subroutine set_lshape_false ()
      INCLUDE 'lcmodel.inc'
      lshape(nmetab) = .false.
      if (fwhmba .ge. fwhmst) return
      fwhm_extra = sqrt(fwhmst**2 - fwhmba**2)
      rsd = pi * fwhm_extra * deltat * hzpppm /
     1      sqrt(2. * alog(2.))
      expmax = 2. * alog(rrange)
      do 110 jdata = 1, ndata
         expon = (rsd * float(jdata - 1))**2
         if (expon .lt. expmax) then
            basist(jdata, nmetab) = exp(-.5 * expon) *
     1                              basist(jdata, nmetab)
         else
            basist(jdata, nmetab) = (0.,0.)
         end if
 110  continue
      return
      end
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      subroutine water_scale ()
      INCLUDE 'lcmodel.inc'
      chsubp = 'WSCALE'
      if (iaverg .eq. 1   .or.   iaverg .eq. 4) then
         area_water = 1.
      else
         area_water = areawa(2)
      end if
      if (lprint .gt. 0) write (lprint, 5110) area_water
 5110 format (//'Area of unsuppressed water peak =', 1pe13.5)
      if (area_water .le. 0.) then
         call errmes (1, 3, chsubp)
         go to 800
      end if
      if (amin1(atth2o, wconc) .le. 0.) then
         call errmes (2, 3, chsubp)
         go to 800
      end if
      water_norm = area_water / (2. * atth2o * wconc)
      fcalib = area_met_norm / water_norm
      wsdone = .true.
      if (lprint .gt. 0) write (lprint, 5250) fcalib
 5250 format ('FCALIB =', 1pe15.5/)
      do 260 j = 1, nunfil
         datat(j) = fcalib * datat(j)
 260  continue
      do 270 jy = 1, ny
         cy(jy) = cy(jy) * fcalib
 270  continue
      rmsamp = rmsamp * fcalib
      if (imethd .eq. 2) then
         do 310 j = 1, nmetab
            conc_expect(j) = conc_expect(j) * fcalib
 310     continue
      end if
 800  return
      end
c
c
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      real function areawa(istage)
C
C  Compute integral of water peak.
C  ISTAGE != 2 to avoid using AREAW2 when calling from AVERAGE, which can
c              cause big errors (and often an abort) with very weak water
c              signal (as sometimes in bone).  In this case, whole spectrum
c              (including lipids) is used for weighting in AVERAG.
c
      INCLUDE 'lcmodel.inc'
      external areaw2
      double precision sx, sy, sxy, sxx, term1, xterm, yterm
      chsubp = 'AREAWA'
      if (iareaw .eq. 2   .and.   istage .eq. 2) then
         areawa = areaw2()
         return
      end if
c     ------------------------------------------------------------------------
c     Log-linear regression for water integral.
c     ------------------------------------------------------------------------
      npts = nwsend - nwsst + 1
      if (nwsst .lt. 1   .or.   nwsend .gt. nunfil   .or.
     1    npts .lt. 10) then
         call errmes (1, 3, chsubp)
         go to 800
      end if
      sx = 0.d0
      sy = 0.d0
      sxy = 0.d0
      sxx = 0.d0
      do 110 j = nwsst, nwsend
         xterm = dble(float(j))
         yterm = cabs(h2ot(j))
         if (yterm .le. 0.d0) then
            call errmes(4, 3, chsubp)
            go to 800
         end if
         yterm = alog(sngl(yterm))
c         write (LPRINT, 9110) j, alog10(cabs(h2ot(j)))
c 9110    format (i4, 1pe15.7)
         sx = sx + xterm
         sy = sy + yterm
         sxy = sxy + xterm * yterm
         sxx = sxx + xterm**2
 110  continue
      term1 = dble(float(nwsend - nwsst + 1)) * sxx
      denom = term1 - sx**2
      if (abs(denom) .lt. 1.e-10 * sngl(term1)) then
c        ---------------------------------------------------------------------
c        The difference of the two nonnegative terms has lost too much
c          precision.
c        ---------------------------------------------------------------------
         call errmes (2, 3, chsubp)
         go to 800
      end if
      rnum = sxx * sy - sx * sxy
c     ------------------------------------------------------------------------
c     sqrt(ndata) below is needed, because the amplitude is an inverse FFT of
c       the spectrum, and this inverse transform is divided by sqrt(ndata).
c       The value at zero time is thus the sum of all spectral points divided
c       by sqrt(ndata). The metabolite spectral peak, on the other hand is
c       simply a sum of the points (without any division by sqrt(ndata)).
c     0.5 is needed to get good agreement with water-scaling-2 (analyzing
c       water as Scyllo or Cr).  This may be related to the 0.5 that must
c       multiply DATAT(1) when ABSVAL=T (discussed above and in Notes of
c       990830 & 001203).
c     PPMINC is nesessary to get an area, rather than just the FFT sum.
c     ------------------------------------------------------------------------
      expmax = alog(rrange)
      if (abs(rnum) .ge. expmax * abs(denom)) then
         call errmes (3, 3, chsubp)
         go to 800
      end if
      areawa = .5 * ppminc * exp(rnum / denom) * sqrt(float(2 * nunfil))
      return
 800  areawa = -1.
      end
c
c
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      real function areaw2()
c
c AREAW2 = area under (unsuppressed) water peak in H2OF.
c Uses peak phasing routine of MakeBasis.
c Uses integration routine of AREABA, which is based on MakeBasis routine.
      INCLUDE 'lcmodel.inc'

      chsubp = 'AREAW2'
c     ------------------------------------------------------------------------
c     H2OF_WORK = smoothed water spectrum.
c     No zero-filling means only half the number of points (N) in the FT,
c        which is normalized by dividing by the sqrt(N).  So must divide the
c        FTs by sqrt(2), as they would be with the original NDATA points.
c     ------------------------------------------------------------------------
      nunfil_half = nunfil / 2
      ppminc2 = ppminc * 2.
      RSD=2.*PI*SDSMOO(4)/(PPMINC2*float(nunfil))
      DO 120 JUNFIL=1,NUNFIL
         h2ot_work(JUNFIL)=H2Ot(JUNFIL)*
     1                     EXP(-.5*(RSD*FLOAT(JUNFIL-1))**2)
 120  CONTINUE
      call csft_r(h2ot_work, h2of_work, Nunfil)
      call csft_r(h2ot, h2of, Nunfil)
c     ----------------------------------------------------------------------
c     No zero-filling means only half the number of points (N) in the FT,
c        which is normalized by dividing by the sqrt(N).  So must divide the
c        FTs by sqrt(2), as they would be with the original NDATA points.
c     ----------------------------------------------------------------------
      rsqrt2 = sqrt(.5)
      do 130 junfil = 1, nunfil
         h2of_work(junfil) = h2of_work(junfil) * rsqrt2
         h2of(junfil) = h2of(junfil) * rsqrt2
 130  continue
c     ------------------------------------------------------------------------
c     ppmh2o_act = true position of water peak.
c     ------------------------------------------------------------------------
      if (ppm_water_range  .le. 0.) then
         ppmh2o_corr = ppmh2o
      else
         kystrt = max0(1,
     1            nint((PPMcen-PPMH2O-ppm_water_range)/PPMINC2)+
     2                NUNFIL_half+1)
         kyend = min0(nunfil,
     1           nint((PPMcen-PPMH2O+ppm_water_range)/PPMINC2)+
     2                 NUNFIL_half+1)
         lmax = 0
         rmax = -rrange
         do 140 j = kystrt, kyend
            if (cabs(h2of(j)) .gt. rmax) then
               rmax = cabs(h2of(j))
               lmax = j
            end if
 140     continue
         ppmh2o_corr = ppmcen - float(lmax - 1 - nunfil_half) * ppminc2
         if (lprint .gt. 0) write (lprint, 5140) ppmh2o_corr
 5140    format (/'Corrected PPMH2O =', f8.4)
      end if
      ly = (ppmcen - ppmh2o_corr) / ppminc2 + nunfil_half + 1
      kystrt = NINT((PPMcen-PPMH2O_corr-HWDWAT(1))/PPMINC2)+
     1         NUNFIL_half + 1
      KYEND=NINT((PPMcen-PPMH2O_corr+HWDWAT(1))/PPMINC2)+
     1      NUNFIL_half + 1
      NYPEAK=KYEND-KYSTRT+1
      if (kystrt .lt. 3  .or.  kyend .gt. nunfil-2   .or.
     1    nypeak .le. 0) call errmes (1, 4, chsubp)
      if (.not.havh2o) call errmes (2, 4, chsubp)
c 9140 format ('ly, lmax =' 2i6)
c      write (6, 9140) ly, lmax
c     -------------------------------------------------------------------------
c     H2OF_WORK is smoothed water spectrum on input to GETPHA and phased
c               (unsmoothed) spectrum (with PPMINC2 spacing) on return.
c     -------------------------------------------------------------------------
      call getpha (KYSTRT, KYEND, h2oF, h2of_work, nunfil, RADIAN,
     1            NYPEAK, rwork, rwork2,
     2            degzer_calc)
      if (lprint .gt. 0) write (lprint, 5210) degzer_calc
 5210 format (/'Zero-order phase correction for unsuppressed water =',
     1        f6.1/)
      kystrt = NINT((PPMcen-PPMH2O_corr-HWDWAT(2))/PPMINC2)+
     1         NUNFIL_half + 1
      KYEND=NINT((PPMcen-PPMH2O_corr+HWDWAT(2))/PPMINC2)+
     1         NUNFIL_half + 1
      NYPEAK=KYEND-KYSTRT+1
      if (kystrt .lt. 3  .or.  kyend .gt. nunfil-2   .or.
     1    nypeak .le. 0) call errmes (1, 4, chsubp)
      nwndo = nint(ppmbas(2) / ppminc)
      call integrate (h2of_work, ppminc2,
     1                area_water,
     2                kyend, kystrt, ly, nunfil, nwndo)
      areaw2 = area_water
      return
      end
c
c
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      subroutine getpha (KYSTRT, KYEND, dataf, dataw, nunfil, radian,
     1                   nypeak, yorig, yinterp,
     2                   degzer_calc)
c
C  Take optimal 0-order phase correction as the one producing the minimum sum
c    of absolute differences of the spectral values equally distant from the
c    maximum in the smoothed real spectrum between KYSTRT and KYEND.  The sum
c    is normalized by dividing by abs(max - min).
c   DATAW : must contain smoothed spectrum (with PPMINC2 spacing) in necessary
c           region.
c
      parameter (ninterp = 10)
      CHARACTER CHSUBP*6
      COMPLEX CFACT, CFACT_BEST, CFINC, cterm, DATAF(nunfil),
     1        DATAW(nunfil)
      REAL yinterp(nunfil), yorig(nunfil)
      CHSUBP='GETPHA'

c     -------------------------------------------------------------------------
c     Start main loop through 0-order phase angles.
c     -------------------------------------------------------------------------
      CFINC=CEXP(CMPLX(0.,RADIAN))
      CFACT=(1.,0.)
      cfact_best = cfact
      ABSMIN=1.E30
      kystrt_best = 999999
      kyend_best = -999999
      DO 110 JDEG=1,360
         CFACT=CFACT*CFINC
c        ----------------------------------------------------------------------
c        YORIG = real part of spectrum with trial 0-order phase.
c        ----------------------------------------------------------------------
         do 120 jy = max0(1, kystrt-2-nypeak),
     1               min0(nunfil, kyend+2+nypeak)
            yorig(jy) = real( dataw(jy) * cfact )
 120     continue
c        ----------------------------------------------------------------------
c        LY is at max in a smoothed YORIG
c        ----------------------------------------------------------------------
         rmin = 1.e37
         RMAX=-1.E37
         ly = 999999
         DO 210 JY=KYSTRT,KYEND
            TERM=yorig(JY)
            IF (TERM .GT. RMAX) THEN
               RMAX=TERM
               LY=JY
            END IF
            IF (TERM .lt. Rmin) THEN
               RMin=TERM
            END IF
 210     CONTINUE
         if (rmax + rmin   .le.   0.) go to 110
c        ----------------------------------------------------------------------
c        Center test region at LY
c        ----------------------------------------------------------------------
         KYSTRT_new=LY-NYPEAK/2
         KYEND_new=LY+NYPEAK/2
         IF (KYSTRT_new.Le.2 .OR. KYEND_new.Ge.NUNFIL-1)
     1        CALL ERRmes (1, 4, CHSUBP)
         NYPEAK=KYEND_new-KYSTRT_new+1
c        ----------------------------------------------------------------------
c        YINTERP = The linearly interpolated YORIG at NINTERP interpolations
c                  on each side to allow for the fact that the peak on the
c                  discrete grid may not be at the center of symmetry.
c        ----------------------------------------------------------------------
         fract = 1.
         rinterp = ninterp
         delta_fract = .5 / rinterp
         do 310 jinterp = 1, 2 * ninterp + 1
            fract = fract - delta_fract
            fract2 = 1 - fract
            if (jinterp .eq. ninterp) fract = 1.
            if (jinterp .lt. ninterp) then
               do 312 jy = kystrt_new - 1, kyend_new + 1
                  yinterp(jy) = fract * yorig(jy) + fract2 * yorig(JY-1)
 312           continue
            else
               do 314 jy = kystrt_new - 1, kyend_new + 1
                  yinterp(jy) = fract * yorig(jy) + fract2 * yorig(JY+1)
 314           continue
            end if
            rmax = yorig(LY)
            rmin = rmax
            sum = 0.
            DO 320 JYREL=1,NYPEAK/2
               rmax = amax1(rmax, yinterp(LY+JYREL), yinterp(LY-JYREL))
               rmin = amin1(rmin, yinterp(LY+JYREL), yinterp(LY-JYREL))
               sum = sum + sqrt(float(jyrel)) *
     1                     abs(yinterp(LY+JYREL) - yinterp(LY-JYREL))
 320        continue
            span = rmax - rmin
            if (span .le. 0.) go to 110
            acrit = sum / span
            IF (ACRIT .LT. ABSMIN) THEN
               kystrt_best = kystrt_new
               kyend_best = kyend_new
               ABSMIN=ACRIT
               DEGZER_CALC=FLOAT(JDEG)
               CFACT_BEST=CFACT
            END IF
 310     continue
  110 CONTINUE
      kystrt = kystrt_best
      kyend = kyend_best
      nypeak = kyend - kystrt + 1
      DO 410 J=1,NUNFIL
         DATAW(J)=DATAF(J)*CFACT_BEST
  410 CONTINUE
      END

C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE INTEGRATE (DATAF, ppminc2,
     2                      RINTEG,
     3                      KYEND, KYSTRT, ly, Nunfil, NWNDO)
C
C  Crude integration of peak (with PPMINC2 spacing) between KYSTRT and KYEND
C    with the baseline taken as the line running from the mean over the 2
c    bordering regions NWNDO wide.
C
      COMPLEX DATAF(Nunfil)
C     -------------------------------------------------------------------------
c     Restricting the integration range by moving KY* inward to 1 beyond the
c       minimum on each side led to erratic results for hennig/9911/press270,
c       where there were eddy-current distortions with one side sharply
c       dropping to min near the peak.
c     So, the integration range is shrunk symmetrically to 1 point beyond the
c       max distance (over both sides) of the min from the peak.
C     -------------------------------------------------------------------------
      rmin = 1.e+30
      lmin = kystrt
      do 102 jy = kystrt, ly - 1
         term = real(dataf(jy))
         if (term .lt. rmin) then
            rmin = term
            lmin = jy
         end if
 102  continue
      ldist_left = ly - lmin
c
      rmin = 1.e+30
      lmin = kyend
      do 104 jy = ly + 1, kyend
         term = real(dataf(jy))
         if (term .lt. rmin) then
            rmin = term
            lmin = jy
         end if
 104  continue
      ldist_right = lmin - ly
      ldist_max = max0( ldist_left, ldist_right)
      kystrt = ly - ldist_max
      kyend = ly + ldist_max
c
      COUNT=0.
      AVG_LEFT=0.
      DO 110 JY=MAX0(1,KYSTRT-NWNDO),KYSTRT-1
         COUNT=COUNT+1.
         AVG_LEFT=AVG_LEFT+REAL(DATAF(JY))
  110 CONTINUE
      AVG_LEFT=AVG_LEFT/COUNT
      COUNT=0.
      AVG_RIGHT=0.
      DO 120 JY=KYEND+1,MIN0(Nunfil,KYEND+NWNDO)
         COUNT=COUNT+1.
         AVG_RIGHT=AVG_RIGHT+REAL(DATAF(JY))
  120 CONTINUE
      avg_right = avg_right / count
C     -------------------------------------------------------------------------
C     Subtracting AVG from every data point in the peak range is
C       equivalent to using an unbiased estimate of a line through the
C       points in the bordering regions.  It is more robust to outliers
C       due to neighboring peaks than least squares.
C     -------------------------------------------------------------------------
      avg = .5 * (avg_left + avg_right)
      RINTEG=0.
      DO 130 JY=KYSTRT,KYEND
         RINTEG=RINTEG+REAL(DATAF(JY))
  130 CONTINUE
      rinteg = rinteg - float(kyend - kystrt + 1) * avg
      rinteg = rinteg * ppminc2
c 9130 format('rinteg =', 1pe13.5/ 'ly =', i5/ 'kystrt =', i5/
c     1       'kyend =', i5/ 'avg_right =', e13.5/ 'avg_left=', e13.5/
c     2       'nwndo =', i5/ 'count =', e13.5/)
c      write (6, 9130) rinteg, ly, kystrt, kyend, avg_right,
c     1                     avg_left, nwndo, count
c 9140 format (i5, 1pe13.5)
c      write (6, 9140) (j, real(dataf(j)), j = kystrt, kyend)
c      if (rinteg .le. 0.) stop
      END
c
c
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      real function areaba(basisf, ppminc_arg, nunfil_arg)
C
C  Compute normalized integral of metabolite peak.  This area is
c    normalized by dividing by N1HMET & ATTMET.  So, it should correspond to
c    1mM of protons.
c
C
      INCLUDE 'lcmodel.inc'
      external icycle
      complex basisf(*)
      chsubp = 'AREABA'
      areaba = 0.
      ndata_arg = 2 * nunfil_arg
      if (sptype(:10) .eq. 'mega-press') then
         do 120 jy = 1, ndata_arg
            basisf(jy) = -basisf(jy)
 120     continue
      end if
      ly = nint((ppmcen - wsppm) / ppminc_arg) + 1
c     ----------------------------------------------------------------------
c     LY = corrected index of metabolite peak
c     ----------------------------------------------------------------------
      if (r_areaba .gt. 0.) then
         nyhalf = nint(r_areaba * desdsh / ppminc_arg)
         kystrt = ly - nyhalf
         kyend = ly + nyhalf
         if (kystrt .le. -nunfil_arg   .or.
     1       kyend .ge. nunfil_arg) then
            call errmes (1, 3, chsubp)
            go to 800
         end if
         rmax = -rrange
         do 140 jy = kystrt, kyend
            term = real(basisf(icycle(jy, ndata_arg)))
            if (term .gt. rmax) then
               rmax = term
               ly = jy
            end if
 140     continue
         term = ppmcen - (ly - 1) * ppminc_arg
         if (lprint .gt. 0) write (lprint, 5140) term
 5140    format (/'Corrected WSPPM =', f8.4)
      end if

      nwndo = nint(ppmbas(1) / ppminc_arg)
      if (ldump(5)) write (lprint, 9210) nwndo, ppmbas(1), ppminc_arg
 9210 format ('NWNDO, PPMBAS(1), PPMINC =', i4, 1p2e15.7)
      hwdsca = .5 * rfwbas * fwhmba
c     -------------------------------------------------------------------------
c          When ABSVAL=T, increase HWDSCA by another factor of 1.5, because of
c     extremely broad absolute-value tails.  Even with Cr, cannot go any
c     higher, since FWHMBA has already been doubled.  For example, with
c     original FWHMBA=.04 and RFWBAS=10, we would get
c     HWDSCA = .5 * 10 * 1.5 * 2 * .04 = .60, which would be more than halfway
c     to CrCH2.
c     -------------------------------------------------------------------------
      if (absval) hwdsca = hwdsca * 1.5
      nyhalf = nint(hwdsca / ppminc_arg)
      kystrt = ly - nyhalf
      kyend = ly + nyhalf
      if (kystrt - nwndo .le. -nunfil_arg   .or.
     1    kyend + nwndo .ge. nunfil_arg
     2    .or.   min0(nyhalf, nwndo) .le. 0) then
         call errmes (1, 3, chsubp)
         go to 800
      end if
      rmin = 1.e+30
      lmin = kystrt
      do 210 jy = kystrt, ly - 1
         term = real(basisf(icycle(jy, ndata_arg)))
         if (ldump(5)) write (lprint, 9250) jy,
     1                       REAL(BASISF(ICYCLE(JY, NDATA_ARG)))
         if (term .lt. rmin) then
            rmin = term
            lmin = jy
         end if
 210  continue
      ldist_left = ly - lmin
      if (ldump(5)) write (lprint, 9211) lmin, ldist_left, ly
 9211 format ('LMIN, LDIST, LY =', 3i5)

      rmin = 1.e+30
      lmin = kyend
      do 220 jy = ly + 1, kyend
         term = real(basisf(icycle(jy, ndata_arg)))
         if (ldump(5)) write (lprint, 9250) jy,
     1                        REAL(BASISF(ICYCLE(JY, NDATA_ARG)))
         if (term .lt. rmin) then
            rmin = term
            lmin = jy
         end if
 220  continue
      ldist_right = lmin - ly
      if (ldump(5)) write (lprint, 9211) lmin, ldist_right, ly
      ldist_max = max0( ldist_left, ldist_right)
      kystrt = ly - ldist_max
      kyend = ly + ldist_max
c
      COUNT=0.
      AVG_LEFT=0.
      DO 230 JY = KYSTRT-NWNDO, KYSTRT-1
         COUNT=COUNT+1.

         if (ldump(5)) write (lprint, 9250) jy,
     1                        REAL(BASISF(ICYCLE(JY, NDATA_ARG)))
         if (count .gt. 0.) AVG_LEFT=AVG_LEFT+
     1                               REAL(BASISF(ICYCLE(JY, NDATA_ARG)))
  230 CONTINUE
      AVG_LEFT=AVG_LEFT/COUNT
      if (ldump(5)) write (lprint, 9240) nint(count), avg_left
      COUNT=0.
      AVG_RIGHT=0.
      DO 240 JY = KYEND+1, KYEND+NWNDO
         COUNT=COUNT+1.

         if (ldump(5)) write (lprint, 9250) jy,
     1                       REAL(BASISF(ICYCLE(JY, NDATA_ARG)))
         AVG_RIGHT=AVG_RIGHT+REAL(BASISF(ICYCLE(JY, NDATA_ARG)))
  240 CONTINUE
      if (count .gt. 0.) avg_right = avg_right / count
      if (ldump(5)) write (lprint, 9240) nint(count), avg_right
 9240 format (i4, 1pe15.7/)
C     -------------------------------------------------------------------------
C     Subtracting AVG from every data point in the peak range is
C       equivalent to using an unbiased estimate of a line through the
C       points in the bordering regions.  It is more robust to outliers
C       due to neighboring peaks than least squares.
C     -------------------------------------------------------------------------
      avg = .5 * (avg_left + avg_right)
      AREA_MET=0.
      DO 250 JY=KYSTRT,KYEND
         AREA_MET=AREA_MET+REAL(BASISF(ICYCLE(JY, NDATA_ARG)))

         if (ldump(5)) write (lprint, 9250) jy,
     1                       REAL(BASISF(ICYCLE(JY, NDATA_ARG)))
 9250    format (i5, 1pe15.7)

  250 CONTINUE
      if (lprint .gt. 0) write (lprint, 9251) area_met
 9251 format ('Uncorrected AREA_MET =', 1pe13.5)
      area_met = area_met - float(kyend - kystrt + 1) * avg
      if (n1hmet .le. 0   .or.   attmet .le. 0.) then
         call errmes (2, 3, chsubp)
         go to 800
      end if
c     -------------------------------------------------------------------------
c     PPMINC_ARG is necessary to get area, rather than just the FFT sum.
c     -------------------------------------------------------------------------
      areaba = ppminc_arg * area_met / (float(n1hmet) * attmet)
      if (lprint .gt. 0) write (lprint, 5250) areaba
 5250 format ('Normalized area of reference Basis singlet =', 1pe15.5/)
c     -------------------------------------------------------------------------
c     If AREABA<=0, then neither water-scaling nor scaling of simulated
c       spectra will be possible.
c     -------------------------------------------------------------------------
      if (areaba .le. 0.) call errmes (3, 3, chsubp)
 800  if (sptype(:10) .eq. 'mega-press') then
         do 820 jy = 1, ndata_arg
            basisf(jy) = -basisf(jy)
 820     continue
      end if
      return
      end
c
c
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE COMBIS ()
C
C  Compute NCOMPO and LCOMPO for combinations of metabolites.
C
      INCLUDE 'lcmodel.inc'
      LOGICAL ATEND
      CHSUBP='COMBIS'
      ncombi = min0(ncombi, mpmet)
c     -------------------------------------------------------------------------
c     Special (tedious) case to eliminate combinations of 2's if all 3 of Cho
c       GPC & PCh and CHCOMB=Cho+GPC+PCh are present.
c     -------------------------------------------------------------------------
      ncho = 0
      do 50 jmetab = 1, nmetab
         nacom2(jmetab) = ' '
         if (nacomb(jmetab) .eq. 'Cho'   .or.
     1       nacomb(jmetab) .eq. 'GPC'   .or.
     2       nacomb(jmetab) .eq. 'PCh') ncho = ncho + 1
 50   continue
      if (ncho .ge. 3) then
         do 52 jcombi = 1, ncombi
            if (CHCOMB(JCOMBI) .eq. 'Cho+GPC+PCh') go to 54
 52      continue
         go to 100
 54      do 55 jtry = 1, 3
            do 56 jcombi = 1, ncombi
               if (CHCOMB(JCOMBI) .eq. 'GPC+PCh'   .or.
     1             CHCOMB(JCOMBI) .eq. 'GPC+Cho'   .or.
     2             CHCOMB(JCOMBI) .eq. 'PCh+Cho') go to 57
 56         continue
            go to 100
 57         ncombi = ncombi - 1
            do 58 j = jcombi, ncombi
               chcomb(j) = chcomb(j + 1)
 58         continue
 55      continue
      end if
 100  JCONC=NMETAB
      DO 110 JCOMBI=1,NCOMBI
         JCONC=JCONC+1
         IF (JCONC .GT. MCONC) CALL ERRMES (1, 4, CHSUBP)
         NACOMB(JCONC)=CHCOMB(JCOMBI)
         NACOM2(JCONC)=CHCOM2(JCOMBI)
         table_top(jconc) = .true.
         NCOMPO(JCONC)=0
         ISTART=1
         DO 120 KMETAB=1,NMETAB
            LENGTH=INDEX(CHCOMB(JCOMBI)(ISTART:),'+')-1
            ATEND=LENGTH .EQ. -1
            IF (ATEND) THEN
C              ---------------------------------------------------------------
C              No more + characters.
C              ---------------------------------------------------------------
               LENGTH=INDEX(CHCOMB(JCOMBI)(ISTART:),' ')-1
               IF (LENGTH .EQ. -1) LENGTH=LEN(CHCOMB(JCOMBI))+1-ISTART
            END IF
            IF (LENGTH .GT. MCHMET) THEN
               IF (LPRINT .GT. 0) WRITE (LPRINT,5120) CHCOMB(JCOMBI)
 5120          FORMAT (' Incorrect CHCOMB =',A)
               CALL ERRMES (2, 4, CHSUBP)
            END IF
            DO 130 JMETAB=1,NMETAB
            IF (INDEX(NACOMB(JMETAB),' ')-1 .EQ. LENGTH) THEN
               IF (CHCOMB(JCOMBI)(ISTART:ISTART+LENGTH-1) .EQ.
     1             NACOMB(JMETAB)(1:LENGTH)) GO TO 135
               END IF
  130       CONTINUE
            JCONC=JCONC-1
            GO TO 110
  135       NCOMPO(JCONC)=NCOMPO(JCONC)+1
            ISTART=ISTART+LENGTH+1
            IF (NCOMPO(JCONC) .GT. MCOMPO) THEN
               IF (LPRINT .GT. 0) WRITE (LPRINT,5120) CHCOMB(JCOMBI)
               CALL ERRMES (3, 4, CHSUBP)
            END IF
            LCOMPO(NCOMPO(JCONC),JCONC)=JMETAB
            table_top(jconc) = table_top(jconc) .and. table_top(jmetab)
            IF (ATEND) GO TO 110
  120    CONTINUE
         JCONC=JCONC-1
  110 CONTINUE
      NCONC=JCONC
      jline = 0
      do 210 jconc = 1, nconc
         if (table_top(jconc)) then
            jline = jline + 1
            iconc_line_table(jline) = jconc
         end if
 210  continue
      ntable_top = jline
      do 220 jconc = 1, nconc
         if (.not.table_top(jconc)) then
            jline = jline + 1
            iconc_line_table(jline) = jconc
         end if
 220  continue
      END
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE STARTV (ipass)
C
C  Crude fast analysis to get starting values for fwhm (FWHMST), DEGZER,
C    and DEGPPM, and to determine ISHIFD and NSIDES.
C
      INCLUDE 'lcmodel.inc'
      save degppm_sav_startv, degzer_sav_startv, ishfst, lwidth
      DOUBLE PRECISION SDSHBS
      INTEGER INTSHF(MSHIFT,2), ISHFST(2), LREFPK(MREFPK), LSHFMN(3),
     1        lshfmn_orig(2), LSHFMX(3), lshfmx_orig(2), LWIDTH(2)
      LOGICAL CNVRG1, dosub_bas_ccf
      real cpy2(mdata)
C      COMPLEX CYFIT(MY)!CT1
C      LOGICAL LTEST!CT1
C      COMMON /BLT1/ CYFIT, LTEST!CT1
      CHSUBP='STARTV'
      do 101 j = 1, 2
         ishfst(j) = 0
         lwidth(j) = 999999
 101  continue
      lshfbs_fixshf = 99999
c     -------------------------------------------------------------------------
c     PPMSHF cannot shift Analysis Window out of spectrum.
c     Max negative shift would shift first point of entire rearranged
c       spectrum to LDATST.
c     Max positive shift would shift last point of entire rearranged
c       spectrum to LDATEN.
c     Otherwise, the shift would require spectral data that do not exist.
c     -------------------------------------------------------------------------
      if (abs(ppmshf) .lt. 1.e5) then
         if ((ppmshf .le. 0.   .and.
     1       -ppmshf .gt. ppminc * float(ldatst))   .or.
     2       (ppmshf .gt. 0.   .and.
     3        ppmshf .gt. ppminc * float(ndata - ldaten))) then
            call errmes (26, 4, chsubp)
         else
            LGRID=1
            ISHFST(1)=PPMSHF/PPMINC
            LSHFMN(3)=ISHFST(1)
            LSHFMX(3)=ISHFST(1)
            LGRDMN=9999
            GO TO 300
         end if
      END IF
c     -----------------------------------------------------------------------
c     FIXSHF = T (used for muscle-4) for initial CCF with PPMREF to fix
c                the referencing shift.  Prel is only used for initial
c                phasing; its optimal shift is ignored.
c     PPMSHF (with FIXSHF=T) will fix the referencing shift at PPMSHF.
c     -----------------------------------------------------------------------
      if (fixshf) then
         rfwhcc = 0.
         fwhh2o = 0.
      end if
      IF (.NOT.(DOREFS(1) .OR. DOREFS(2))) CALL ERRMES (1, 4, CHSUBP)
      LSHFMN(3)=99999
      LSHFMX(3)=-99999
      DO 105 JRFSET=1,2
         IF (.NOT.DOREFS(JRFSET)) GO TO 105
C        ----------------------------------------------------------------------
C        Reduce NREFPK(JRFSET) if a PPMREF is out of analysis window.
C        ----------------------------------------------------------------------
         KREFPK=NREFPK(JRFSET)
         DO 106 J=1,NREFPK(JRFSET)
            IF (J.GT.KREFPK .OR. JRFSET.EQ.1) GO TO 108
            TEST=PPMREF(J,JRFSET)+HZREF(J,JRFSET)/HZPPPM
            IF (PPMST.LT.TEST .OR. PPMEND.GT.TEST) THEN
               KREFPK=KREFPK-1
               DO 107 K=J,KREFPK
                  PPMREF(K,JRFSET)=PPMREF(K+1,JRFSET)
                  HZREF(K,JRFSET)=HZREF(K+1,JRFSET)
  107          CONTINUE
            END IF
  106    CONTINUE
  108    NREFPK(JRFSET)=KREFPK
         LSHFMN(JRFSET)=NINT(SHIFMN(JRFSET)/PPMINC)
         LSHFMX(JRFSET)=NINT(SHIFMX(JRFSET)/PPMINC)
         LSHFMN_orig(JRFSET)=NINT(SHIFMN_orig(JRFSET)/PPMINC)
         LSHFMX_orig(JRFSET)=NINT(SHIFMX_orig(JRFSET)/PPMINC)
         IF (LSHFMN(JRFSET) .GT. LSHFMX(JRFSET)) CALL ERRMES (2, 4,
     1                                                        CHSUBP)
C        ----------------------------------------------------------------------
C        DATAF = (temporarily) Gaussian-smoothed FFT of zero-filled
C                (time-domain) DATAT (COMPLEX).
C        DATAF(1+nunfil): corresponds to PPMCEN; i.e., the spectrum is
c                         rearranged.
c                  /main/projects/lcm/lcmodel/src/misc/test-fft.f verifies
c                    that the 1st point is the zero-frequency transform (in
c                    the old non-rearranged version).
C        ----------------------------------------------------------------------
         RSD=2.*PI*SDSMOO(JRFSET)/(PPMINC*FNDATA)
         DO 110 JUNFIL=1,NUNFIL
            DATAF(JUNFIL)=DATAT(JUNFIL)*
     1                    EXP(-.5*(RSD*FLOAT(JUNFIL-1))**2)
            DATAF(NUNFIL+JUNFIL)=(0.,0.)
  110    CONTINUE
         CALL CFFT_r (DATAF, DATAF, NDATA, LWFFT,
     1              WFFTC)
C        ----------------------------------------------------------------------
C        CPY2 = smoothed power spectrum.
C        ----------------------------------------------------------------------
         DO 120 JDATA=1,NDATA
            cpy2(JDATA)=REAL(DATAF(JDATA))**2+AIMAG(DATAF(JDATA))**2
  120    CONTINUE
C        ----------------------------------------------------------------------
C        ISHFST = starting value (in grid points) for referencing shift in the
C                 spectrum.
C        Compute cross-correlation function (CCF) with a sum of unit reference
C          delta-functions at PPMREF(J,JRFSET).
C        Ordinarily, NREFPK(1)=1 and PPMREF(1,1)=4.65; i.e., the water peak is
C          used, despite the possible distortion in the peak position due to
C          water suppression.
C        Typically, NREFPK(2)=3 and PPMREF(*,2)=2.01, 3.03, 3.22; i.e., the
C          usual landmarks are used to extend the range of the grid search in
C          case the water peak has been strongly displaced by the water
C          suppression.
C        A positive shift shifts the data spectrum to the left (larger ppm).
C          Thus SHIFMN and SHIFMX specify the allowed range of the correction
C          to the apparent ppm postion of the data spectrum; i.e.,
C          (apparent ppm)+SHIFMN < true ppm < (apparent ppm)+SHIFMX.
C          SHIFMN <= SHIFMX always.
C          Usually SHIFMN<0, SHIFMX>0
C        The same sign convention applies to all other shift parameters, such
C          as LSHFM*, ISH*, etc.
C        ----------------------------------------------------------------------
C        DOSUB_BAS_CCF = T to subtract rough baseline from smoothed power
c                          spectrum.
c        Set DOSUB_BAS_CCF = F if one of the reference peaks is within
c          PPM_WATER_TOL (typically 0.08) of 4.68 (to avoid baseline
c          subtraction at the huge water peak).
C          PPM_WATER_TOL < 0 will negate this test.
c        NBAS_CCF <= 0 will omit baseline subtraction.
c        CPY = smoothed power spectrum with baseline subtracted.
c        Limits hardcoded for (input values) RFWHMST_CCF & NBAS_CCF below.
C        ----------------------------------------------------------------------
         IF (NREFPK(JRFSET).LE.0 .OR. NREFPK(JRFSET).GT.MREFPK) CALL
     1         ERRMES (3, 4, CHSUBP)
         dosub_bas_ccf = .true.
         DO 130 J=1,NREFPK(JRFSET)
            LREFPK(J)=NINT((PPMCEN-PPMREF(J,JRFSET)-
     1                      HZREF(J,JRFSET)/HZPPPM)/PPMINC)+1+nunfil
            dosub_bas_ccf = dosub_bas_ccf   .and.
     1                  abs(PPMREF(J,JRFSET) - 4.68) .gt. ppm_water_tol
  130    CONTINUE
         dosub_bas_ccf = dosub_bas_ccf   .and.   rfwhmst_ccf .gt. 0.
     1                   .and.   nbas_ccf .gt. 0
         if (dosub_bas_ccf) then
            rfwhmst_ccf = amin1(rfwhmst_ccf, 4.)
            nbas_ccf = min0(nbas_ccf, 40)
            lsub_start = max0(1, nint(rfwhmst_ccf * fwhmst / ppminc))
         else
            nbas_ccf = 0
            lsub_start = 0
         end if
         do 132 jdata = 1, ndata
            bas_sum = 0.
            do 133 jsub = lsub_start, lsub_start + nbas_ccf - 1
               bas_sum = bas_sum +
     1                   cpy2(icycle_r(jdata + jsub, ndata)) +
     2                   cpy2(icycle_r(jdata - jsub, ndata))
 133        continue
            if (dosub_bas_ccf) then
               cpy(jdata) = amax1(0., cpy2(jdata) -
     1                                bas_sum / float(2 * nbas_ccf))
            else
               cpy(jdata) = cpy2(jdata)
            end if
 132     continue
C        ----------------------------------------------------------------------
C        ISHFST = shift with max. correlation with the NREFPK(JRFSET)
C                 reference delta-functions.
C        ----------------------------------------------------------------------
  140    CORRMX=-RRANGE
         CORRMN=RRANGE
         DO 150 JSHIFT=LSHFMN(JRFSET),LSHFMX(JRFSET)
            CCF=0.
            DO 160 JREFPK=1,NREFPK(JRFSET)
               CCF=CCF+CPY(ICYCLE_r(LREFPK(JREFPK)+JSHIFT, NDATA))
  160       CONTINUE
            CORRMN=AMIN1(CORRMN, CCF)
            IF (CCF .GE. CORRMX) THEN
               CORRMX=CCF
               ISHFST(JRFSET)=JSHIFT
            END IF
  150    CONTINUE
c        ---------------------------------------------------------------------
c        Only make this test if original SHIFM* are being used, not if
c          restricted SHIFM* from multi-voxel priors for SHIFM*.
c        ---------------------------------------------------------------------
         IF ((ISHFST(JRFSET).EQ.LSHFMN(JRFSET) .OR.
     1        ISHFST(JRFSET).EQ.LSHFMX(JRFSET))   .and.
     2       lshfmn(jrfset) .eq. lshfmn_orig(jrfset)   .and.
     2       lshfmx(jrfset) .eq. lshfmx_orig(jrfset)) THEN
            IF (JRFSET .EQ. 1) THEN
C              ----------------------------------------------------------------
C              An extreme shift SHIFM*(1) is being called for.  The water peak
C                is probably very distorted or weak.
C              ----------------------------------------------------------------
               CALL ERRMES (4, 2, CHSUBP)
            ELSE
               IF (ISHFST(JRFSET) .EQ. LSHFMX(JRFSET)) THEN
C                 -------------------------------------------------------------
C                 The extreme shift SHIFMX(2) is being called for.
C                 -------------------------------------------------------------
                  CALL ERRMES (5, 2, CHSUBP)
               ELSE
                  IF (NREFPK(JRFSET) .GT. MAX0(1,NRF2MN)) THEN
C                    ----------------------------------------------------------
C                    The CCF has probably been distorted by incomplete water
C                      suppression.  Decrement NREFPK(2).  This assumes that
C                      the elements of PPMREF(*,2) are increasing in ppm.
C                    ----------------------------------------------------------
                     CALL ERRMES (6, 1, CHSUBP)
                     NREFPK(2)=NREFPK(2)-1
                     GO TO 140
                  ELSE
C                    ----------------------------------------------------------
C                    All but NRF2MN peaks have been removed, and the extreme
C                      SHIFMN(2) is still being called for.
C                    ----------------------------------------------------------
                     CALL ERRMES (7, 2, CHSUBP)
                  END IF
               END IF
            END IF
         END IF
C        ----------------------------------------------------------------------
C        FWHMCC = FWHM of CCF peak.  It will be used to set limits on the grid
C                 search for the shift.
C        CORRMN is subtracted from CCF as a background.
C        ----------------------------------------------------------------------
         HALFMX=.5*(CORRMX-CORRMN)
         DO 170 JSHIFT=ISHFST(JRFSET)+1,ISHFST(JRFSET)+NUNFIL/2
            CCF=-CORRMN
            DO 180 JREFPK=1,NREFPK(JRFSET)
               CCF=CCF+CPY(ICYCLE_R(LREFPK(JREFPK)+JSHIFT, NDATA))
  180       CONTINUE
            IF (CCF .LE. HALFMX) GO TO 190
  170    CONTINUE
         CALL ERRMES (8, 2, CHSUBP)
  190    DO 200 KSHIFT=ISHFST(JRFSET)-1, ISHFST(JRFSET)-NUNFIL/2, -1
            CCF=-CORRMN
            DO 210 JREFPK=1,NREFPK(JRFSET)
               CCF=CCF+CPY(ICYCLE_R(LREFPK(JREFPK)+KSHIFT, NDATA))
  210       CONTINUE
            IF (CCF .LE. HALFMX) GO TO 220
  200    CONTINUE
         CALL ERRMES (9, 2, CHSUBP)
C        ----------------------------------------------------------------------
C        The 8(ln2)*SDSMOO**2 roughly corrects FWHMCC for the convolution with
C          the Gaussian.  This tends to be an undercorrection; so, too large
C          an SDSMOO would cause too wide a grid and too long computation
c          times.
C          SDSMOO about 0.02 seems reasonable.
C        ----------------------------------------------------------------------
  220    FWHMCC=SQRT(AMAX1(0.,
     1                     (PPMINC*FLOAT(JSHIFT-KSHIFT))**2-
     2                     8.*ALOG2*SDSMOO(JRFSET)**2))
C     -------------------------------------------------------------------------
C        The starting grid will normally not extend beyond RFWHCC*FWHMCC on
C          either side of grid center.  Only a multimodal water peak can
C          extend this.
C     -------------------------------------------------------------------------
         LCC=NINT(RFWHCC*FWHMCC/PPMINC)
         LH2OMN=LCC
         LH2OMX=LCC
         IF (NREFPK(JRFSET).EQ.1 .AND.
     1       ABS(PPMREF(1,JRFSET) - 4.7) .LT. .1) THEN
C           -------------------------------------------------------------------
C           The residual water peak may be multimodal.  Search over the ppm
C             range FWHH2O (centered at LH2OPK) to see if the power spectrum
C             attains values of at least THRESH=HALFMX*2*FH2OMX; i.e.,
C             FH2OMX=.25 will set the threshold at the quarter-maximum (a
C             reasonable value).
C           LH2OMN = no. of points toward the left where the power spectrum
C                    exceeds the threshold.
C           LH2OMX = no. of points toward the right ...
C           -------------------------------------------------------------------
            LH2OPK=LREFPK(1)+ISHFST(JRFSET)
            THRESH=HALFMX*2.*FH2OMX+CORRMN
            DO 230 JSHIFT=1,NINT(.5*FWHH2O/PPMINC)
               IF (CPY(ICYCLE_R(LH2OPK-JSHIFT,NDATA)) .GT. THRESH)
     1               LH2OMN=JSHIFT
               IF (CPY(ICYCLE_R(LH2OPK+JSHIFT,NDATA)) .GT. THRESH)
     1               LH2OMX=JSHIFT
  230       CONTINUE
         END IF
         LSHFMN(3)=MIN0(LSHFMN(3),
     1                  MAX0(LSHFMN(JRFSET), ISHFST(JRFSET)-LH2OMN))
         LSHFMX(3)=MAX0(LSHFMX(3),
     1                  MIN0(LSHFMX(JRFSET), ISHFST(JRFSET)+LH2OMX))
 5230    FORMAT (' Peak in CCF at', I4, 5X, 'Range =', 2I5)
         IF (LPRINT .GT. 0) WRITE (LPRINT,5230) ISHFST(JRFSET),
     1                                          -LH2OMN, LH2OMX
         LWIDTH(JRFSET)=LH2OMX+LH2OMN
  105 CONTINUE
      IF (LWIDTH(1) .LT. LWIDTH(2)) THEN
         LGRID=1
      ELSE
         LGRID=2
      END IF
      LGRDMN=max0(1, NINT(RFWHST*FWHMST/PPMINC))
 300  if (fixshf) then
         lshfbs_fixshf = lshfmn(3)
         lgrid = 1
         ishfst(1) = lshfmn(3)
         lgrdmn = 9999
      end if
C     -------------------------------------------------------------------------
C     Get DATAF = frequency-domain data shifted by ISHFST(LGRID).
C     -------------------------------------------------------------------------
      CALL FTDATA (ISHFST(LGRID))
C     -------------------------------------------------------------------------
C     Get starting estimates for the 0- and 1st-order phase corrections.
c     First restore current values of DEGPPM & DEGZER if in 2nd pass, since
c        they are zeroed at the end of STARTV and are needed in PHASTA to set
c        EXDEGP & EXDEGZ.
C     -------------------------------------------------------------------------
      if (ipass .eq. 1) then
         degzer_sav_startv = degzer
         degppm_sav_startv = degppm
      else
         degzer = degzer_sav_startv
         degppm = degppm_sav_startv
      end if
      CALL PHASTA ()
C
C     -------------------------------------------------------------------------
C     Set up for calls to PLINLS and search for starting values.
C     -------------------------------------------------------------------------
      NSIDES=0
      CALL SETUP (1)
      IF (NSHIFT .GE. MSHIFT) THEN
          NSHIFT=MSHIFT
          CALL ERRMES (10, 3, CHSUBP)
      END IF
      NDEGZ(2)=MAX0(NDEGZ(2),1)
      DDEGZ=360./FLOAT(NDEGZ(2))
      IF (NDGPPM(2) .LE. 1) THEN
         NDGPPM(2)=1
         DDGPPM=DGPPMX-DGPPMN
      ELSE
         DDGPPM=(DGPPMX-DGPPMN)/FLOAT(NDGPPM(2)-1)
         IF (DDGPPM .LE. 0.) CALL ERRMES (11, 4, CHSUBP)
      END IF
      DGPPST=DEGPPM
C     -------------------------------------------------------------------------
C     PARBES(*,1) will be updated to the best so far in the grid search below.
C     PARBES(*,2) must be initialized here because it overwrites PARNLN when
C                 REPHAS is called in the grid search below, and PARNLN must
C                 be properly initialized for PLINLS.
C     -------------------------------------------------------------------------
      PARBES(LSHIST,2)=PARNLN(LSHIST)
      PARBES(LRT2ST,2)=PARNLN(LRT2ST)
      SDBEST(1)=DRANGE
 5310 FORMAT (//' Preliminary search for starting phases ',
     1              'and referencing shift with starting shifts ',
     2              'between', I5, ' and', I5, ' and mesh of', I5,
     3              ' points')
      IF (LPRINT .GT. 0) WRITE (LPRINT,5310) LSHFMN(3), LSHFMX(3),
     1                                       LGRDMN
      CNVRG1=.FALSE.
C     -------------------------------------------------------------------------
C     Start of main loop for search for starting values.
C     Original CY (with no rephasing) is used.
C     -------------------------------------------------------------------------
      DO 310 JSHIFT=1,NSHIFT
         SDSHBS=DRANGE
         KSHFBS=ISHIFD
         DO 320 JDEGZ=1,NDEGZ(2)
            TEST=AMOD(ABS(DEGZER-EXDEGZ),360.)
            IF (AMIN1(TEST,360.-TEST).GT.4.*SDDEGZ .AND. .NOT.FXDEGZ)
     1            GO TO 328
            DEGPPM=DGPPST
            DO 330 JDGPPM=1,NDGPPM(2)
               IF (ABS(DEGPPM-EXDEGP).GT.4.*SDDEGP .AND. .NOT.FXDEGP)
     1               GO TO 338
               IF (LPRINT .GT. 0) WRITE (LPRINT,5330) ISHIFD
 5330          FORMAT (////' Starting shift =', I5, ' points')
               PARNLN(LPHAST)=DEGZER*RADIAN
               PARNLN(LPHAST+1)=DEGPPM*RADIAN
               PARNLN(LSHIST)=0.D0
C              ----------------------------------------------------------------
C              Here the peak broadening is done by multiplying the time-domain
C                data by exp{-[PARNLN(LRT2ST)*t]**2}, t in s, and
C                therefore PARNLN(LRT2ST) in radians/s.
C              FWHMST is in ppm.
C              ----------------------------------------------------------------
               IF (FWHMST .LE. 0.) CALL ERRMES (12, 4, CHSUBP)
               PARNLN(LRT2ST)=FWHMST/TOFWHM
C               LTEST=.TRUE.!CT1
               CALL PLINLS (1, IERROR)
               CNVRG1=CNVRG1 .OR. IERROR.EQ.1
C!CT1
C               PARNLN(LPHAST)=DEGZER*RADIAN!CT1
C               PARNLN(LPHAST+1)=DEGPPM*RADIAN!CT1
C               PARNLN(LSHIST)=0.D0!CT1
C               PARNLN(LRT2ST)=FWHMST/TOFWHM!CT1
C               DO 910 JY=1,NY!CT1
C                  CY(JY)=CYFIT(JY)!CT1
C  910          CONTINUE!CT1
C               CALL PLINLS (1, IERROR)!CT1
C               IF (LTEST) STOP!CT1
C!CT1
               IF (STDDEV .LT. SDSHBS) THEN
                  SDSHBS=STDDEV
C                 -------------------------------------------------------------
C                 Subtraction in the next line is necessary, because ISHIFD
C                   shifts the data and PARNLN(LSHIST) shifts the model.
C                 -------------------------------------------------------------
                  KSHFBS=ISHIFD-NINT(SNGL(PARNLN(LSHIST))*DELTAT*FNDATA/
     1                                 (2.*PI))
                  IF (LPRINT .GT. 0) WRITE (LPRINT,5331) KSHFBS,
     1                                 FLOAT(KSHFBS)*PPMINC
 5331             FORMAT (/' ******** Best data shift for this ',
     1                     'starting shift so far = ', I5,
     2                     ' points =', 1PE10.2, ' ppm')
                  IF (STDDEV .LT. SDBEST(1)) THEN
                     CALL SAVBES (1)
                     LSHFBS=KSHFBS
                     IF (LPRINT .GT. 0) WRITE (LPRINT,5332) LSHFBS,
     1                                    FLOAT(LSHFBS)*PPMINC
 5332                FORMAT (/' ************************ Best data ',
     1                        'shift for all starting shifts so far = ',
     2                        I5, ' points =', 1PE10.2, ' ppm')
                  END IF
               END IF
  338          TEST=DEGPPM+DDGPPM
               IF (TEST .LE. DGPPMX) THEN
                  DEGPPM=TEST
               ELSE
C                 -------------------------------------------------------------
C                 New DEGPPM would exceed DGPPMX.  Set DEGPPM to an endpoint;
C                   which endpoint is determined by how far TEST overshot
C                   DGPPMX.
C                 -------------------------------------------------------------
                  IF (TEST-DGPPMX .LE. .5*DDGPPM) THEN
                     DEGPPM=DGPPMX
                  ELSE
                     DEGPPM=DGPPMN
                  END IF
               END IF
  330       CONTINUE
  328       DEGZER=AMOD(DEGZER+DDEGZ,360.)
  320    CONTINUE
         INTSHF(JSHIFT,1)=MIN0(KSHFBS,ISHIFD)
         INTSHF(JSHIFT,2)=MAX0(KSHFBS,ISHIFD)
C        ----------------------------------------------------------------------
C        Use grid point in grid range that is farthest from the intervals
C          already covered.  If this max. distance is less than LGRDMN, then
C          exit.
C        ----------------------------------------------------------------------
         LMAX=LGRDMN-1
         DO 340 L=LSHFMN(3),LSHFMX(3)
            LMIN=NDATA
            DO 350 KSHIFT=1,JSHIFT
               LMIN=MIN0(LMIN, MAX0(INTSHF(KSHIFT,1)-L,
     1                              L-INTSHF(KSHIFT,2)))
  350       CONTINUE
            IF (LMIN .GT. LMAX) THEN
               LMAX=LMIN
               ISHFUS=L
            END IF
  340    CONTINUE
         IF (LMAX .LT. LGRDMN) GO TO 400
         CALL SHIFTD (ISHFUS)
  310 CONTINUE
      CALL ERRMES (13, 1, CHSUBP)
  400 IF (SDBEST(1) .GE. DRANGE) CALL ERRMES (14, 4, CHSUBP)
C     -------------------------------------------------------------------------
C     Load best values into PARNLN.
C     -------------------------------------------------------------------------
      CALL SAVBES (2)
      IF (LSHFBS .NE. ISHIFD) THEN
         CALL SHIFTD (LSHFBS)
         CALL REPHAS ()
C        ----------------------------------------------------------------------
C        Analysis with optimal shift to get best starting values with
C          optimally shifted and rephased data.
C        ----------------------------------------------------------------------
         PARNLN(LSHIST)=0.D0
 5400    FORMAT (////' Analysis with optimal data shift to get optimal',
     1               ' starting values')
         IF (LPRINT .GT. 0) WRITE (LPRINT,5400)
         MITER(1)=MITER(1)*2
         CALL PLINLS (1, IERROR)
         CNVRG1=CNVRG1 .OR. IERROR.EQ.1
         IF (OBJECT .GE. DRANGE) CALL ERRMES (15, 4, CHSUBP)
         CALL SAVBES (1)
         CALL SAVBES (2)
         LSHFBS=LSHFBS-NINT(SNGL(PARNLN(LSHIST))*DELTAT*FNDATA/(2.*PI))
      END IF
      IF (.NOT.CNVRG1) CALL ERRMES (16, 2, CHSUBP)
      FWHMST=AMAX1(0., TOFWHM*SNGL(PARBES(LRT2ST,1)))
      fwhmst_full = fwhmst
      IF (.not.DOFULL) THEN
c        ----------------------------------------------------------------------
c        Set ISHIFD=LSHFBS, just for final output as "Data shift" (without
c          shifting the data).
c        ----------------------------------------------------------------------
         ishifd = lshfbs
      else
         if (fwhmst .gt. fwhmmx) then
            fwhmst = fwhmmx
c           ------------------------------------------------------------------
c           With IMETHD=3, FWHMMX is set fairly low.  It determines the max
c              starting FWHM of the (e.g., Voigt) power functions.
c           Similarly, FWHMST determines the SIFWMN when SCAFWH=T
c           ------------------------------------------------------------------
            if (imethd .ne. 3   .and.   .not.scafwh)
     1         call errmes (25, 2, chsubp)
         end if
         IF (LSHFBS .NE. ISHIFD) THEN
            PARBES(LPHAST,2)=PARBES(LPHAST,2)+PHITOT(1)
            PARBES(LPHAST+1,2)=PARBES(LPHAST+1,2)+PHITOT(2)
            CALL SHIFTD (LSHFBS)
         END IF
         if (fixshf   .and.   lshfbs .ne. lshfbs_fixshf) then
            lshfbs = lshfbs_fixshf
            PARBES(LPHAST,2)=PARBES(LPHAST,2)+PHITOT(1)
            PARBES(LPHAST+1,2)=PARBES(LPHAST+1,2)+PHITOT(2)
            call shiftd(lshfbs)
         end if
         CALL REPHAS ()
         DEGZER=0.
         DEGPPM=0.
         if (scafwh   .or.   imethd .eq. 3) then
C           -------------------------------------------------------------------
C           SCAFWH assumes that there is no lineshape in Final
C           -------------------------------------------------------------------
            nsides = 0
            nside2 = 0
            incsid = 1
C           -------------------------------------------------------------------
C           FCONC_EXPECT = scale factor to multiply CONC_EXPECT to get
c                          ALPHAS in constant range (only used with IMETHD=2)
C           -------------------------------------------------------------------
            fconc_expect = 0.
            do 450 jmetab = 1, nmetab
               fconc_expect = fconc_expect + solbes(jmetab, 2)
 450        continue
            if (imethd .eq. 3) fwhmst = amax1(fwhmst, fwhmmn)
         else
C           -------------------------------------------------------------------
C           Compute NSIDES and INCSID, after checking their limits.
C           -------------------------------------------------------------------
            IF (NSIDMX .GT. MSIDES) THEN
               NSIDMX=MSIDES
               CALL ERRMES (17, 3, CHSUBP)
            END IF
            IF (NSIDMN.LE.0 .OR. NSIDMN.GT.NSIDMX) CALL ERRMES (18, 4,
     1                                                          CHSUBP)
            IF (INCSMX.LE.0 .OR. INCSMX.GT.MINCSD) THEN
               CALL ERRMES (19, 3, CHSUBP)
               INCSMX=MIN0(MINCSD,MAX0(1,INCSMX))
            END IF
            NSIDES=NINT(.5*FWHMST*RFWHM/PPMINC)
            IF (NSIDES .LT. NSIDMN) THEN
               CALL ERRMES (20, 1, CHSUBP)
               NSIDES=NSIDMN
            END IF
            INCSID=(NSIDES-1)/NSIDMX +1
            NSIDES=NINT((FLOAT(NSIDES)+.001)/FLOAT(INCSID))
            IF (INCSID .GT. INCSMX) THEN
               INCSID=INCSMX
               NSIDES=NSIDMX
               if (.not.nobasi) CALL ERRMES (21, 3, CHSUBP)
            END IF
C           -------------------------------------------------------------------
C           The data with ppm < PPMCEN run from NUNFIL+1 to NDATA
C           -------------------------------------------------------------------
            INCDIM=MIN0(LDATST-1,(ndata-LDATEN-1))/NSIDES
            IF (INCDIM .LE. 0) CALL ERRMES (22, 4, CHSUBP)
            IF (INCSID .GT. INCDIM) THEN
               INCSID=INCDIM
               CALL ERRMES (23, 3, CHSUBP)
            END IF
            IF (INCSID .GT. 4) then
               CALL ERRMES (24, 2, CHSUBP)
            else if (INCSID .GT. 1) then
               CALL ERRMES (24, 1, CHSUBP)
            end if
         end if
         IF (LPRINT .GT. 0) WRITE (LPRINT,5410) LSHFBS,
     1         FLOAT(LSHFBS)*PPMINC, PHITOT(1)/RADIAN,
     2         PHITOT(2)/RADIAN, fwhmst_full, NSIDES, INCSID
 5410     FORMAT (////' Starting values for final analysis'/
     1                ' Shift =', I5, ' points =', F7.4, ' ppm'/
     2                ' Phi(0) =', F8.1, ' deg'/
     3                ' Phi(1) =', F8.2, ' deg/ppm'/
     4                ' FWHM =', F6.3, ' ppm'/
     5                ' NSIDES =', I3,/
     6                ' INCSID =', I2///)
      END IF
      END
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE FTDATA (ISHIFT)
C
C  DATAF(JDATA) = unshifted frequency-domain data (finally) (COMPLEX).
C  DATAF(1+nunfil): corresponds to PPMCEN; i.e., the spectrum is rearranged.
C  CY(JY) = shifted (by ISHIFT) frequency-domain data in analysis window.
C
      INCLUDE 'lcmodel.inc'
      CHSUBP='FTDATA'
C     -------------------------------------------------------------------------
C     DATAF = zero-filled time-domain data (temporarily).
C           = unshifted frequency-domain data (finally).
C     -------------------------------------------------------------------------
      DO 120 JUNFIL=1,NUNFIL
         DATAF(JUNFIL)=DATAT(JUNFIL)
         DATAF(JUNFIL+NUNFIL)=(0.,0.)
  120 CONTINUE
      CALL CFFT_r (DATAF, DATAF, NDATA, LWFFT,
     1           WFFTC)
C     -------------------------------------------------------------------------
C     CY(JY) = frequency-domain data in window to be analyzed (COMPLEX).
C     -------------------------------------------------------------------------
      CALL SHIFTD (ISHIFT)
C     -------------------------------------------------------------------------
C     RMSAMP will be used in GBACKG to scale background, so that the columns
C       of the Hessian will be of similar magnitude for better performance in
C       PNNLS.
C     -------------------------------------------------------------------------
      RMSAMP=0.
      DO 150 JY=1,NY
         if (.not.lcy_skip(jy))
     1      RMSAMP=RMSAMP+REAL(CY(JY))**2+AIMAG(CY(JY))**2
  150 CONTINUE
      RMSAMP=SQRT(RMSAMP/FLOAT(NYuse))
      IF (RMSAMP .LE. 0.) then
         istago = 0
         CALL ERRMES (1, 4, CHSUBP)
      end if
      END
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE SHIFTD (ISHIFT)
C
C  Shift CY ISHIFT points from original unshifted position.
C  ISHIFD = ISHIFT = current shift.
C
      INCLUDE 'lcmodel.inc'
      CHSUBP='SHIFTD'
      JDATA=LDATST+ISHIFT
      DO 150 JY=1,NY
         CY(JY)=DATAF(ICYCLE_r(JDATA,NDATA))
         JDATA=JDATA+1
  150 CONTINUE
C     -------------------------------------------------------------------------
C     ISTAGO = 2 when CY is loaded with frequency-domain data, and can
C                therefore be plotted in EXITPS.
C     -------------------------------------------------------------------------
      ISTAGO=2
      IF (PHITOT(1).NE.0. .OR. PHITOT(2).NE.0.) THEN
         PHITOT(1)=0.
         PHITOT(2)=0.
      END IF
      ISHIFD=ISHIFT
      END
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE SETUP (LSTAGE)
C
C  Set up variables for calls to PLINLS.
C  LSTAGE = 1 for initial analyses with restricted model.
C         = 2 for analyses with full model.
C
      INCLUDE 'lcmodel.inc'
      LOGICAL LDELTA, LERROR
      CHSUBP='SETUP'
c     -------------------------------------------------------------------------
c     If SCAFWH=T, use lineshape in Prel so that FWHMST can be used to
c        determine # of knots in Final.  All NMETAB in Prel will be with
c        lineshape; so must set CHUSE1 carefully and BADREF=F.  For FWHMST to
c        be useful, only sharpest models should be used in Prel.
c     If SCAFWH=T, FWHMST also determines the FWHM specs of the simulated
c        basis spectra.
c     -------------------------------------------------------------------------
      if ((scafwh   .or.   imethd .eq. 3)   .and.   lstage .eq. 1)
     1   then
         do 120 j = 1, nmetab
            lshape(j) = .true.
 120     continue
      end if
      if (nobase) go to 200
C     -------------------------------------------------------------------------
C     NBACKG is set so that there will be a knot every
C       FWHMST_full*RBACKG(LSTAGE) ppm.
C     -------------------------------------------------------------------------
      if (lstage .eq. 1) fwhmst_full = fwhmst
      TEST=AMAX1(DKNTMN(IKNTMN),fwhmst_full*RBACKG(LSTAGE))
      IF (TEST .LE. 0.) CALL ERRMES (1, 4, CHSUBP)
      NBACKG=NINT((delppm(1) - delppm(ny))/TEST)+3
c     -------------------------------------------------------------------------
c     Each gap can introduce 2 extra (external) knots (although large gaps
c        will reduce the # knots).
c     -------------------------------------------------------------------------
      IF (NBACKG .GT. MBACKG - 2 * ngap) THEN
         CALL ERRMES (2, 3, CHSUBP)
         NBACKG=MBACKG - 2 * ngap
      END IF
C     -------------------------------------------------------------------------
C     Get BACKGR(JY,JBACKG) = background terms (REAL).
c     Compute REGB = (temporarily) Squared baseline regularizor
C     -------------------------------------------------------------------------
      CALL GBACKG ()
C
C      DO 140 IROW=1,NBACKG!
C         WRITE (LPRINT,5150) (REGB(IROW,J),J=1,NBACKG) !DELETE
C 5150    FORMAT (/(1X,1P10E13.5)) !DELETE
C  140 CONTINUE!
C     -------------------------------------------------------------------------
C     Eigenvalue decomposition of squared regularizor (not the fastest way,
C       but simple and stable).  Because of the lack of boundary conditions,
C       REGB is only of rank NBACKG-2.
C     The IMSL routine EVCSF normalizes the eigenvectors in the infinity-norm.
C       This destroys the orthognality of the matrix of eigenvectors.  The
C       IMSL eigenvectors would have to be renormalized in the Euclidean norm.
C       Use EISPACK routines instead.
C     CPY = vector of eigenvalues (temporarily).
C     WFFTC = matrix of eigenvectors (temporarily).
C     -------------------------------------------------------------------------
C      CALL EVCSF (NBACKG, REGB, MBACKG, CPY, WFFTC, MBACKG)!
C      DO 9145 J=1,NBACKG!
C         RNORM=0.!
C         IPOINT=(J-1)*MBACKG!
C         DO 9146 K=1,NBACKG!
C            RNORM=RNORM+WFFTC(IPOINT+K)**2!
C 9146    CONTINUE!
C         RNORM=1./SQRT(RNORM)!
C         DO 9147 K=1,NBACKG!
C            WFFTC(IPOINT+K)=WFFTC(IPOINT+K)*RNORM!
C 9147    CONTINUE!
C 9145 CONTINUE!
      LWFFT=0
      CALL EIGVRS (MBACKG, NBACKG, REGB, CPY, WFFTC, DAMAT, DAMAT(1,2),
     1             IERROR)
      IF (IERROR .NE. 0) CALL ERRMES (4, 4, CHSUBP)
C      WRITE (LPRINT,5150) (CPY(J),J=1,NBACKG)!
C     -------------------------------------------------------------------------
C     REGB = regularizor
C          = square root of above squared regularizor in REGB
C     -------------------------------------------------------------------------
      DO 150 ICOL=1,NBACKG
         DO 160 IROW=1,NBACKG
            REGB(IROW,ICOL)=0.
  160    CONTINUE
  150 CONTINUE
      DO 170 ICOL=1,NBACKG
         IPOINT=(ICOL-1)*MBACKG
         IF (CPY(ICOL) .GT. 0.) THEN
            FACT=SQRT(CPY(ICOL))
            DO 180 JCOL=1,NBACKG
               TERM=WFFTC(IPOINT+JCOL)*FACT
               DO 181 IROW=1,NBACKG
                  REGB(IROW,JCOL)=REGB(IROW,JCOL)+WFFTC(IPOINT+IROW)*
     1                                            TERM
  181          CONTINUE
  180       CONTINUE
         END IF
  170 CONTINUE
C     -------------------------------------------------------------------------
C     Scale REGB for normalized B-splines.
C     The check for a zero denominator below was just done in GBACKG.
C     -------------------------------------------------------------------------
      FNORM=(FLOAT(NBACKG-3)/(DELPPM(1)-DELPPM(NY)))**4
      DO 183 ICOL=1,NBACKG
         DO 184 IROW=1,NBACKG
            REGB(IROW,ICOL)=REGB(IROW,ICOL)*FNORM
  184    CONTINUE
  183 CONTINUE
C      DO 9160 IROW=1,NBACKG !DELETE
C         IF (LPRINT .GT. 0) WRITE (LPRINT,5150) (REGB(IROW,J),
C     1                                           J=1,NBACKG) !
C 9160 CONTINUE !
C      DO 9195 IROW=1,NBACKG!
C         DO 9196 ICOL=1,NBACKG!
C            TERM=0.!
C            DO 9197 J=1,NBACKG!
C               TERM=TERM+REGB(J,IROW)*REGB(J,ICOL)!
C 9197       CONTINUE!
C            CPY(ICOL)=TERM!
C 9196    CONTINUE!
C         WRITE (LPRINT,5150) (CPY(ICOL),ICOL=1,NBACKG)!
C 9195 CONTINUE!
C      IF (NBACKG .GE. 0) STOP!
C     -------------------------------------------------------------------------
C     Initialize arrays for PLINLS.
C     First initialize linear parameters.
C     -------------------------------------------------------------------------
 200  NLIN=NMETAB+NBACKG
      IF (NLIN .GT. MPAR) CALL ERRMES (5, 4, CHSUBP)
      DO 210 JPAR=1,NLIN
         SOLUTN(JPAR)=0.D0
  210 CONTINUE
C     -------------------------------------------------------------------------
C     Initialize lineshape parameters.
C     PARNLN = normalized Gaussian with fwhm=FWHMST.
C     -------------------------------------------------------------------------
      NSIDE2=2*NSIDES
      NNONL=NSIDE2
      IF (NNONL .GT. MNONL) CALL ERRMES (6, 4, CHSUBP)
      RNORM=1.
      LDELTA=FWHMST .LT. .5*PPMINC
      rexp = rrange
      IF (.NOT.LDELTA) REXP=-4.*ALOG2*(FLOAT(INCSID)*PPMINC/FWHMST)**2
      DO 230 JSIDE=1,NSIDES
         IF (LDELTA) THEN
            TERM=0.
         ELSE
            TERM=EXP(REXP*FLOAT(JSIDE)**2)
         END IF
         PARNLN(NSIDES+1-JSIDE)=TERM
         PARNLN(NSIDES+JSIDE)=TERM
         RNORM=RNORM+2.*TERM
  230 CONTINUE
      RNORM=1./RNORM
      DO 250 JNONL=1,NNONL
         PARNLN(JNONL)=PARNLN(JNONL)*RNORM
         DPARMQ(JNONL)=DFLDMQ
  250 CONTINUE
      IF (LSTAGE .EQ. 2   .and.   imethd .ne. 2)
     1    THEN
C        ----------------------------------------------------------------------
C        DGAUSS = a 1-sided normalized Gaussian profile with a fwhm of FWHMBA
C                 ppm.
C        ----------------------------------------------------------------------
         IF (FWHMBA .LE. 0.) CALL ERRMES (7, 4, CHSUBP)
         REXP=-4.*ALOG2*(FLOAT(INCSID)*PPMINC/FWHMBA)**2
         RNORM=1.
         DGAUSS(0)=1.D0
         DO 255 J=1,NSIDE2+4
            TERM=EXP(REXP*FLOAT(J)**2)
            DGAUSS(J)=TERM
            RNORM=RNORM+2.*TERM
  255    CONTINUE
         RNORM=1./RNORM
         DO 256 J=0,NSIDE2+4
            DGAUSS(J)=DGAUSS(J)*RNORM
  256    CONTINUE
      END IF
C     IF (LSTAGE .EQ. 2) THEN!DELETE
C         WRITE (LPRINT,9250) (PARNLN(J),J=1,NNONL)!DELETE
C 9250    FORMAT (//' Starting Gaussian profile'/(1X, 1P10E13.3))!
C         IF (LPRINT .GT. 0) STOP!DELETE
C     END IF!DELETE
C     -------------------------------------------------------------------------
C     Initialize phase parameters.
C     -------------------------------------------------------------------------
      LPHAST=NNONL+1
      NNONL=NNONL+2
      IF (NNONL .GT. MNONL) CALL ERRMES (8, 4, CHSUBP)
      PARNLN(NNONL-1)=DEGZER*RADIAN
      PARNLN(NNONL)=DEGPPM*RADIAN
      DPARMQ(NNONL-1)=DDGZMQ(LSTAGE)*RADIAN
      DPARMQ(NNONL)=DDGPMQ(LSTAGE)*RADIAN
C     -------------------------------------------------------------------------
C     Initialize shift parameters.
C     -------------------------------------------------------------------------
      IF (LSTAGE .EQ. 1) THEN
         ALPHAB=0.D0
         ALPHAS=0.D0
         NEXPON=1
C        ----------------------------------------------------------------------
C        Set (max. step size)/FSTPMQ to RSHFMQ*(initial estimate of FWHM).
C        ----------------------------------------------------------------------
         DMARQ=RSHFMQ*FWHMST
C        ----------------------------------------------------------------------
C        Above DMARQ is in ppm; convert this to radians/s.
C        ----------------------------------------------------------------------
         DMARQ=DMARQ*2.*PI*HZPPPM
         LSHIST=NNONL+1
         NNONL=NNONL+NEXPON
         IF (NNONL .GT. MNONL) CALL ERRMES (11, 4, CHSUBP)
         PARNLN(lshist)=0.D0
         DPARMQ(lshist)=DMARQ
      ELSE
         ALPHAB=ALPBST
         IF (NSIDES.LE.0   .AND.   ALPSST.gt.0.   .and.   imethd .ne. 2)
     1       ALPSST=0.
         ALPHAS=ALPSST
         IF (ALPHAB.LE.0.D0 .OR. ALPHAS.LT.0.D0) CALL ERRMES (10, 4,
     1                                                        CHSUBP)
         NEXPON=NMETAB
         LSHIST=NNONL+1
         NNONL=NNONL+NEXPON
         IF (NNONL .GT. MNONL) CALL ERRMES (11, 4, CHSUBP)
c        ----------------------------------------------------------------------
c        Set (max. step size)/FSTPMQ to RSDSMQ * SDSHIF
c        ----------------------------------------------------------------------
         jmetab = 0
         DO 260 JNONL=LSHIST,NNONL
            PARNLN(JNONL)=0.D0
            jmetab = jmetab + 1
            DPARMQ(JNONL)= rsdsmq * sdshif(jmetab)
 260     CONTINUE
      END IF
C     -------------------------------------------------------------------------
C     Initialize broadening parameters.
C     -------------------------------------------------------------------------
      LRT2ST=NNONL+1
      NNONL=NNONL+NEXPON
      IF (NNONL .GT. MNONL) CALL ERRMES (12, 4, CHSUBP)
      IF (NSIDES .GT. 0   .or.   imethd .eq. 2) THEN
         JMETAB=0
         DO 270 JNONL=LRT2ST,NNONL
            JMETAB=JMETAB+1
            PARNLN(JNONL)=EXRT2(JMETAB)

C            write(6, 9270) jnonl, parnln(jnonl) * tofwhm!<<< = 4, .04995
c 9270       format('FWHM(', i2, ') =', 1pe10.3)

            DPARMQ(JNONL)=rrt2mq * EXRT2(JMETAB)
  270    CONTINUE
      ELSE
C        ----------------------------------------------------------------------
C        NSIDES = 0. Use FWHMST for initial estimate.  In the usual case that
C          LSTAGE=1, FWHMST is input data. When LSTAGE=2, it is from the
C          initial analysis with LSTAGE=1.
C        ----------------------------------------------------------------------
         IF (LSTAGE .EQ. 1) THEN
C           -------------------------------------------------------------------
C           Here the peak broadening is done by multiplying the time-domain
C             data by exp{-[PARNLN(LRT2ST)*t]**2}, t in s, and therefore
C             PARNLN(LRT2ST) in radians/s
C           FWHMST is in ppm.
C           -------------------------------------------------------------------
            IF (FWHMST .LE. 0.) CALL ERRMES (13, 4, CHSUBP)
            PARNLN(LRT2ST)=FWHMST/TOFWHM
         ELSE
            if (imethd .eq. 3) then
               call setup3 ()
            else
C              ----------------------------------------------------------------
C              Here the peak broadening will be done by multiplying the
C                time-domain data by exp(-PARNLN*t), t in s and therefore
C                PARNLN in 1/s.
C              A Lorenzian has 1/T2 = PI*fwhm.
C              FWHMST is in ppm.
C              ----------------------------------------------------------------
               PARNLN(LRT2ST)=PI*FWHMST*HZPPPM
            end if
         END IF
         DPARMQ(LRT2ST)=RRT2MQ*PARNLN(LRT2ST)
         if (imethd .ne. 3) then
C           -------------------------------------------------------------------
C           Set (max. step size)/FSTPMQ to RRT2MQ*(initial estimate).
C           -------------------------------------------------------------------
            DO 275 JNONL=LRT2ST+1,NNONL
               PARNLN(JNONL)=PARNLN(LRT2ST)
               DPARMQ(JNONL)=DPARMQ(LRT2ST)
 275        CONTINUE
         end if
      END IF
      DO 277 JNONL=LRT2ST,NNONL
         IF (PARNLN(JNONL) .LE. 0.D0) CALL ERRMES (14, 4, CHSUBP)
  277 CONTINUE
      NPAR=NLIN+NNONL
      IF (NPAR .GT. MPAR) CALL ERRMES (15, 4, CHSUBP)
C     -------------------------------------------------------------------------
C     Set NONNEG, except for
c       JPAR=1,NMETAB, which were set in MYBASI
c       JPAR=NMETAB+1,NMETAB+NBACKG, which must be set in GBACKG.
C     NONNEG for delta(1/T2) will be reset in PASTEP to constrain delta(1/T2)
C       to be nonnegative.
C     -------------------------------------------------------------------------
      DO 290 JPAR=NLIN+1,NPAR
         NONNEG(JPAR)=.FALSE.
  290 CONTINUE
      IF (NSIDES .GT. 0) THEN
C        ----------------------------------------------------------------------
C        Set up 2nd-order regularizor for lineshape coefficients with zero
C          boundary conditions.
C          The rows start from the center and work outward.  The 1st 3 rows
C            correspond to the equality constraint that has eliminated the
C            center point as a parameter; these 1st 3 also have extra
C            constants (2, -1, -1) on the rhs of the regularizor.
C        ----------------------------------------------------------------------
         NCOLRF=NSIDE2
         NREGF=NSIDE2+3
         DO 310 IROW=4,NREGF
            DO 320 ICOL=1,NCOLRF
               REGF(IROW,ICOL)=0.D0
  320       CONTINUE
  310    CONTINUE
         DO 330 ICOL=1,NCOLRF
            REGF(1,ICOL)=2.D0
            REGF(2,ICOL)=-1.D0
            REGF(3,ICOL)=-1.D0
  330    CONTINUE
         REGF(1,NSIDES)=3.D0
         REGF(1,NSIDES+1)=3.D0
         IF (NSIDES .GE. 2) REGF(2,NSIDES-1)=0.D0
         REGF(2,NSIDES)=-3.D0
         REGF(3,NSIDES+1)=-3.D0
         IF (NSIDES .GE. 2) REGF(3,NSIDES+2)=0.D0
         IROW=3
         DO 340 JCENTR=2,NSIDES+1
            IROW=IROW+1
            ICOL=NSIDES+JCENTR
            REGF(IROW,ICOL-1)=1.D0
            IF (JCENTR .LE. NSIDES) REGF(IROW,ICOL)=-2.D0
            IF (JCENTR .LT. NSIDES) REGF(IROW,ICOL+1)=1.D0
            IROW=IROW+1
            ICOL=NSIDES+1-JCENTR
            REGF(IROW,ICOL+1)=1.D0
            IF (ICOL .GE. 1) REGF(IROW,ICOL)=-2.D0
            IF (ICOL .GT. 1) REGF(IROW,ICOL-1)=1.D0
  340    CONTINUE
      END IF
C     -------------------------------------------------------------------------
C     First initialize SDREF with PMQACT=0 to avoid possible stalling later in
C       PLINLS.
C     -------------------------------------------------------------------------
      INISOL=.TRUE.
      SDREF=DRANGE
      CALL SOLVE (LSTAGE, .FALSE., 0.D0, .FALSE., LERROR)
      END
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE setup3 ()
c
c Called when IMETHD=3 and LSTAGE=2.
c Set starting values for PARNLN & DPARMQ
c
      INCLUDE 'lcmodel.inc'
      double precision ddtime, dtime
      real pstart(mmpowr)
      chsubp = 'SETUP3'
      start1 = alog(pi * hzpppm * fwhmst)
      start2 = 2. * alog(fwhmst / tofwhm)
      ddtime = dble(deltat)
      if (mpower .gt. mmpowr   .or.   mpower .lt. 1   .or.
     1    amin1(fmain_power, fother_power) .le. -.001   .or.
     2    amax1(fmain_power, fother_power) .ge. 1.001)
     3   call errmes (1, 4, chsubp)
      do 110 jpower = 1, mpower
         if (power(jpower) .lt. .999d0   .or.
     1       power(jpower) .gt. 2.001d0) call errmes (2, 4, chsubp)
         dtime = 0.d0
         do 120 jdata = 1, ndata
            tpower(jpower, jdata) = dtime ** power(jpower)
            dtime = dtime + ddtime
 120     continue
c        ---------------------------------------------------------------------
c        Geometric mean
c        ---------------------------------------------------------------------
         term = power(jpower)
         pstart(jpower) = exp((2. - term) * start1 +
     1                        (term - 1.) * start2)
 110  continue
      ncoeff_power = 0
c     ------------------------------------------------------------------------
c     NNONL was already incremented by NMETAB in SETUP.  Set it back and then
c        increment it here.
c     ------------------------------------------------------------------------
      nnonl = lrt2st - 1
      lpowen(0) = nnonl
      do 210 jmetab = 1, nmetab
         ncoeff_power = ncoeff_power + 1
         nnonl = nnonl + 1
c        ---------------------------------------------------------------------
c        FMAIN_POWER = attenuation factor for starting values of PARNLN for
c                      1st broadening term (typically 0.6)
c        FOTHER_POWER = attenuation factor for starting values of PARNLN for
c                       other broadening terms (typically 0.1)
c        ---------------------------------------------------------------------
         parnln(nnonl) = fmain_power * pstart(1)
         dparmq(nnonl) = rpowmq * pstart(1)
c        ----------------------------------------------------------------------
c        COEFF_POWER_SD = prior SD of power coefficient (analogous to SDRT2).
c        All prior means are zero, to suppress excessive broadening.  Typical
c        values for FRACT_POWER_SD might be 0.5 for component 1 and somewhat
c        less for others.
c        ----------------------------------------------------------------------
         coeff_power_sd(1, jmetab) = fract_power_sd(1, jmetab) *
     1                               pstart(1)
         do 230 jpower = 2, npower(jmetab)
            ncoeff_power = ncoeff_power + 1
            nnonl = nnonl + 1
            if (nnonl .gt. mnonl   .or.
     1        ncoeff_power .gt. mcoeff_power) call errmes (3, 4, chsubp)
            parnln(nnonl) = fother_power * pstart(jpower)
            dparmq(nnonl) = rpowmq * pstart(jpower)
            coeff_power_sd(jpower, jmetab) =
     1         fract_power_sd(jpower, jmetab) * pstart(jpower)
 230     continue
         lpowen(jmetab) = nnonl
 210  continue
      end
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE PHASTA ()
C
C  Get starting estimates for the 0- and 1st-order phase corrections for the
C    data.
C  These can be specified in 5 ways:
C    (1) NDGPPM(1) > 1 will cause a grid search over NDGPPM(1) points in
C                      DEGPPM=[DGPPMN,DGPPMX] and NDEGZ(1) points in
c                      DEGZER=[0,180] for the minimum of the
c                      |vertical distance|**IPOWPH
c                      traveled by the real part of the smoothed spectrum.
c                      With IPOWPH about 6, the big jumps in the center of the
c                      dispersion part will count very strongly and help to
c                      eliminate these.
c                      This criterion will be
c                      weakened by noise and also if the residual water peak
c                      is incoherent (as in a strongly water-suppressed
c                      spectrum).  However, final results do not seem to be
c                      significantly affect by PHASTA.
c                      Until 6.2-0G, IPOWPH=1.
c                      Until 6.1-4K, the
c                      sum of the squares of the integrals over the real and
c                      imaginary parts was maximized. This now seems like
c                      nonsense (especially if the water tails intrudes).
c                      Also, this criterion would be identical for 90, 180 &
c                      270-deg phase changes.
C    (2) NDGPPM(1) = 1 will set DEGPPM=DEGPPM with DEGZER set as in (1).
C    (3) NDGPPM(1) < 1 will cause input values of DEGZER or DEGPPM to be used.
C    (4) SDDEGZ<45 will cause the input value of DEGZER to be used;
C        SDDEGZ < min[DDGZMQ(1),DDGZMQ(2)]/3 will cause DEGZER to be fixed to
C                 its input value throughout the analysis.
C    (5) SDDEGP < 10 will cause the input value of DEGPPM to be used;
C        SDDEGP < min[DDGPMQ(1),DDGPMQ(2)]*.4 will cause DEGPPM to be fixed to
C                 its input value throughout the analysis.
C  The criteria in (1) and (2) can be poor if incomplete water suppression
C    causes a significant part of the phased real part of the spectrum to be
C    negative.
c
      INCLUDE 'lcmodel.inc'
      complex data_ph1(my), data_zero(mdata)
      double precision dist, distmn
      LOGICAL STARTP, STARTZ
      CHSUBP='PHASTA'
      SDDEGP=AMAX1(SDDEGP,0.)
      SDDEGZ=AMAX1(SDDEGZ,0.)
C     -------------------------------------------------------------------------
C     START* = T means that DEGZER or DEGPPM will be used as starting values.
C     FXDEG* = T means that DEGZER or DEGPPM will be fixed at their input
C                values throughout the analysis.
C     -------------------------------------------------------------------------
      FXDEGZ=SDDEGZ .LT. AMIN1(DDGZMQ(1),DDGZMQ(2))/3.
      STARTZ=SDDEGZ.LT.45. .OR. FXDEGZ .OR. NDGPPM(1).LE.0
      IF (FXDEGZ) NDEGZ(2)=1
      FXDEGP=SDDEGP .LT. AMIN1(DDGPMQ(1),DDGPMQ(2))*.4
      STARTP=SDDEGP.LT.10. .OR. NDGPPM(1).LE.0 .OR. FXDEGP
      IF (FXDEGP) NDGPPM(2)=1
C     -------------------------------------------------------------------------
C     DEGZER and DEGPPM are the input expectation values; save these in EXDEGZ
C       and EXDEGP.
C     -------------------------------------------------------------------------
      DEGZER=AMOD(DEGZER,360.)
      EXDEGZ=DEGZER
      EXDEGP=DEGPPM
C     -------------------------------------------------------------------------
C     Put EXDEGP in range of DGPPM*.
C     -------------------------------------------------------------------------
      if (exdegp .lt. dgppmn) then
         exdegp = dgppmn
         call errmes (1, 3, chsubp)
      else if (exdegp .gt. dgppmx) then
         exdegp = dgppmx
         call errmes (1, 3, chsubp)
      end if
      IF (.NOT.STARTZ .OR. .NOT.STARTP) THEN
C        ----------------------------------------------------------------------
C        Grid search for starting values for DEGZER and/or DEGPPM.
C        ----------------------------------------------------------------------
         IF (STARTP) NDGPPM(1)=1
         IF (NDGPPM(1) .GT. 1) THEN
            DELTPP=(DGPPMX-DGPPMN)/FLOAT(NDGPPM(1)-1)
            DEGPPM=DGPPMN-DELTPP
         ELSE
            DELTPP=0.
         END IF
         if (startz) ndegz(1) = 1
         if (ndegz(1) .gt. 1) then
            deltz = 180. / float(ndegz(1))
         else
            deltz = 0.
         end if
C        ----------------------------------------------------------------------
C        DATAF_ZERO = (temporarily) Gaussian-smoothed FFT of zero-filled
C                     (time-domain) DATAT (COMPLEX).
C        DATA_ZERO(1+nunfil): corresponds to PPMCEN; i.e., the spectrum is
c                         rearranged.
c        Use SDSMOO(3) for SD of smoothing.
C        ----------------------------------------------------------------------
         RSD=2.*PI*SDSMOO(3)/(PPMINC*FNDATA)
         DO 110 JUNFIL=1,NUNFIL
            DATA_ZERO(JUNFIL)=DATAT(JUNFIL)*
     1                    EXP(-.5*(RSD*FLOAT(JUNFIL-1))**2)
            DATA_ZERO(NUNFIL+JUNFIL)=(0.,0.)
  110    CONTINUE
         CALL CFFT_r (DATA_ZERO, DATA_ZERO, NDATA, LWFFT,
     1              WFFTC)
C        ----------------------------------------------------------------------
c        Start of main loop for phase optimization.
C        ----------------------------------------------------------------------
         distmn = 1.0d300
         sumbes = 9.
         degppm_best = 999.
         degzer_best = 999.
         do 210 jdgppm = 1, ndgppm(1)
            DEGPPM=DEGPPM+DELTPP
            CTERM(1)=CEXP(CMPLX(0.,RADIAN*DELPPM(1)*DEGPPM))
            CTERM(2)=CEXP(CMPLX(0.,-RADIAN*PPMINC*DEGPPM))
            jy = 0
            DO 220 JDATA=LDATST,LDATEN
               jy = jy + 1
               data_ph1(jy) = data_zero(jdata) * cterm(1)
               CTERM(1)=CTERM(1)*CTERM(2)
 220        continue
            degzer_try = degzer - deltz
            do 230 jdegz = 1, ndegz(1)
               degzer_try = degzer_try + deltz
               cterm(3) = cexp(cmplx(0., radian * degzer_try))
               dist = 0.
               sum = 0.
               dterm(1) = real(data_ph1(1) * cterm(3))
               do 240 jy = 2, ny
                  dterm(2) = real(data_ph1(jy) * cterm(3))
                  if (.not.lcy_skip(jy)) then
                     dist = dist + dabs(dterm(2) - dterm(1))**ipowph
                     sum = sum + sngl(dterm(2))
                  end if
                  dterm(1) = dterm(2)
 240           continue
               if (dist .le. distmn) then
                  distmn = dist
                  sumbes = sum
                  degppm_best = degppm
                  degzer_best = degzer_try
               end if
 230        continue
 210     continue
         if (.not.startp) degppm = degppm_best
         if (.not.startz) degzer = degzer_best
c        ---------------------------------------------------------------------
c        SUMBES < 0 implies that spectrum is negative of properly phased
c        one.  This may be incorrect if there is a big offset or if
c        DEGPPM is so big that some peaks are negative and some positive
c        (but that would require a bigger DEGPPM than usually allowed).
c        ---------------------------------------------------------------------
         if (ndegz(1) .gt. 1   .and.   sumbes .lt. 0.)
     1         degzer = degzer - 180.
      END IF
      END
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE GBACKG ()
C
C  Load BACKGR(JY,JBACKG) = background terms (REAL).
C  Background is a cubic B-spline with NBACKG equally spaced knots on the
C    (-DELPPM)-axis; i.e., the grid points are positive and increasing (for
C    computational convenience).
C  Background is scaled by RMSAMP (rms amplitude of frequency-domain data) for
C    similar magnitudes of Hessian columns and for near data-independence of
C    ALPHAB and ALPHAS values.
C  Knots 2 and (NBACKG-1) correspond to PPMST and PPMEND; i.e., there is 1
C    knot beyond each endpoint (to allow full freedom at the endpoints).
C  Neither speed nor precision are important in this subprogram.
C
      INCLUDE 'lcmodel.inc'
      real ppmmax(mgap + 1), ppmmin(mgap + 1)
      CHSUBP='GBACKG'
      IF (NBACKG .LT. nbckmn) THEN
         IF (MBACKG .LT. nbckmn) CALL ERRMES (2, 4, CHSUBP)
         NBACKG=nbckmn
      END IF
      DO 110 JBACKG=1,MBACKG
         DO 120 JY=1,NY
            BACKGR(JY,JBACKG)=0.
  120    CONTINUE
         do 130 icol = 1, mbackg
            regb(jbackg, icol) = 0.
 130     continue
  110 CONTINUE
      DELTA=(DELPPM(1)-DELPPM(NY))/FLOAT(NBACKG-3)
      IF (DELTA .LE. 0.) CALL ERRMES (3, 4, CHSUBP)
      region_min = 4. * delta
      FNORM=RMSAMP/(6.*DELTA**4)
c     -------------------------------------------------------------------------
c     NBACKG will be recomputed (and may change if NGAP>0) below.
c     PPMMAX(J) = the left (high) ppm value for the Jth background region.
c     PPMMIN(J) = the right (low) ppm value for the Jth background region.
c     NREGION = # of ppm-regions with separate baselines (which may be
c               reduced).
c     -------------------------------------------------------------------------
      do 210 jgap = 1, ngap
         ppmmax(jgap + 1) = ppmgap(2, jgap)
         ppmmin(jgap) = ppmgap(1, jgap)
 210  continue
      ppmmax(1) = delppm(1) + ppmcen
      ppmmin(ngap + 1) = delppm(ny) + ppmcen
      nregion = ngap + 1
      nsep = 0
      if (ngap .gt. 0) then
c        ----------------------------------------------------------------------
c        PPMSEP: the baseline should be separated into separate baselines with
c           separate free boundaries on each side of PPMSEP.
c        ----------------------------------------------------------------------
         do 230 jsep = 1, mgap
            if (ppmsep(jsep) .ge. ppmst - region_min   .or.
     1          ppmsep(jsep) .le. ppmend + region_min) go to 240
            nsep = nsep + 1
            ppmsep(nsep) = ppmsep(jsep)
            if (lprint .gt. 0) write (lprint, 5232) ppmsep(nsep)
 5232       format (//'PPMSEP =', f7.3/)
 230     continue
 240     continue
         if (ldump(2)) then
            write (6,5230) nbackg
 5230       format (/'NBACKG =', i3)
            write (6, 5240) ((ppmgap(j, k), j=1,2), k=1,ngap)
 5240       format ('PPMGAP =', 5(2f8.2, 3x))
            write (6,5241) (ppmmax(j), ppmmin(j), j=1,nregion)
 5241       format ('PPMMNX =',  5(2f8.2, 3x))
            write (6, 5242) (ppmsep(j), j=1,nsep)
 5242       format('PPMSEP =', 10f8.2)
         end if
      end if
c     -------------------------------------------------------------------------
c     Merge all baseline regions without PPMSEP between them.
c     -------------------------------------------------------------------------
      nregion_old = nregion
      do 250 kregion = 1, nregion_old - 1
         do 260 jregion = 1, nregion - 1
            do 270 jsep = 1, nsep
               if (ppmmin(jregion) .ge. ppmsep(jsep)   .and.
     1             ppmmax(jregion + 1) .le. ppmsep(jsep)) go to 260
 270        continue
            call merge_right(jregion, ppmmin, ppmmax, nregion)
c            write (6, 9270) jregion
c 9270       format (/'Right-merging region', i2)
c            write (6,5241) (ppmmax(j), ppmmin(j), j=1,nregion)
            go to 250
 260     continue
 250  continue
c     -------------------------------------------------------------------------
c     If a region is too small to support its own baseline (of 4 knots), then
c        merge it with a neighboring region (for background only; the gaps
c        remain).  Merging will be done over lowest-priority PPMSEP(J) (i.e.,
c        with the highest J).  Typical usage is to input PPMSEP(1)=4.65, when
c        the feet of the water peak are strong (especially when they are
c        dispersive, pointing in opposite directions).
c     -------------------------------------------------------------------------
      nregion_old = nregion
      do 280 kregion = 1, nregion_old
         do 290 jregion = 1, nregion
            test = ppmmax(jregion) - ppmmin(jregion)
            if (test .ge. region_min) go to 290
c           -------------------------------------------------------------------
c           Region JREGION is too small; merge it.
c           From the above merges, there must already be a PPMSEP between all
c              regions.  Merge over the lowest priority PPMSEP.
c           -------------------------------------------------------------------
            if (jregion .ge. nregion) then
               jsep_right = 0
            else
               do 310 jsep_right = 1, nsep
                  if (ppmmin(jregion) .ge. ppmsep(jsep_right)   .and.
     1                ppmmax(jregion + 1) .le. ppmsep(jsep_right))
     2               go to 320
 310           continue
 320           continue
            end if
            if (jregion .le. 1) then
               jsep_left = 0
            else
               do 330 jsep_left = 1, nsep
                  if (ppmmin(jregion - 1) .gt. ppmsep(jsep_left)   .and.
     1                ppmmax(jregion) .lt. ppmsep(jsep_left)) go to 340
 330           continue
 340           continue
            end if
c            write (6, 9340) jregion, jsep_right, jsep_left,
c     1                      ppmmax(jregion), ppmmin(jregion)
c 9340       format ('JREGION =', i2, 5x, 'JSEP_RIGHT =', i2, 5x,
c     1              'JSEP_LEFT =', i2, 5x, 'PPMMAX =', 1pe9.2, 5x,
c     2              'PPMMIN =', e9.2)
            if (jsep_left .gt. jsep_right) then
               call merge_left(jregion, ppmmin, ppmmax, nregion)
            else if (jsep_right .gt. 0) then
               call merge_right(jregion, ppmmin, ppmmax, nregion)
            end if
            go to 280
 290     continue
 280  continue
c     -------------------------------------------------------------------------
c     Compute BACKGR & REGB for each region.  REGB will be block-diagonal,
c        with a block for each Region.
c     -DELPPM axis is used
c     X = -DELPPM = PPMCEN - PPM increases with JBACKG
c     -------------------------------------------------------------------------
      nbackg = 0
      do 410 jregion = 1, nregion
         nbackg_use = max0(nbckmn, 3 +
     1                nint((ppmmax(jregion) - ppmmin(jregion)) / delta))
         nbackg_start = nbackg + 1
         nbackg_end = nbackg + nbackg_use
         delta_use = (ppmmax(jregion) - ppmmin(jregion)) /
     1               float(nbackg_use - 3)
         xknot = ppmcen - ppmmax(jregion) - 2. * delta_use
         DO 420 JBACKG=1,NBACKG_use
            nbackg = nbackg + 1
c           -------------------------------------------------------------------
c           This should have been avoided with SETUP 2
c           -------------------------------------------------------------------
            IF (NBACKG .gt. mbackg) CALL ERRMES (4, 5, CHSUBP)
            XKNOT=XKNOT+DELTA_USE
c            XMIN=amax1(XKNOT, ppmcen - ppmmax(jregion)) - 2. * delta_use
            XMIN=XKNOT - 2. * delta_use
c            XMAX=amin1(XKNOT+2.*DELTA_USE,
c     1                 ppmcen - ppmmin(jregion) + delta)
            XMAX=XKNOT+2.*DELTA_USE
            XPPM_KNOT=PPMCEN-XKNOT
            NONNEG(NMETAB+NBACKG)=XPPM_KNOT.LE.PPMPOS(1) .AND.
     1                            XPPM_KNOT.GE.PPMPOS(2)
            DO 430 JY=1,NY
               X=-DELPPM(JY)
               xppm = delppm(jy) + ppmcen
c              ----------------------------------------------------------------
c              This baseline is exclusively for PPM(JY) in this region.
c              PPM & knots only coincide exactly for PPMST & PPMEND.
c                 Tolerances below are mainly for these 2 cases.
c              ----------------------------------------------------------------
               if (xppm .gt. ppmmax(jregion) + .001*delta_use   .or.
     1             xppm .lt. ppmmin(jregion) - .001*delta_use) go to 430
               IF (X .LE. XMIN) GO TO 430
               IF (X .GE. XMAX) GO TO 420
               BACKGR(JY,NBACKG)=(DIM(X,XMIN)**3 -
     1                            4.*DIM(X,XMIN+DELTA_USE)**3 +
     2                            6.*DIM(X,XKNOT)**3 -
     3                            4.*DIM(X,XMAX-DELTA_USE)**3 +
     4                            DIM(X,XMAX)**3) * FNORM
 430        CONTINUE
 420     CONTINUE
         if (ldump(2)) then
            write (6, 5420) jregion
 5420       format (/'Region =', i2)
            write (6,5241) (ppmmax(j), ppmmin(j), j=1,nregion)
            write (6,5422) nbackg_use, delta_use, delta_use/delta
 5422       format ('NBACKG_USE =', i3/ 'DELTA_USE =', 1pe11.4/
     1              'delta ratio =', e11.4)
         end if
C        ----------------------------------------------------------------------
C        Compute regularizor for cubic B-splines with equally spaced knots and
C           no boundary conditions.
C        For simplicity, no use is made of the banded structure; the full
C           matrices are used with many 0 elements.
c        Fill upper triangle of REGB was zeroed above (DO 130).
C        NBACKG_use >= 6 was imposed above.
C        ----------------------------------------------------------------------
         DO 440 IROW=nbackg_start, NBACKG_end
            REGB(IROW,IROW)=16.
            IF (IROW+1 .LE. NBACKG_end) REGB(IROW,IROW+1)=-9.
            IF (IROW+3 .LE. NBACKG_end) REGB(IROW,IROW+3)=1.
 440     CONTINUE
         REGB(nbackg_start,nbackg_start)=2.
         REGB(NBACKG_END, NBACKG_END)=2.
         REGB(nbackg_start, nbackg_start + 1)=-3.
         REGB(NBACKG_END-1, NBACKG_END)=-3.
         REGB(nbackg_start + 1, nbackg_start + 1)=8.
         REGB(NBACKG_END-1,NBACKG_END-1)=8.
         REGB(nbackg_start + 1, nbackg_start + 2)=-6.
         REGB(NBACKG_END-2, NBACKG_END-1)=-6.
         REGB(nbackg_start + 2, nbackg_start + 2)=14.
         REGB(NBACKG_END-2, NBACKG_END-2)=14.
         DO 450 IROW=nbackg_start,NBACKG_END
            DO 460 ICOL=IROW+1,NBACKG_END
               REGB(ICOL,IROW)=REGB(IROW,ICOL)
 460        CONTINUE
 450     CONTINUE
 410  continue
      END
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE merge_right (lregion, ppmmin, ppmmax, nregion)
C
C  Assumes that lregion < nregion
c
      character chsubp*6
      real ppmmax(*), ppmmin(*)
      chsubp = 'MERGRT'
      if (lregion .ge. nregion) call errmes (1, 5, chsubp)
      nregion = nregion - 1
      ppmmin(lregion) = ppmmin(lregion + 1)
      do 110 jregion = lregion + 1, nregion
         ppmmax(jregion) = ppmmax(jregion + 1)
         ppmmin(jregion) = ppmmin(jregion + 1)
 110  continue
      end
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE merge_left (lregion, ppmmin, ppmmax, nregion)
C
C  Assumes that 1 < lregion
c
      character chsubp*6
      real ppmmax(*), ppmmin(*)
      chsubp = 'MERGLF'
      if (lregion .le. 1) call errmes (1, 5, chsubp)
      nregion = nregion - 1
      ppmmin(lregion - 1) = ppmmin(lregion)
      do 110 jregion = lregion, nregion
         ppmmax(jregion) = ppmmax(jregion + 1)
         ppmmin(jregion) = ppmmin(jregion + 1)
 110  continue
      end
c
c
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      subroutine check_chless ()
c
c .TRUE. if STARTV is to be repeated with all CHLESS omitted from Prel.
c The concentrations [SOLBES(JMETAB,2)] with all NACOMB containing the unique
c    prefixes CHLESS(JLESS) and CHMORE will be summed.
c    OMIT_CHLESS = [CONCEN corresponding to CHLESS(JLESS) exceeds that for
c                   RLESMO*CHMORE].
c    Then Prel will be repeated with all CHLESS components omitted.
c Typically, CHLESS='L09' 'L20' and CHMORE='L13' to avoid Lip09 replacing
c    Lip13 in Prel.
c RLESMO: OMIT_CHLESS=T if CONC_LESS(JLESS) / CONC_MORE > RLESMO (default 0
c         will set OMIT_CHLESS=F).
c NCHLES > 0 to allow OMIT_CHLESS
c
      INCLUDE 'lcmodel.inc'
      external ilen
      integer lless(mmetab)
      real conc_less(mmetab)
      chsubp = 'LESSMO'
      omit_chless = .false.
      if (chmore .eq. ' '   .or.  rlesmo .le. 0.   .or.
     1    nchles .le. 0) return
      if (nchles .gt. mmetab) call errmes (1, 4, chsubp)
      do 110 jless = 1, nchles
         if (chless(jless) .eq. ' ')  return
         if (chless(jless) .eq. chmore) then
            call errmes (2, 3, chsubp)
            return
         end if
         conc_less(jless) =-1.
         lless(jless) = ilen(chless(jless))
 110  continue
      conc_more = -1.
      lmore = ilen(chmore)
      lnot1 = nnot1
      do 210 jmetab = 1, nmetab
         do 220 jless = 1, nchles
            if (index(nacomb(jmetab), chless(jless)(:lless(jless)))
     1          .eq. 1) then
               conc_less(jless) = amax1(0., conc_less(jless)) +
     1                            solbes(jmetab, 2)
               lnot1 = lnot1 + 1
               if (lnot1 .gt. mmetab_extra) then
                  call errmes (3, 3, chsubp)
                  return
               end if
               chnot1(lnot1) = nacomb(jmetab)
            end if
 220     continue
         if (index(nacomb(jmetab), chmore(:lmore)) .eq. 1)
     1      conc_more = amax1(0., conc_more) + solbes(jmetab, 2)
 210  continue
      do 310 jless = 1, nchles
         if (conc_less(jless) .gt. 0.) go to 320
 310  continue
      return
 320  do 350 jless = 1, nchles
         if (conc_less(jless) .ge. conc_more * rlesmo) go to 400
 350  continue
      return
 400  omit_chless = .true.
      call errmes (4, 1, chsubp)
      nnot1 = lnot1
      end
c
c
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE TWOReg ()
C
C  Find best unconstrained solution.
c  If unusual conditions occur, do a series of NDEGPPM3 analyses with fixed
c     DEGPPM.
c  IDGPPM = -1 (default) to not do any DEGPPM-fixed analyses, only standard
c              free analysis.
c            0 (default in lipid-2 & PPMST<5) for analyses stressing flat
c              baselines (by allowing medium SSQ/SSQMIN), where there is no
c              small peak that can be lost by incorrect DEGPPM.  This can
c              also be used to input any values for RBASMX & RSDGP3; only
c              differences between IDGPPM=0 & >0 are settings in MYCONT.
c            1 (default in breast-2, only-cho-1 & liver-2) for analyses
c              stressing good phasing and fit (at expense flat baselines),
c              to find small peaks (like Cho).  Forces fixed-DEGPPM series,
c              even if baseline in unconstrained solution is flat.
c            2 (default in muscle-2) (actually between 0 and 1) stresses
c              good fit, but does not force fixed-DEGPPM series if
c              unconstrained solution is flat.
c  To switch on DEGPPM-analyses, only need to input IDGPPM>=0 (and check
c     RBASMX)
c
      INCLUDE 'lcmodel.inc'
      external r_base_sol_big
      logical big_base_free(2), lterm, r_base_sol_big
      CHSUBP='TWOREG'
c     -----------------------------------------------------------------------
c     NDEGPPM3_USED = 0 for free analysis.
c     -----------------------------------------------------------------------
      ndegppm3_used = 0
      call tworg2 (0, .false.)
      degppm_free = (phitot(2) + parbes(lphast + 1, 2)) / radian
      big_base_free(1) = r_base_sol_big(1)
      big_base_free(2) = r_base_sol_big(2)
      lterm = degppm_free .lt. dgppmn   .or.   degppm_free .gt. dgppmx
     1        .or.   big_base_free(1)
c     ------------------------------------------------------------------------
c     If there are no unusual conditions or IDGPPM=-1, return and skip
c        series with fixed DEGPPM.
c     ------------------------------------------------------------------------
      if (fxdegp   .or.   .not.lterm   .or.   idgppm .lt. 0) return
      call errmes (12, 1, chsubp)
      call tworeg_sav ()
      degp_degp(0) = degppm_free
      if (ddegp3 .le. 0.   .or.   mdegp3 .le. 2)
     1   call errmes (13, 4, chsubp)
c     ------------------------------------------------------------------------
c     It is necessary to start from near DEGPPM of the free DEGPPM analysis,
c        even if that is outside range of DGPPM*.
c     ------------------------------------------------------------------------
      dgppmn_use = amin1(degppm_free, dgppmn)
      dgppmx_use = amax1(degppm_free, dgppmx)
      if (degppm_free .lt. dgppmn   .or.   degppm_free .gt. dgppmx)
     1   call errmes (16, 1, chsubp)
      ndegppm3 = nint((dgppmx_use - dgppmn_use) / ddegp3)
      if (ndegppm3 .gt. mdegp3) then
         call errmes (14, 2, chsubp)
         ndegppm3 = mdegp3
      end if
      ddegp3_use = (dgppmx_use - dgppmn_use) / float(ndegppm3)
      degzer_free = (phitot(1) + parbes(lphast, 2)) / radian
      exdegp_orig = exdegp
      sddegp_orig = sddegp
c     -----------------------------------------------------------------------
c     Start with DEGPPM of previous unconstrained analysis (not EXDEGP)
c     -----------------------------------------------------------------------
      exdegp = degppm_free
      sddegp = 0.
      fxdegp = .true.
      ssqbes_degp = rrange
      do 110 jdgppm = 1, ndegppm3
         exdegp = exdegp + ddegp3_use
c        ---------------------------------------------------------------------
c        6*SD used (instead of original 4) in the two statements below
c        to allow for prostate with SDDEGP=30 & DGPPM*=30-150
c        ---------------------------------------------------------------------
         IF (ABS(exdegp-exdegp_orig).GT.6.*sddegp_orig) GO TO 110
         if (exdegp .gt. dgppmx_use + .5 * ddegp3_use) go to 200
         ndegppm3_used = ndegppm3_used + 1
         call tworg1 ()
 110  continue
c     ------------------------------------------------------------------------
c     Start decreasing DEGPPM from DEGPPM & DEGZER of solution with free
c        DEGPPM
c     ------------------------------------------------------------------------
 200  parbes(lphast, 2) = degzer_free * radian - phitot(1)
      call rephas()
      exdegp = degppm_free
      do 210 jdgppm = 1, ndegppm3
         exdegp = exdegp - ddegp3_use
          IF (ABS(exdegp-exdegp_orig).GT.6.*sddegp_orig) GO TO 210
         if (exdegp .lt. dgppmn_use - .5 * ddegp3_use) go to 300
         ndegppm3_used = ndegppm3_used + 1
         call tworg1 ()
 210  continue
c     ------------------------------------------------------------------------
c     Regenerate solution with minimum SSQ
c     SSQBES(7) is from initial analysis with free DEGPPM
c     SSQBES(4) is from min-SSQ DEGPPM-constrained
c     ------------------------------------------------------------------------
 300  if (ndegppm3_used .le. 0) go to 700
      if (ssqbes(7) .le. ssqbes(4)   .and.
     1    .not.big_base_free(2)) then
         call errmes (17, 1, chsubp)
         call savbes(-7)
      else
c        ---------------------------------------------------------------------
c        Select min-SSQ solution if it has R_BASE_SOL_BIG(2) = F.
C        No! Comment this out.  Always look for smaller spline distance.
c        ---------------------------------------------------------------------
         call savbes(-4)
c         if (r_base_sol_big(2)) then
c           ------------------------------------------------------------------
c           Try to find solution with the min spline distance that has an
c              SSQ < (min SSQ) * RSDGP3
c           RSDGP3 < 1. will force the above min-SSQ solution to be used,
c              even though its R_BASE_SOL_BIG(2) = T
c           RSDGP3 very large will force min spline distance solution, even
c              if its SSQ is very high.
c           ------------------------------------------------------------------
            bound = ssqbes(4) * rsdgp3
            distmn = rrange
            ldistmn = -1
            do 350 j = 0, ndegppm3_used
               if (ssq_degp(j) .lt. bound) then
                  if (dist_degp(j) .le. distmn) then
                     distmn = dist_degp(j)
                     ldistmn = j
                  end if
               end if
 350        continue
            if (ldistmn .ge. 0) call savbes(-ldistmn - 7)
c         end if
      end if
c     ------------------------------------------------------------------------
c     These have to be restored, for use in FINOUT.  This may not be optimal
c        for SOLVE in FINOUT, but removing these produced identical solution
c        & error estimates.
c     ------------------------------------------------------------------------
 700  exdegp = exdegp_orig
      fxdegp = .false.
      sddegp = sddegp_orig
      end
c
c
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE tworg1 ()
c
c  Find best solution for a fixed DEGPPM
c
      INCLUDE 'lcmodel.inc'
      CHSUBP='TWOREG'
      degp_degp(ndegppm3_used) = exdegp
      IF (LPRINT .GT. 0) WRITE (LPRINT,5110) exdegp
 5110 FORMAT (////25x, 'Analysis with fixed DEGPPM =', f8.2)
      parbes(lphast + 1, 2) = exdegp * radian - phitot(2)
      call rephas()
      call tworg2(ndegppm3_used, .true.)
      call tworeg_sav ()
      end
c
c
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE tworeg_sav ()
c
c  Save current solution, which is in *(ndegppm3_used) and compute baseline
c  criteria.
c
      INCLUDE 'lcmodel.inc'
      call savbes (ndegppm3_used + 7)
      ssq_degp(ndegppm3_used) = ssqbes(2)
      alpb_degp(ndegppm3_used) = alpbbs(2)
      dist_degp(ndegppm3_used) = 0.
      do 120 j = nmetab + 1, nmetab + nbackg - 1
         dist_degp(ndegppm3_used) = dist_degp(ndegppm3_used) +
     1                       dabs(solbes(j, 2) - solbes(j + 1, 2))
 120  continue
      if (ssq_degp(ndegppm3_used) .le. ssqbes_degp) then
         ssqbes_degp = ssq_degp(ndegppm3_used)
         call savbes(4)
      end if
      end
c
c
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE tworg2 (jpass, fixed_degppm_series)
C
C  Call TWORG3 to find ALPHAB and ALPHAS so that PRMNMX(1,1)<PROB1<PRMNMX(2,1).
c  ENDPHA = T to do fixed-phase analysis after analysis for ALPHAB & ALPHAS
c             (previously the final analysis)
c  USEMXB = T choose final solution with the largest ALPHAB
c  USEMXB=F was not tested (assuming that it will never be used).
C
      INCLUDE 'lcmodel.inc'
      external ldegmx
      double precision parbes_phase_sav(2)
      LOGICAL fixed_degppm_series, fixed_phase,
     1        fxdegp_orig, fxdegz_orig, LDEGMX,
     1        ldegmx_sav, PREJOK, usesol
      CHSUBP='TWOREG'
C     -------------------------------------------------------------------------
C     Repeated calls to SETUP produce slightly slower execution and more
c        PNNLS.
c     Repeated calls to "Preliminary full..." below speed up the analysis.
C     -------------------------------------------------------------------------
      if (jpass .le. 0) then
         CALL SETUP (2)
C        ----------------------------------------------------------------------
C        When doing a series of fixed DEGPPM, rephasing has already set the
c           following to zero, but SETUP sets them.  Set them back to zero.
C        ----------------------------------------------------------------------
         if (fixed_degppm_series) then
            parnln(lphast) = 0.d0
            parnln(lphast + 1) = 0.d0
            parbes(lphast, 2) = 0.d0
            parbes(lphast + 1, 2) = 0.d0
         end if
      end if
C     -------------------------------------------------------------------------
C     Get Starting Solution with ALPBST and ALPSST.
C     -------------------------------------------------------------------------
 5240 FORMAT (////20X, 'Preliminary full analysis with alphaB =',
     1                 1PE9.2E2, ' and alphaS =', E9.2E2)
      IF (LPRINT .GT. 0) WRITE (LPRINT,5240) ALPHAB, ALPHAS
      if (imethd .eq. 1   .and.   nratio .le. 0) miter(2) = 2 * miter(2)
      CALL PLINLS (2, IERROR)
      IF (DMAX1(OBJECT,SDREF) .GE. DRANGE) CALL ERRMES (1, 4, CHSUBP)
      CALL SAVBES (1)
      CALL SAVBES (2)
c     -------------------------------------------------------------------------
c     Special quick exit, e.g., for huge Roche-2 analyses, where above values
c       of ALPHA* can be used as final values, and where huge NY makes FSHSSQ
c       inaccurate and PRMNMX much too narrow (because of so much baseline and
c       few data in sharp peaks).
c     -------------------------------------------------------------------------
      if (imethd .eq. 1) then
         NINFL(1)=INFLEC (PARBES(1,1), NSIDE2, DPY, DGAUSS, THRLIN,
     1                    imethd)
         NEXTR(1)=NEXTRE (PARBES(1,1), NSIDE2, DPY, DGAUSS, THRLIN,
     1                    imethd)
         if (nratio .gt. 0) then
            call conc_prior ()
            if (nratio_used .gt. 0) then
               if (ninfl(1) .gt. 2) alphas = alphas * rdalpb**2
               CALL PLINLS (2, IERROR)
               if (object .lt. drange) then
                  CALL SAVBES (1)
                  CALL SAVBES (2)
                  NINFL(2)=INFLEC (PARBES(1,1), NSIDE2, DPY, DGAUSS,
     1                             THRLIN, imethd)
                  NEXTR(2)=NEXTRE (PARBES(1,1), NSIDE2, DPY, DGAUSS,
     1                             THRLIN, imethd)
               end if
            end if
         end if
         do 210 jrepha = 2, mrepha(1)
            IF (.NOT.LDEGMX(1)) go to 800
            parbes(lphast, 2) = parbes(lphast, 2) * frepha
            parbes(lphast + 1, 2) = parbes(lphast + 1, 2) * frepha
            call rephas()
            CALL ERRMES (8, 1, CHSUBP)
            CALL PLINLS (2, IERROR)
            if (object .lt. drange) then
               CALL SAVBES (1)
               CALL SAVBES (2)
               NINFL(2)=INFLEC (PARBES(1,1), NSIDE2, DPY, DGAUSS,
     1                          THRLIN, imethd)
               NEXTR(2)=NEXTRE (PARBES(1,1), NSIDE2, DPY, DGAUSS,
     1                          THRLIN, imethd)
            end if
 210     continue
         IF (LDEGMX(1)) CALL ERRMES (18, 2, CHSUBP)
         go to 800
      end if
      IF (RDALPB.LE.1. .OR. ALPBST.LT.SNGL(.99999*ALPBMN) .OR.
     1    ALPBST.GT.SNGL(1.00001*ALPBMX)) CALL ERRMES (2, 4, CHSUBP)
C     -------------------------------------------------------------------------
C     There is no point in varying ALPHAS when NSIDES=1; the peak shape does
c        not change with ALPHAS.
C     -------------------------------------------------------------------------
      if (nsides .le. 1   .and.   imethd .ne. 2) mdalpb = 0
      if (nratio .gt. 0   .and.   jpass .le. 0) then
C        ----------------------------------------------------------------------
c        Set up CPRIOR, matrix for priors of concentration ratios, after doing
c          preliminary Reference Solution and then Regula Falsi search with
c          ALSBMN to get CONC estimates for weighting the priors.
C        ----------------------------------------------------------------------
         SSQAIM=0.
         PENBES(2)=DRANGE
         CALL RFALSI (1, 1, .TRUE., ALPBBS(2), ALPSMN, -1./RRANGE, 0.,
     1                RRANGE, RRANGE, 1., PREJOK, PREJ1)
         IF (PREJOK .OR. (ALPHAB.GE..99999*ALPBMX .AND. MDALPB.LE.0))
     1       CALL SAVBES (2)
         call conc_prior ()
      end if
      exdegz_orig = exdegz
      exdegp_orig = exdegp
      sddegz_orig = sddegz
      sddegp_orig = sddegp
      fxdegz_orig = fxdegz
      fxdegp_orig = fxdegp
      SSQAIM=0.
      alpbbs(3) = -1.
c     -----------------------------------------------------------------------
c     The following is just to avoid compile diagnostic about possible
c     undefined variable
      ldegmx_sav = .false.
c     -----------------------------------------------------------------------
      DO 310 JREPHA=1,MREPHA(1)
         call tworg3(iabs(jrepha))
         ldegmx_sav = ldegmx(1)
c        --------------------------------------------------------------------
c        Do "final" solution with fixed phases.
c        ENDPHA = F by default to avoid making "normal" analyses (including
c                   test run) from taking 50% longer.
c        --------------------------------------------------------------------
         parbes_phase_sav(1) = parbes(lphast, 2)
         parbes_phase_sav(2) = parbes(lphast + 1, 2)
         fixed_phase = (endpha   .and.
     1                  (.not.ldegmx_sav   .or.
     2                   jrepha . eq. mrepha(1)))   .or.
     3                 (ldegmx_sav   .and.   jrepha . eq. mrepha(1))
c     4                 .or.   idgppm .ge. 0
         if (fixed_phase) then
            if (lprint .gt. 0) write(lprint, 5380)
 5380       format(//20x,
     1             'Repeat analysis with fixed phases from above')
            call rephas ()
            exdegz = phitot(1) / radian
            exdegp = phitot(2) / radian
            sddegz = 0.
            sddegp = 0.
            fxdegz = .true.
            fxdegp = .true.
            call tworg3(iabs(jrepha))
            exdegz= exdegz_orig
            exdegp= exdegp_orig
            sddegz= sddegz_orig
            sddegp= sddegp_orig
            fxdegz= fxdegz_orig
            fxdegp= fxdegp_orig
         end if
c        --------------------------------------------------------------------
c        Save solution with the max ALPHAB with SAVBES(3)
c        --------------------------------------------------------------------
         if (usemxb   .and.   alpbbs(2) .ge. alpbbs(3)) call savbes(3)
         if (.not.ldegmx_sav) go to 700
         if (jrepha .lt. mrepha(1)) then
c           ------------------------------------------------------------------
c           This will reduce the rephasing corrections by a factor of FREPHA.
c           Version 6.0-2C and before use FREPHA=1.
c           A reasonable value would be 0.5, which will hopefully avoid the
c             oscillations between two extreme phase sets that occurred in
c             previous versions.
c           ------------------------------------------------------------------
            if (.not.fixed_phase) then
               parbes(lphast, 2) = parbes_phase_sav(1) * frepha
               parbes(lphast + 1, 2) = parbes_phase_sav(2) * frepha
            end if
         end if
         CALL ERRMES (8, 1, CHSUBP)
 310  continue
      CALL ERRMES (9, 1, CHSUBP)
c     ------------------------------------------------------------------------
c     Regenerate solution with the max ALPHAB, if no stable phases have been
c     found.
c     ------------------------------------------------------------------------
 700  if (usemxb   .and.  ldegmx_sav) call savbes(-3)
  800 RETURN
      END
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      subroutine tworg3(jrepha)
c
C  Find ALPHAB and ALPHAS so that PRMNMX(1,1)<PROB1<PRMNMX(2,1).
c  Shares CALL ERRMES numbers with TWOREG.
C
      INCLUDE 'lcmodel.inc'
      LOGICAL PREJOK, usesol

      chsubp='TWOREG'
      DO 312 J=1,2
         NEXTR(J)=0
         NINFL(J)=-1
 312  CONTINUE
      PENBES(2)=DRANGE
      CALL RFALSI (1, 1, .TRUE., ALPbbs(2), ALPSMN, -1./RRANGE, 0.,
     1             RRANGE, RRANGE, 1., PREJOK, PREJ1)
      if (mdalpb .le. 0   .and.  daimbs .lt. rrange) then
         usesol = prejok   .or.   ALPHAB.GE..99999*ALPBMX
         if (.not.usesol   .and.   useany) call errmes (10, 2, chsubp)
         IF (usesol .OR.   useany) THEN
            CALL SAVBES (2)
            NINFL(1)=INFLEC (PARBES(1,1), NSIDE2, DPY, DGAUSS, THRLIN,
     1                       imethd)
            NEXTR(1)=NEXTRE (PARBES(1,1), NSIDE2, DPY, DGAUSS, THRLIN,
     1                       imethd)
         END IF
      end if
      DO 320 JDALPB=1,MDALPB
         IF (LPRINT .GT. 0) WRITE (LPRINT,5320) JREPHA, JDALPB
 5320    FORMAT (//////10X, 'Phase Pair', I2, 5X, 'Decrease', I2,
     1           ' of alphaB/alphaS')
         CALL RFALSI (3, 1, .FALSE., ALPBBS(1)/RDALPB,
     1                ALPSBS(1)*RDALPB, SSQREF, 0., RRANGE, RRANGE,
     2                1., PREJOK, PREJ1)
         IF (PREJOK) THEN
            IF (PENBES(1) .LT. PENBES(2)) THEN
               CALL SAVBES(2)
               NINFL(1)=INFLEC (PARBES(1,1), NSIDE2, DPY, DGAUSS,
     1                          THRLIN, imethd)
               NEXTR(1)=NEXTRE (PARBES(1,1), NSIDE2, DPY, DGAUSS,
     1                          THRLIN, imethd)
            ELSE IF (PENBES(1) .GE. RPENMX*PENBES(2)) THEN
               GO TO 330
            END IF
            IF (NEXTRE(PARBES(1,1), NSIDE2, DPY, DGAUSS, THRLIN, imethd)
     1          .LE. 1) GO TO 330
         END IF
         IF (ALPBBS(1).LE.ALPBMN .OR. ALPSBS(1).GE.ALPSMX) GO TO 330
 320  CONTINUE
      IF (MDALPB .GT. 0) CALL ERRMES (3, 2, CHSUBP)
 330  IF (PENBES(2) .GE. DRANGE) CALL ERRMES (4, 4, CHSUBP)
      IF (MDALPB.LE.0 .OR. USINFL) THEN
         ITEST=NINFL(1)-2
      ELSE
         ITEST=NEXTR(1)-1
      END IF
      IF (ITEST.GT.0 .AND. ALPBBS(2).GT.ALPBMN .AND.
     1    .NOT.VITRO  .AND.   ALPSBS(2).LT.ALPSMX) THEN
         IF (LPRINT .GT. 0) WRITE (LPRINT,5340)
 5340    FORMAT (//////20X, 'Step 2: Increase alphaS with fixed',
     1                 ' alphaB')
         IF (AMAX1(PRMNMX(2,1),PRMNMX(2,3)) .GT. PRMNMX(1,2)) CALL
     1         ERRMES (5, 4, CHSUBP)
         CALL SSRANG (2)
         DO 340 JNONL=1,NNONL
            PARNLN(JNONL)=PARBES(JNONL,2)
 340     CONTINUE
         CALL RFALSI (2, 2, .FALSE., ALPBBS(2), ALPSBS(2),
     1      SSQBES(2), 1., RRANGE, RRANGE, RALINC, PREJOK, PREJ1)
         IF (.NOT.PREJOK) THEN
            CALL ERRMES (6, 2, CHSUBP)
            GO TO 800
         END IF
         if (skip_step3) then
            call savbes(2)
            NINFL(2)=INFLEC (PARBES(1,1), NSIDE2, DPY, DGAUSS,
     1                       THRLIN, imethd)
            NEXTR(2)=NEXTRE (PARBES(1,1), NSIDE2, DPY, DGAUSS,
     1                       THRLIN, imethd)
            go to 800
         end if
         if (imethd .eq. 2   .and.   accept_step2) call savbes(2)
         IF (MDALPB.LE.0 .OR. USINFL) THEN
            ITEST=INFLEC (PARBES(1,1), NSIDE2, DPY, DGAUSS, THRLIN,
     1                    imethd)-2
         ELSE
            ITEST=NEXTRE (PARBES(1,1), NSIDE2, DPY, DGAUSS, THRLIN,
     1                    imethd)-1
         END IF
         IF (ITEST .LE. 0) THEN
C           -------------------------------------------------------------------
C           Test for special exit from Step 2 with 2-inflection-point or
C              unimodal lineshape and PREJ1<PRMNMX(2,3).
C           -------------------------------------------------------------------
            IF (PREJ1 .GT. PRMNMX(2,3)) THEN
               IF (LPRINT .GT. 0) WRITE (LPRINT,5350)
 5350          FORMAT (//////20X, 'Step 3A: Decrease alphaB and ',
     1                       'alphaS')
               CALL SSRANG (3)
               CALL RFALSI (3, 3, .FALSE., ALPBBS(2), ALPSBS(1),
     1                      SSQREF, 0., SSQBES(1), 1., 1./RALINC,
     2                      PREJOK, PREJ1)
            END IF
         ELSE
            IF (LPRINT .GT. 0) WRITE (LPRINT,5360)
 5360       FORMAT (//////20X, 'Step 3B: Decrease alphaB with ',
     1                    'fixed alphaS')
            CALL SSRANG (3)
            CALL RFALSI (1, 3, .FALSE., ALPBBS(2), ALPSBS(1),
     1                   -1./RRANGE, 0., SSQBES(1), 1., 1./RALINC,
     2                   PREJOK, PREJ1)
c           ------------------------------------------------------------------
c           When IMETHD=2, use ALPBMN in Step 3, even if PREJ is not down to
c              PRMNMX(2,3) to avoid using results of Step 1.
c           ------------------------------------------------------------------
            if (imethd .eq. 2   .and.   accept_alpbmn   .and.
     1          is_alpbmn) then
               call savbes(1)
               prejok = .true.
            end if
         END IF
         IF (PREJOK) THEN
            NEXTR_test=NEXTRE (PARBES(1,1), NSIDE2, DPY, DGAUSS,
     1                         THRLIN, imethd)
            NINFL_test=INFLEC (PARBES(1,1), NSIDE2, DPY, DGAUSS,
     1                         THRLIN, imethd)
            if (ninfl_test .ge. ninfl(1)  .and.
     1          nextr_test .ge. nextr(1)   .and.   imethd .ne. 2) then
               IF (LPRINT .GT. 0) WRITE (LPRINT,5370)
 5370          FORMAT (//////' Steps 2 and 3 did not decrease ',
     1              'the no. of inflections or extrema; ',
     2              'they will not be used.'//)
               GO TO 800
            END IF
            CALL SAVBES (2)
            NINFL(2)=ninfl_test
            NEXTR(2)=NEXTR_test
         ELSE
            CALL ERRMES (7, 1, CHSUBP)
         END IF
      END IF
 800  return
      end
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      logical function r_base_sol_big(istage)
c
c ISTAGE = 1 for testing free solution.
c          2 for testing min-SSQ solution from fixed-DEGPPM series.
c .TRUE. if the ratio of the height difference in the baseline to the height
c    difference in the solution > RBASMX(ISTAGE)
c Uses the values currently in *BES(2).
c
      INCLUDE 'lcmodel.inc'
      logical lerror
      chsubp = 'RBASOL'
c     ------------------------------------------------------------------------
c     Statements down thru 165 (except SAVBES) are from FINOUT.  Skipping
c        the 1st call to SOLVE below caused a FATAL
c     ------------------------------------------------------------------------
      call savbes(6)
      DO 150 JPAR=1,NLIN
         SOLUTN(JPAR)=SOLBES(JPAR,2)
c         NONNEG(JPAR)=SOLUTN(JPAR) .EQ. 0.D0
  150 CONTINUE
      DO 160 JNONL=1,NNONL
         PARNLN(JNONL)=PARBES(JNONL,2)
  160 CONTINUE
      ALPHAB=ALPBBS(2)
      ALPHAS=ALPSBS(2)
      CALL SOLVE (2, .TRUE., PMQBES(2), .FALSE., LERROR)
      IF (LERROR) CALL ERRMES (1, 4, CHSUBP)
C     -------------------------------------------------------------------------
C     Now call SOLVE to get the following:
C     YFITRE(JY,0) = fit
C     BACKRE(JY) = background
C     -------------------------------------------------------------------------
      DO 165 JPAR=1,NLIN
         SOLUTN(JPAR)=SOLBES(JPAR,2)
  165 CONTINUE
      CALL SOLVE (2, .FALSE., 0.D0, .TRUE., LERROR)
      IF (LERROR) CALL ERRMES (2, 4, CHSUBP)
      call savbes(-6)
      solmax = -rrange
      basmin = rrange
      basmax = -rrange
      lmax = 0
      lmin = 0
      do 210 j = 1, nyuse
         solmax = amax1(solmax, abs(yfitre(j, 0) - backre(j)))
         if (backre(j) .le. basmin) then
            basmin = backre(j)
            lmin = j
         end if
         if (backre(j) .ge. basmax) then
            basmax = backre(j)
            lmax = j
         end if
 210  continue
c     ------------------------------------------------------------------------
c     Count distances from both (1) & (nyuse) to any internal extremum.  This
c        properly counts extra distance to a bowed baseline.
c     ------------------------------------------------------------------------
c      base_dist = 0.
c      if (lmin .ne. 1   .and.   lmin .ne. nyuse)
c     1   base_dist = abs(backre(1) - basmin) +
c     2               abs(backre(nyuse) - basmin)
c      if (lmax .ne. 1   .and.   lmax .ne. nyuse)
c     1   base_dist = base_dist + abs(backre(1) - basmax) +
c     2                           abs(backre(nyuse) - basmax)
c      if (base_dist .eq. 0.) base_dist = basmax - basmin
      base_dist = basmax - basmin
      if (solmax .le. 0.) then
         call errmes (3, 2, chsubp)
         r_base_sol_big = .true.
      else
         r_base_sol_big = base_dist / solmax .gt. rbasmx(istage)
 9210    format ('base_dist =', 1pe11.3, 3x, 'solmax =', e11.3, 3x,
     1           'ratio =',  e11.3, 3x, 'ratio limit =', e11.3/)
         if (lprint .gt. 0) write (lprint, 9210) base_dist, solmax,
     1                         base_dist / solmax, rbasmx(istage)
      end if
      end
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      subroutine conc_prior()
c
c     Make CPRIOR, the matrix of priors for the CONC ratios in CHRATI.
c     CHRATI must contain exactly one Metabolite Name in the numerator,
c followed by a slash, follwed by a CONC sum (with no whitespace).
c     CHRATW can contain a further CONC sum.  These will not go into the
c constraint, but will be used to compute CSUM, for the weights.  For example,
c might have CHRATW='Lip09' when the denominator in CHRATI is MM09, which is
c very difficult to resolve from Lip09.
c     In many cases, a prior will simply be skipped if an error condition is
c found.
c
c     The prior is
c c_num / c_sum = exrati +- sdrati
c c_num - c_sum * exrati = 0 +- c_sum * sdrati
c where c_num is a single metabolite;
c       c_sum can be a sum of several metabolites.
c       For weighting, c_sum is estimated from the CONC values of the
c         Preliminary Full Analysis with ALP*ST.
c         CHRATW can contain further metabolites added to c_sum for weighting.
c
      INCLUDE 'lcmodel.inc'
      character chterm*(mchmet)
      logical denom_absent
      CHSUBP='CONCPR'
c     -------------------------------------------------------------------------
c     NRATIO = input number of priors
c     NRATIO_USED = actual number of priors that will be used.
c     -------------------------------------------------------------------------
      if (nratio .gt. mmetab) call ERRMES (1, 4, CHSUBP)
      call parse_prior ()
      nratio_used = 0
      do 110 jratio = 1, nratio
c        ----------------------------------------------------------------------
c        Increment NRATIO_USED as though this try will be accepted.
c           NRATIO_USED will have to be decremented at 300 if this try is not
c           accepted.
c        ----------------------------------------------------------------------
         nratio_used = nratio_used + 1
         do 120 j = 1, mmetab
            cprior(nratio_used, j) = 0.
 120     continue
         islash = index(chrati(jratio), '/')
         if (islash .le. 1) then
            IF (LPRINT .GT. 0) WRITE (LPRINT,5120) CHrati(jratio)
 5120       FORMAT (' Missing slash in the ratio in CHRATO: ',A)
            call errmes (2, 4, chsubp)
         end if
c        ----------------------------------------------------------------------
c        Parse numerator, which must have exactly one Metabolite Name.
c        ----------------------------------------------------------------------
         LENGTH=islash - 1
         IF (LENGTH .GT. MCHMET) THEN
            IF (LPRINT .GT. 0) WRITE (LPRINT,5130) CHrati(jratio)
 5130       FORMAT (' Incorrect numerator in CHRATI =',A)
            CALL ERRMES (3, 4, CHSUBP)
         END IF
         chterm = chrati(jratio)(1:length)
         do 125 jomit = 1, nnorat
            if (chterm .eq. norato(jomit)) go to 300
 125     continue
         do 130 jmetab = 1, nmetab
            if (chterm .eq. nacomb(jmetab)) then
               if (exrati(jratio) .lt. 0.   .or.
     1             sdrati(jratio) .le. 0.) call ERRMES (4, 4, CHSUBP)
               lmetab_prior(nratio_used) = jmetab
               cprior(nratio_used, jmetab) = 1.
               go to 150
            end if
 130     continue
         go to 300
c        ----------------------------------------------------------------------
c        Parse denominator.
c        ----------------------------------------------------------------------
 150     csum = 0.
         denom_absent = .true.
         call parse_sum(exrati(jratio), chrati(jratio)(islash+1:),
     1                  mchratio - islash, nratio_used, csum,
     2                  denom_absent)
c        ----------------------------------------------------------------------
c        Parse CHRATW for extra metabolites to be included for weighting.
c        ----------------------------------------------------------------------
         call parse_sum(0., chratw(jratio), mchratio, nratio_used, csum,
     1                  denom_absent)
c        ----------------------------------------------------------------------
c        Skip prior if metabolites in denominator & weight terms are not in
c          analysis.
c        ----------------------------------------------------------------------
         if (denom_absent) go to 300
         if (csum .le. 0.) then
c           -------------------------------------------------------------------
c           CSUM from denominator was 0.  Use sum over all CONCs times a small
c             factor to produce a weight, which is all that CSUM affects.
c             CSUM = 0 implies that the numerator CONC should also be zero.
c             Therefore, the weight should be strong, and FCSUM small, e.g.,
c             FCSUM = 1.e-2 or 1.e-3
c           -------------------------------------------------------------------
            dterm(1) = 0.d0
            do 160 jmetab = 1, nmetab
               dterm(1) = dterm(1) + solbes(jmetab, 1)
 160        continue
            if (fcsum .le. 0.) call ERRMES (5, 4, CHSUBP)
            csum = fcsum * sngl(dterm(1))
c           -------------------------------------------------------------------
c           If all CONCs are 0, then skip this constraint
c           -------------------------------------------------------------------
            if (csum .eq. 0.) then
               call ERRMES (6, 2, CHSUBP)
               go to 300
            end if
         end if
         sqrtwt = 1. / (csum * sdrati(jratio))
         do 170 jmetab = 1, nmetab
            cprior(nratio_used, jmetab) = cprior(nratio_used, jmetab) *
     1                                    sqrtwt
 170     continue
c        ----------------------------------------------------------------------
c        Move *(JRATIO) down to *(NRATIO_USED) for later output.
c        ----------------------------------------------------------------------
         chrato(nratio_used) = chrato(jratio)
         exrati(nratio_used) = exrati(jratio)
         sdrati(nratio_used) = sdrati(jratio)
         sqrtwt_ratio_used(nratio_used) = sqrtwt
         go to 110
 300     nratio_used = nratio_used - 1
 110  continue
c     -------------------------------------------------------------------------
c     Dump prior matrix (if IPDUMP >= 3) or active CHRATO
c     -------------------------------------------------------------------------
      if (min0(nratio_used, lprint) .gt. 0) then
         if (ipdump .ge. 3) then
            write (lprint, 5210) (nacomb(j), j = 1, nmetab)
 5210       format (//20x, 'Prior matrix for concentration ratios'//
     1             (8x, (10(6x, a6))))
            do 210 jratio = 1, nratio_used
               write (lprint, 5220) nacomb(lmetab_prior(jratio)),
     1              (cprior(jratio, jmetab), jmetab = 1, nmetab)
 5220          format (/2x, a6, 1p10e12.3 / (8x, 1p10e12.3))
 210        continue
         else
            write (lprint, 5230) (chrato(jratio)(1:132),
     1                            chrato(jratio)(133:264),
     2                            jratio = 1, nratio_used)
 5230       format (//10x, 'CHRATO ratio priors used' // (a132))
         end if
      end if
      end
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      subroutine parse_prior ()
c
c     Parse CHRATO input strings into CHRATI, CHRATW, EXRATI & SDRATI.
c     CHRATO must be of form:
c CHRATI = EXRATI +- SDRATI +WT= CHRATW
c
      INCLUDE 'lcmodel.inc'
      external ilen
      character chreturn*(mchratio)
c
      chsubp = 'PPRIOR'
      do 210 jratio = 1, nratio
         len_chrato = ilen(chrato(jratio))
         istart = 1
         call get_field ('=', 1, 1, 0,
     1                   chrati(jratio), freturn,
     2                   istart, len_chrato, chrato(jratio))
         if (istart .le. 0) then
c           -------------------------------------------------------------------
c           This can be caused by an empty string; i.e., no input for CHRATO.
c           -------------------------------------------------------------------
            ierr = 0
            go to 800
         end if
         call get_field ('+-', 2, 2, 0,
     1                   chreturn, exrati(jratio),
     2                   istart, len_chrato, chrato(jratio))
         if (istart .le. 0) then
            ierr = 1
            go to 800
         end if
         call get_field ('+WT=', 4, 2, 1,
     1                   chreturn, sdrati(jratio),
     2                   istart, len_chrato, chrato(jratio))
         if (istart .gt. len_chrato) go to 210
         if (istart .lt. 0) then
            ierr = 2
            go to 800
         end if
         call get_field (' ', 0, 1, 2,
     1                   chratw(jratio), freturn,
     2                   istart, len_chrato, chrato(jratio))
         if (istart .le. 0) then
            ierr = 3
            go to 800
         end if
 210  continue
      return
 800  if (lprint .gt. 0) write (lprint, 5810)
     1     chrato(jratio)(1:132), chrato(jratio)(133:264), istart
 5810 format ('Incorrect CHRATO follows:', / a132 / a132 /
     1        'ISTART =', i3)
      call errmes (100*ierr + jratio, 4, chsubp)
      end
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      subroutine get_field (chseparator, len_chseparator, ifield_type,
     2                      iatend, chreturn, freturn,
     3                      istart, len_string_in, string_in)
c
c     Extracts field from STRING_IN into
c CHRETURN (if IFIELD_TYPE = 1)
C FRETURN  (if IFIELD_TYPE = 2)
c
c     STRING_IN, the string being searched is always a full string in the
c calling routine (e.g., CHRATO).  Substrings of it are explicitly defined
c here in GET_FIELD with ISTART, IEND_FIELD, etc.  This avoids possible
c compiler problems with substrings as actual arguments and INDEX.
c
      implicit none
      character chseparator*(*), chreturn*(*), chsubp*6, fmt*7,
     1          string_in*(*)
      integer i, iatend, iend_field, ifield_type, istart, istart_field,
     3        len_chseparator, len_string_in
      real freturn
c
      chsubp = 'GFIELD'
      iend_field = 0
c     -------------------------------------------------------------------------
c     Locate field in STRING_IN
c     -------------------------------------------------------------------------
      if (len_string_in .lt. istart) call errmes(1, 5, chsubp)
      if (iatend .eq. 0) then
c        ----------------------------------------------------------------------
c        CHSEPARATOR must be present.
c        ----------------------------------------------------------------------
         iend_field = index(string_in(istart:len_string_in),
     1                      chseparator(:len_chseparator)) - 2 + istart
         if (iend_field .lt. istart) then
c           -------------------------------------------------------------------
c           Error -- separator absent.
c           -------------------------------------------------------------------
            istart = -1
            return
         end if
      else if (iatend .eq. 1) then
c        ----------------------------------------------------------------------
c        CHSEPARATOR may be present, but the field may also be at the end.
c        ----------------------------------------------------------------------
         iend_field = index(string_in(istart:len_string_in),
     1                      chseparator(:len_chseparator)) - 2 + istart
         if (iend_field .lt. istart) iend_field = len_string_in
      else if (iatend .eq. 2) then
c        ----------------------------------------------------------------------
c        The field is at the end; CHSEPARATOR is not present.
c        ----------------------------------------------------------------------
         iend_field = len_string_in
      else
         call errmes(2, 5, chsubp)
      end if
c     -------------------------------------------------------------------------
c     Remove leading white space.
c     -------------------------------------------------------------------------
      do 210 istart_field = istart, iend_field
         if (string_in(istart_field:istart_field) .ne. ' ') go to 220
 210  continue
c     -------------------------------------------------------------------------
c     Error -- entire field is blank.
c     -------------------------------------------------------------------------
      istart = -2
      return
c     -------------------------------------------------------------------------
c     Increment ISTART (since IEND_FIELD is going to be changed below).
c     -------------------------------------------------------------------------
 220  istart = iend_field + len_chseparator + 1
c     -------------------------------------------------------------------------
c     Remove trailing white space.
c     -------------------------------------------------------------------------
      istart = iend_field + len_chseparator + 1
      i = iend_field
      do 230 iend_field = i, istart_field, -1
         if (string_in(iend_field:iend_field) .ne. ' ') go to 240
 230  continue
 240  if (ifield_type .eq. 1) then
         chreturn = string_in(istart_field:iend_field)
      else if (ifield_type .eq. 2) then
         i = iend_field - istart_field + 1
         if (i .le. 9) then
            write (fmt, 5240) i
 5240       format ('(f', i1, '.0)')
         else if (i .le. 99) then
            write (fmt, 5250) i
 5250       format ('(f', i2, '.0)')
         else
            istart = -3
            return
         end if
         read (string_in(istart_field:iend_field), fmt, err=810,
     1         end=810) freturn
      else
         istart = -4
         return
      end if
      return
 810  istart = -5
      end
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      subroutine parse_sum(exrati_arg, substring, len_substring,
     1                     lratio, csum, denom_absent)
c
c     Parse CHRATI or CHRATW, and compute (unweighted) CPRIOR elements and
c CSUM.  CPRIOR will have to be multiplied by the weight (1/SD*CSUM).
C     If no metabolites are present from the denominator, then CPRIOR will
c have all zeroes, except for the numerator, which will then have an
c expectation of zero.
c     If CSUM=0, then the original constraint with the denominator terms will
c hold, but the weight (presumably large) will have to be set in calling
c program.
c
      INCLUDE 'lcmodel.inc'
      character chterm*(mchmet), substring*(*)
      logical atend, denom_absent, wildcard
      CHSUBP='PARSUM'
      istart = 1
c      write (lprint, 9000) substring
c 9000 format (a)
      do 110 jterm = 1, mmet_ratio - 1
         LENGTH=INDEX(substring(ISTART:len_substring),'+')-1
c         write (lprint, 9110) length
c 9110    format (' length =', i3)
         ATEND=LENGTH .EQ. -1
         IF (ATEND) LENGTH=INDEX(substring(ISTART:len_substring),' ')-1
C        ----------------------------------------------------------------------
C        Blank in position 1 or right after last "+"
C        ----------------------------------------------------------------------
         IF (LENGTH .EQ. 0) return
c        ----------------------------------------------------------------------
c        CHRATI has (MCHMET+1)*mmet_ratio + 1.  Thus, there should
c          be room for at least one blank at the end, if <= MMET_RATIO
c          terms are used.  If not, abort (probably because there are
c          > MMET_RATIO terms.
c        ----------------------------------------------------------------------
         IF (LENGTH .EQ. -1) then
            IF (LPRINT .GT. 0) WRITE (LPRINT,5110)
     1        substring(:len_substring)
 5110       FORMAT (' Too long a sum in CHRATO, ending as follows:'/
     1              a)
            call errmes (1, 4, chsubp)
         end if
         IF (LENGTH .GT. MCHMET) THEN
            IF (LPRINT .GT. 0) WRITE (LPRINT,5120)
     1        substring(:len_substring)
 5120       FORMAT
     1           (' Too long a Metabolite Name in CHRATO ',
     2            'ending as follows:' / A)
            CALL ERRMES (2, 4, CHSUBP)
         END IF
         wildcard = substring(istart+length-1:istart+length-1) .eq. '*'
         do 130 jmetab = 1, nmetab
            factor = 0.
            if (wildcard) then
               if (length .eq. 1) then
                  factor = 1.
               else
                  if (substring(istart:istart+length-2) .eq.
     1                nacomb(jmetab)(1:length-1)) factor = 1.
               end if
            else
               chterm = substring(istart:istart+length-1)
               if (chterm .eq. nacomb(jmetab)) factor = 1.
               if (chterm .eq. 'totCho'   .and.
     1             (nacomb(jmetab) .eq. 'Cho'   .or.
     2              nacomb(jmetab) .eq. 'GPC'   .or.
     3              nacomb(jmetab) .eq. 'PCh')) factor = 1.
               if (chterm .eq. 'totCr'   .and.
     1             (nacomb(jmetab) .eq. 'Cr'   .or.
     2              nacomb(jmetab) .eq. 'Cre'   .or.
     3              nacomb(jmetab) .eq. 'PCr')) factor = 1.
               if (chterm .eq. 'totNAA'   .and.
     1             (nacomb(jmetab) .eq. 'NAA'   .or.
     2              nacomb(jmetab) .eq. 'NAAG')) factor = 1.
               if (chterm .eq. 'Big3') then
                  if (nacomb(jmetab) .eq. 'Cr'   .or.
     1                nacomb(jmetab) .eq. 'Cre'   .or.
     2                nacomb(jmetab) .eq. 'PCr'   .or.
     3                nacomb(jmetab) .eq. 'NAA'   .or.
     4                nacomb(jmetab) .eq. 'NAAG') then
                     factor = 1.
                  else if (nacomb(jmetab) .eq. 'Cho'   .or.
     1                     nacomb(jmetab) .eq. 'GPC'   .or.
     2                     nacomb(jmetab) .eq. 'PCh') then
                     factor = 3.
                  end if
               end if
            end if
            if (factor .gt. 0.) then
               denom_absent = .false.
               csum = csum + factor * sngl(solbes(jmetab, 1))
               if (exrati_arg .gt. 0.) cprior(lratio, jmetab) =
     1                                 cprior(lratio, jmetab) -
     2                                 factor * exrati_arg
            end if
 130     continue
         if (atend) return
         istart = istart + length + 1
 110  continue
      IF (LPRINT .GT. 0) WRITE (LPRINT,5130) substring(:len_substring)
 5130 FORMAT (' Too many metabolites in CHRATI or CHRATW ',
     1        'ending as follows:' / A)
      call errmes (3, 4, chsubp)
      end
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      LOGICAL FUNCTION LDEGMX (IDEGMX)
C
C  LDEGMX = T if the max. phase correction to the data would exceed
C             DEGMAX(IDEGMX)
C
      INCLUDE 'lcmodel.inc'
      PHACOR(ppmarg) = ABS(PHIZER + (ppmarg - ppmcen) * PHIONE)
      CHSUBP='LDEGMX'
      IF ((IDEGMX.NE.1 .AND. IDEGMX.NE.2) .OR. RADIAN.LE.0.) CALL
     1      ERRMES (1, 5, CHSUBP)
      IF (DEGMAX(IDEGMX) .LE. 0.) CALL ERRMES (2, 4, CHSUBP)
      PHIZER=PARBES(LPHAST,2)
      PHIONE=PARBES(LPHAST+1,2)
      ppmsig_max = amax1(ppmsig(1), ppmsig(2))
      ppmsig_min = amin1(ppmsig(1), ppmsig(2))
      ppmmax = amin1(ppmsig_max, ppm(1))
      ppmmin = amax1(ppmsig_min, ppm(nyuse))
      LDEGMX=AMAX1(PHACOR(ppmmax),PHACOR(ppmmin)) .GT.
     1       DEGMAX(IDEGMX)*RADIAN
      END
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      INTEGER FUNCTION NEXTRE (PARNL, NSIDE2, DPY, DGAUSS, THRLIN,
     1                         imethd)
C  NEXTRE = no. of extrema, assuming one zero point outside of each boundary
C           and that the point between PARNL(NSIDE2/2) and PARNL(NSIDE2/2+1)
C           is 1-(sum over the NSIDE2 PARNL).
C  Lineshape is first smoothed with DGAUSS.
C  An extremum is not counted if the absolute values of it and one of its
C     neighboring extrema are less than
C     THRLIN*(maximum of the absolute value of all points); i.e., if it is
C     just a notch near the noisy Baseline.
C
      DOUBLE PRECISION PARNL(NSIDE2), DPY(NSIDE2+3,2), DSUM,
     1                 DGAUSS(0:NSIDE2+2), DTHR
      if (imethd .eq. 2) then
         nextre = 99
         return
      end if
      DPY(1,1)=0.D0
      DPY(NSIDE2+3,1)=0.D0
      DSUM=1.D0
      DO 110 JPAR=1,NSIDE2
         DSUM=DSUM-PARNL(JPAR)
  110 CONTINUE
      IMIDDL=NSIDE2/2+2
      JPAR=0
      DO 120 JPY=2,NSIDE2+2
         IF (JPY .EQ. IMIDDL) THEN
            DPY(JPY,1)=DSUM
        ELSE
            JPAR=JPAR+1
            DPY(JPY,1)=PARNL(JPAR)
         END IF
  120 CONTINUE
      DTHR=0.D0
      DO 150 JPY=1,NSIDE2+3
         DSUM=0.D0
         DO 160 KPY=1,NSIDE2+3
            DSUM=DSUM+DPY(KPY,1)*DGAUSS(IABS(KPY-JPY))
  160    CONTINUE
         DPY(JPY,2)=DSUM
         DTHR=DMAX1(DTHR, DABS(DSUM))
  150 CONTINUE
      DTHR=DTHR*THRLIN
C      WRITE (6,5150) DTHR, (DPY(J,2),J=1,NSIDE2+3)!DELETE
C 5150 FORMAT (/' Threshold =',F7.4/(1X,10F12.4))!DELETE
      KEXTR=1
      DPY(1,1)=0.D0
      DO 210 JPAR=2,NSIDE2+2
         IF ((DPY(JPAR,2)-DPY(JPAR-1,2))*(DPY(JPAR+1,2)-DPY(JPAR,2))
     1       .LT. 0.D0) THEN
            KEXTR=KEXTR+1
            DPY(KEXTR,1)=DABS(DPY(JPAR,2))
         END IF
  210 CONTINUE
      DPY(KEXTR+1,1)=0.D0
      NEXTRE=0
      DO 220 JEXTR=2,KEXTR
         IF (DMAX1(DPY(JEXTR,1), DMIN1(DPY(JEXTR+1,1),
     1                                 DPY(JEXTR-1,1))) .GT. DTHR)
     2         NEXTRE=NEXTRE+1
  220 CONTINUE
      END
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      INTEGER FUNCTION INFLEC (PARNL, NSIDE2, DPY, DGAUSS, THRLIN,
     1                         imethd)
C
C  INFLEC = no. of inflection points assuming 2 zero points outside of each
C           boundary and that the point between PARNL(NSIDE2/2) and
C           PARNL(NSIDE2/2+1) is 1-(sum over the NSIDE2 PARNL).
C  Lineshape is first smoothed with DGAUSS.
C  Inflections are only counted if smoothed point exceeds THRLIN*(maximum of
C    the abolute values of all points).
C
      DOUBLE PRECISION PARNL(NSIDE2), DPY(NSIDE2+5,2), DSUM, DEL,
     1                 DELOLD, DGAUSS(0:NSIDE2+4), DTHR
      if (imethd .eq. 2) then
         inflec = 99
         return
      end if
      DPY(1,1)=0.D0
      DPY(2,1)=0.D0
      DPY(NSIDE2+4,1)=0.D0
      DPY(NSIDE2+5,1)=0.D0
      DSUM=1.D0
      DO 110 JPAR=1,NSIDE2
         DSUM=DSUM-PARNL(JPAR)
  110 CONTINUE
      IMIDDL=NSIDE2/2+3
      JPAR=0
      DO 120 JPY=3,NSIDE2+3
         IF (JPY .EQ. IMIDDL) THEN
            DPY(JPY,1)=DSUM
         ELSE
            JPAR=JPAR+1
            DPY(JPY,1)=PARNL(JPAR)
         END IF
  120 CONTINUE
      DTHR=0.D0
      DO 150 JPY=1,NSIDE2+5
         DSUM=0.D0
         DO 160 KPY=1,NSIDE2+5
            DSUM=DSUM+DPY(KPY,1)*DGAUSS(IABS(KPY-JPY))
  160    CONTINUE
         DPY(JPY,2)=DSUM
         DTHR=DMAX1(DTHR, DABS(DSUM))
  150 CONTINUE
      DTHR=DTHR*THRLIN
      INFLEC=0
      DELOLD=DPY(3,2)
      DO 210 JPAR=3,NSIDE2+4
         DEL=DPY(JPAR-1,2)-2.D0*DPY(JPAR,2)+DPY(JPAR+1,2)
         IF (DEL*DELOLD.LT.0.D0 .AND. DABS(DPY(JPAR,2)).GT.DTHR)
     1     INFLEC=INFLEC+1
         DELOLD=DEL
  210 CONTINUE
      END
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE SSRANG (IRANGE)
C
C  Set parameters for Regula Falsi search.
C
      INCLUDE 'lcmodel.inc'
      CHSUBP='SSRANG'
      IF (IRANGE.LT.1 .OR. IRANGE.GT.3) CALL ERRMES (1, 5, CHSUBP)
      SSQMIN=FSHSSQ (PRMNMX(1,IRANGE),
     1               0, NYuse, FLOAT(NDFREF), SSQREF,
     2                      LPRINT, RRANGE)
      SSQMAX=FSHSSQ (PRMNMX(2,IRANGE),
     1               0, NYuse, FLOAT(NDFREF), SSQREF,
     2                      LPRINT, RRANGE)
 5210 FORMAT (//' SSQREF =',1PE14.6,'   SSQMIN =',E14.6,'   SSQMAX =',
     1        E14.6,'   PREJMN =',0PF7.4,'   PREJMX =',F7.4//)
      IF (LPRINT .GT. 0) WRITE (LPRINT,5210) SSQREF, SSQMIN, SSQMAX,
     1                            PRMNMX(1,IRANGE), PRMNMX(2,IRANGE)
      SSQAIM=.5*(SSQMIN+SSQMAX)
      IF (SSQMIN .GE. SSQMAX) CALL ERRMES (2, 4, CHSUBP)
      END
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE RFALSI (IALPHA, IRANGE, LREPHA, ALPHB, ALPHS, ASSQLO,
     1                   AALPLO, ASSQHI, AALPHI, AALPHA, PREJOK, PREJ1)
C
C  Regula falsi search for an ALPHA with SSQ between SSQMIN and SSQMAX, where
C    ALPHAB = ALPHB*ALPHA when IALPHA=1 or 3
C    ALPHAS = ALPHS*ALPHA when IALPHA=2 or 3
C
C  IALPHA = 1 keeping ALPHAS fixed.
C         = 2 keeping ALPHAB fixed.
C         = 3 for normal search varying ALPHAB and ALPHAS.
c
c  IRANGE: PRMNMX(*, IRANGE) will be used.
C
C  LREPHA = T to rephase and get Reference Solution.
C
C  Needs starting values from previous analysis and call to SAVBES(2).
C
      INCLUDE 'lcmodel.inc'
      DOUBLE PRECISION ALPBOL, ALPBUS, alpha_alphab, alpha_alphas,
     1                 ALPHB, ALPHS, ALPSOL, ALPSUS, PENLTY
      LOGICAL LREPHA, PREJOK
C      COMPLEX CYFIT(MY)!CT2
C      LOGICAL LTEST!CT2
C      COMMON /BLT1/ CYFIT, LTEST!CT2

      CHSUBP='RFALSI'
      IF (MIN0(IRANGE,IALPHA).LT.1 .OR. MAX0(IRANGE,IALPHA).GT.3) CALL
     1      ERRMES (1, 5, CHSUBP)
      IF (AMIN1(RALIMN,RALINC) .LE. 1.) CALL ERRMES (2, 4, CHSUBP)
      is_alpbmn = .false.
      ALPBUS=DMIN1(ALPBMX,DMAX1(ALPBMN,ALPHB))
      ALPSUS=DMIN1(ALPSMX,DMAX1(ALPSMN,ALPHS))
      SSQLO=ASSQLO
      ALPLO=AALPLO
      SSQHI=ASSQHI
      ALPHI=AALPHI
      ALPHA=AALPHA
      IF (LREPHA) THEN
C        ----------------------------------------------------------------------
C        Rephase data and get Reference Solution.
C        ----------------------------------------------------------------------
         IF (LPRINT .GT. 0) WRITE (LPRINT,5110)
 5110    FORMAT (//////20X, 'Reference Solution for rephased data')
         CALL REPHAS ()
         ALPHAB=ALPBMN
         ALPHAS=ALPSMN
C         LTEST=.TRUE.!CT2
         CALL PLINLS (2, IERROR)
         IF (OBJECT .GE. DRANGE) CALL ERRMES (3, 4, CHSUBP)
C!CT2
C         DO 2110 JNONL=1,NNONL!CT2
C            PARNLN(JNONL)=PARBES(JNONL,2)!CT2
C 2110    CONTINUE!CT2
C         DO 2120 JY=1,NY!CT2
C            CY(JY)=CYFIT(JY)!CT2
C 2120    CONTINUE!CT2
C         CALL PLINLS (2, IERROR)!CT2
C         IF (LTEST) STOP!CT2
C!CT2
         INISOL=.FALSE.
         SSQREF=DSSQ
         NDFREF=NDF
         CALL SSRANG (IRANGE)
      END IF
      DAIMBS=RRANGE
      NINFLE=99
      PREJOK=.FALSE.
      ALPHAB=ALPBUS
      ALPHAS=ALPSUS
      DO 310 JTRY=1,MFNDAL
         ALPBOL=ALPHAB
         ALPSOL=ALPHAS
         IF (IALPHA .EQ. 1) THEN
            ALPHAB=DMAX1(ALPBMN,DMIN1(ALPBMX,ALPBUS*ALPHA))
c           ------------------------------------------------------------------
c           ALPHA must be adjusted (for next ALPHA interplolation) to agree
c              with any limit imposed by ALPBMN or ALPBMX.
c           The factors .99999 & 1.00001 allow for rounding error in
c              calculation of ALPHA.
c           ------------------------------------------------------------------
            alpha = alphab / alpbus
            IF (JTRY .GT. 1) THEN
               IF (DMIN1(ALPBOL,ALPHAB) .GE. .99999*ALPBMX) THEN
                  if (.not.nobase) CALL ERRMES (4, 1, CHSUBP)
                  GO TO 700
               ELSE IF (DMAX1(ALPBOL,ALPHAB) .LE. 1.00001*ALPBMN) THEN
                  CALL ERRMES (5, 1, CHSUBP)
                  is_alpbmn = .true.
                  GO TO 700
               END IF
            END IF
         ELSE IF (IALPHA .EQ. 2) THEN
            ALPHAS=DMAX1(ALPSMN,DMIN1(ALPSMX,ALPSUS*ALPHA))
c           ------------------------------------------------------------------
c           ALPHA must be adjusted (for next ALPHA interplolation) to agree
c              with any limit imposed by ALPSMN or ALPSMX.
c           ------------------------------------------------------------------
            alpha = alphas / alpsus
            IF (JTRY .GT. 1) THEN
               IF (DMIN1(ALPSOL,ALPHAS) .GE. .99999*ALPSMX) THEN
                  CALL ERRMES (6, 1, CHSUBP)
                  GO TO 700
               ELSE IF (DMAX1(ALPSOL,ALPHAS) .LE. 1.00001*ALPSMN) THEN
                  CALL ERRMES (7, 2, CHSUBP)
                  GO TO 700
               END IF
            END IF
         ELSE
            ALPHAB=DMAX1(ALPBMN,DMIN1(ALPBMX,ALPBUS*ALPHA))
            ALPHAS=DMAX1(ALPSMN,DMIN1(ALPSMX,ALPSUS*ALPHA))
c           ------------------------------------------------------------------
c           The limits imposed by ALP*MN or ALP*MX produce two ALPHAs, at least
c              as close to 1 (on log scale) as the original ALPHA.  Readjust
c              ALPHA (for interpolation later) to the one furthest from 1 (on
c              log scale), i.e., closest to the original ALPHA.
c           ------------------------------------------------------------------
            alpha_alphab = alphab/alpbus
            alpha_alphas = alphas/alpsus
            if (dabs(dlog(alpha_alphab)) .gt.
     1          dabs(dlog(alpha_alphas))) then
               alpha = alpha_alphab
            else
               alpha = alpha_alphas
            end if
            IF (JTRY .GT. 1) THEN
               IF (DMIN1(ALPBOL,ALPHAB).GE. .99999*ALPBMX .AND.
     1             DMIN1(ALPSOL,ALPHAS).GE. .99999*ALPSMX) THEN
C                 -------------------------------------------------------------
C                 PREJOK = T for special case that both ALPHAs are max, and
C                            SSQ<SSQMAX nevertheless (or, below, when
C                            unimodality has already been achieved during
C                            increase of ALPHAS).
C                 -------------------------------------------------------------
                  PREJOK=SSQ .LE. SSQMAX
                  CALL ERRMES (8, 1, CHSUBP)
                  GO TO 700
               END IF
               IF (DMAX1(ALPBOL,ALPHAB).LE. 1.00001*ALPBMN .AND.
     1              DMAX1(ALPSOL,ALPHAS).LE. 1.00001*ALPSMN) THEN
                  CALL ERRMES (9, 2, CHSUBP)
                  GO TO 700
               END IF
            END IF
         END IF
         IF (LREPHA) THEN
            CALL PLINLS (2, IERROR)
         ELSE
            CALL PLINLS (3, IERROR)
         END IF
         SSQ=DSSQ
         IF (OBJECT .LT. DRANGE) THEN
            NINFLE=INFLEC (PARNLN, NSIDE2, DPY, DGAUSS, THRLIN, imethd)
            NEXT=NEXTRE (PARNLN, NSIDE2, DPY, DGAUSS, THRLIN, imethd)
            IF (MDALPB.LE.0 .OR. USINFL) THEN
               ITEST=NINFLE-2
            ELSE
               ITEST=NEXT-1
            END IF
            IF (ITEST.LE.0 .AND. SSQ.LE.SSQMAX) THEN
C              ----------------------------------------------------------------
C              The peak is smooth and the fit is good; so set
C              PREJOK = T for special exit to stop increasing ALPHAS
C                         if only ALPHAS is being increased (IALPHA=2) or
C                         if ALPHAB=ALPBMX during the normal search varying
C                           ALPHAB & ALPHAS (IALPHA=3), or when NSIDES=1
c                           (i.e. only ALPHAB will be varied).
C              ----------------------------------------------------------------
               PREJOK=IALPHA.EQ.2 .OR.
     1                (ALPHAB.GE. .99999*ALPBMX   .and.
     2                 (IALPHA.EQ.3   .or.   nsides .le. 1))
C               if (ALPHAB.GE.ALPBMX .AND. IALPHA.EQ.3) call errmes (99,
C     1                                                   1, CHSUBP)
            END IF
            if (imethd .eq. 2   .and.   ialpha .eq. 2   .and.
     1          alphas .ge. .99999 * alpsmx   .and.
     2          ssq .le. ssqmax) then
               prejok = .true.
               call errmes (18, 1, chsubp)
            end if
            RTERM=ABS(SSQ-SSQAIM)
            IF (RTERM .LT. DAIMBS) THEN
               DAIMBS=RTERM
               CALL SAVBES (1)
            END IF
         ELSE
            CALL ERRMES (10, 3, CHSUBP)
            ALPHA=ALPHA*RALINC
            GO TO 310
         END IF
         IF (LPRINT .GT. 0) THEN
            IF (SDREF**2 .GT. 0.D0) THEN
               PENB=PENLTY (ALPHAB, 0.D0, SOLUTN, PARNLN)/SDREF**2
               PENS=PENLTY (0.D0, ALPHAS, SOLUTN, PARNLN)/SDREF**2
               IF (PENS .GT. 0.) THEN
                  RPEN=PENB/PENS
               ELSE
                  RPEN=RRANGE
               END IF
               PEN=(OBJECT-DSSQ)/SDREF**2
               IF (SNGL(ALPHAB) .LT. ALPBPN) PEN=PEN+PNALPB
            ELSE
               PENB=RRANGE
               PENS=RRANGE
               RPEN=RRANGE
               PEN=RRANGE
            END IF
            WRITE (LPRINT,5310) JTRY, ALPHAB, ALPHAS,
     1                           NINFLE, SSQLO, SSQ, SSQHI,
     2                           PENB, PENS, RPEN, NEXT,
     3                           PEN, OBJECT-DSSQ
 5310       FORMAT (/' ITER =',I2,'     ALPHAB =', 1PE10.3, 3X,
     1      'ALPHAS =', E10.3, 6X, 'Ninfle =', I2, 6X, '(SSQ', E14.6,
     2      ' <', E14.6,' <',E14.6,')'/
     3      14X, 'penB/penS =', E9.2, ' /', E9.2, ' =', E9.2, 3X,
     4      'Nextre =', I2, /
     5      14X, 'Penalty =', E12.4, 24X,
     6      'Penalty*SDREF**2 (w/o prior) =', E10.2)
            if (iter_dump .eq. jtry   .and.
     1           dabs(alphab - alphab_dump) .le. 1.d-3 * alphab   .and.
     2           dabs(alphas - alphas_dump) .le. 1.d-3 * alphas) then
               call savbes(1)
               call savbes(2)
               call finout ()
               stop
            end if
         END IF
         IF (PREJOK) THEN
C           -------------------------------------------------------------------
C           Special exit when either of the above 2 criteria (before LPRINT)
c              are satisfied.
C           -------------------------------------------------------------------
            CALL SAVBES (1)
            GO TO 700
         END IF
         ALPOLD=ALPHA
         IF (SSQ .LE. AMAX1(SSQREF,SSQLO)) THEN
            IF (SSQ .GE. SSQREF) THEN
C              ----------------------------------------------------------------
C              This error is probably due to a local min. in a preceding
C                solution.
C              ----------------------------------------------------------------
               CALL ERRMES (11, 1, CHSUBP)
            ELSE
C              ----------------------------------------------------------------
C              This error is probably due to a local min. in the Reference
C                Solution.  Redefine the present solution as the Reference
C                Solution.
C              ----------------------------------------------------------------
               CALL ERRMES (12, 1, CHSUBP)
               SSQREF=SSQ
               NDFREF=NDF
               CALL SSRANG (IRANGE)
            END IF
            SSQLO=SSQ
            ALPLO=ALPHA
            IF (ALPHI .LT. RRANGE) THEN
               ALPHA=AMIN1(.5*(ALPHA+ALPHI), ALPHA*RALINC)
            ELSE
               ALPHA=ALPHA*RALINC
            END IF
            GO TO 320
         END IF
         IF (SSQ .GE. SSQHI) THEN
C           -------------------------------------------------------------------
C           This error is probably due to round-off or to a local min. in this
C             solution.
C           -------------------------------------------------------------------
            ALPHA=AMAX1(.5*(ALPHA+ALPLO), ALPHA/RALINC)
            CALL ERRMES (13, 1, CHSUBP)
            GO TO 320
         END IF
         IF (SSQ .GT. SSQMAX) THEN
            IF (SSQHI-SSQAIM .LE. SSQAIM-SSQLO) THEN
C              ----------------------------------------------------------------
C              SSQLO is too far away for interpolation.  Extrapolate using
C                SSQHI.
C              ----------------------------------------------------------------
               ALPHA=AMAX1(ALPHA/RALINC,
     1                 ALPHI-(ALPHI-ALPHA)*(SSQHI-SSQAIM)/(SSQHI-SSQ))
C              ----------------------------------------------------------------
C              If extrapolation goes back behind ALPLO, then take midpoint.
C              ----------------------------------------------------------------
               IF (ALPHA .LE. ALPLO) ALPHA=.5*(ALPOLD+ALPLO)
            ELSE IF (SSQLO .LT. 0.) THEN
               ALPHA=ALPHA/RALINC
            ELSE
C              ----------------------------------------------------------------
C              Normal interpolation.
C              ----------------------------------------------------------------
               ALPHA=ALPLO+(ALPHA-ALPLO)*(SSQAIM-SSQLO)/(SSQ-SSQLO)
            END IF
            ALPHI=ALPOLD
            SSQHI=SSQ
         ELSE IF (SSQ .LT. SSQMIN) THEN
            IF (SSQHI .GE. RRANGE) THEN
               IF (SSQLO .LT. 0.) THEN
                  ALPHA=ALPHA*RALINC
               ELSE
C                 -------------------------------------------------------------
C                 Limited extrapolation.
C                 -------------------------------------------------------------
                  test = ALPLO + (ALPHA - ALPLO) *
     1                           (SSQAIM - SSQLO) / (SSQ - SSQLO)
                  alpha = amin1(test, xtrpmx * alpha)
               END IF
            ELSE IF (SSQAIM-SSQLO.LE.SSQHI-SSQAIM .AND. SSQLO.GT.0.)
     1                 THEN
C              ----------------------------------------------------------------
C              SSQHI is too far away for interpolation.  Extrapolate using
C                SSQLO.
C              ----------------------------------------------------------------
               ALPHA=ALPLO+(ALPHA-ALPLO)*(SSQAIM-SSQLO)/(SSQ-SSQLO)
               IF (ALPHA .GE. ALPHI) THEN
C                 -------------------------------------------------------------
C                 Limit extrapolation beyond ALPHI.
C                 Remove ALPHI as upper bound.  It could have been a local
C                   min. that has since been improved.
C                 -------------------------------------------------------------
                  ALPHA=AMIN1(ALPHA,ALPOLD*RALINC)
                  ALPHI=RRANGE
                  SSQHI=RRANGE
               END IF
            ELSE
C              ----------------------------------------------------------------
C              Normal interpolation.
C              ----------------------------------------------------------------
               ALPHA=ALPHA+(ALPHI-ALPHA)*(SSQAIM-SSQ)/(SSQHI-SSQ)
            END IF
            ALPLO=ALPOLD
            SSQLO=SSQ
         ELSE
            GO TO 700
         END IF
  320    IF (ALPHA/ALPOLD.GT.1. .AND. ALPHA/ALPOLD.LT.RALIMN) THEN
C           -------------------------------------------------------------------
C           This too small an increase in ALPHA could be due to too low an
C             upper bound; remove it.
C           -------------------------------------------------------------------
            SSQHI=RRANGE
            ALPHI=RRANGE
         ELSE IF (ALPOLD/ALPHA.GT.1. .AND. ALPOLD/ALPHA.LT.RALIMN) THEN
C           -------------------------------------------------------------------
C           This too small a decrease in ALPHA could be due to too high a
C             lower bound; remove it.
C           -------------------------------------------------------------------
            SSQLO=-1./RRANGE
            ALPLO=0.
         END IF
  310 CONTINUE
      CALL ERRMES (14, 2, CHSUBP)
  700 IF (DAIMBS .GE. RRANGE) CALL ERRMES (15, 4, CHSUBP)
      IF (SSQREF*FLOAT(NDFREF) .LE. 0.) THEN
         CALL ERRMES (16, 3, CHSUBP)
         PREJ1=-1.
      ELSE
         PREJ1=FISHNI(AMAX1(0.,(SSQBES(1)-SSQREF))*FLOAT(NYuse-NDFREF)/
     1                (SSQREF*FLOAT(NDFREF)), FLOAT(NDFREF),
     2                FLOAT(NYuse-NDFREF), LPRINT)
         IF (LPRINT .GT. 0) WRITE (LPRINT,5710) PREJ1
 5710    FORMAT (/' Probability to reject =',F7.4)
         PREJOK=PREJOK .OR. (PREJ1.GE..99*PRMNMX(1,IRANGE) .AND.
     1                       PREJ1.LE.1.01*PRMNMX(2,IRANGE))
C        ----------------------------------------------------------------------
C        PREJOK = F together with an alpha = alpha_max is probably harmless,
C                   e.g., when ALPHAB=ALPBMX and ALPHAS=ALPSMN at start of
C                   grid scan.
C        ----------------------------------------------------------------------
         IF (.NOT.PREJOK .AND. ALPHAB.LT..99999*ALPBMX .AND.
     1       ALPHAB.GT.1.00001*ALPBMN) CALL ERRMES (17, 2, CHSUBP)
      END IF
      END
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      DOUBLE PRECISION FUNCTION PENLTY (ALPB, ALPS, SOL, PARNL)
C
C  PENLTY = regularizor penalty for ALPHAB=ALPB and ALPHAS=ALPS multiplied by
C           weighting factor SDREF.
C         = 0 if SDREF has not yet been computed.
C  REGF is assumed to be for the lineshape coefficients with the center
C       coefficient eliminated by the equality constraint.  Therefore, the 1st
C       3 rows are assumed to have the constants 2, -1, -1 on the rhs, rather
C       than 0.
C
      INCLUDE 'lcmodel.inc'
      DOUBLE PRECISION ALPB, ALPS, PARNL(MNONL), SOL(MPAR)
      CHSUBP='PENLTY'
      PENLTY=0.D0
      IF (SDREF .GE. DRANGE) RETURN
      IF (ALPB .GT. 0.D0) THEN
         DO 110 IROW=1,NBACKG
            DTERM(1)=0.D0
            DO 120 ICOL=1,NBACKG
               DTERM(1)=DTERM(1)+REGB(IROW,ICOL)*SOL(NMETAB+ICOL)
  120       CONTINUE
            PENLTY=PENLTY+(ALPB*DTERM(1))**2
  110    CONTINUE
      END IF
      IF (ALPS .GT. 0.D0) THEN
         if (imethd .eq. 2) then
            do 205 jmetab = 1, nmetab
               jnonl = lrt2st - 1 + jmetab
c              ---------------------------------------------------------------
c              CONC_EXPECT(JMETAB) = expectation of relative CONC
c              PI * HZPPPM * RT2MIN(JMETAB) = (Lorentzian) 1/T2 of
c                 of initial Gaussian (sharpness limit), SIFWMN.
c              RLRNTZ = extra factor (>1) to penalize Lorentzian broadening
c                       compared to component with initial Gaussian.
c              ---------------------------------------------------------------
               dterm(1) = alps * sol(jmetab) / conc_expect(jmetab)
               if (ipowrg .eq. 1) then
                  penlty = penlty + (dterm(1) * (rt2min(jmetab) +
     1                                        rlrntz * parnl(jnonl)))**2
               else
                  dterm(2) = (rt2min(jmetab) + rlrntz * parnl(jnonl))**2
                  penlty = penlty + (dterm(1) * dterm(2))**2
               end if
c               write(lprint, 9205) sdref, alps, sol(jmetab),
c     1            conc_expect(jmetab), rt2min(jmetab), parnl(jnonl),
c     2            dterm(1), dterm(2), penlty, jnonl, jmetab, nmetab
c 9205          format(1p9e10.2, 3i4)

 205        continue
         else
            DO 210 IROW=1,NREGF
               IF (IROW .EQ. 1) THEN
                  DTERM(1)=-2.D0
               ELSE IF (IROW .LE. 3) THEN
                  DTERM(1)=1.D0
               ELSE
                  DTERM(1)=0.D0
               END IF
               DO 220 ICOL=1,NSIDE2
                  DTERM(1)=DTERM(1)+REGF(IROW,ICOL)*PARNL(ICOL)
 220           CONTINUE
               PENLTY=PENLTY+(ALPS*DTERM(1))**2
 210        CONTINUE
         END IF
      END IF
      PENLTY=PENLTY*SDREF**2
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE REPHAS ()
C
C  Rephases CY using phases in PARBES(*,2)
C  Loads PARBES(*,2) into PARNLN
C
      INCLUDE 'lcmodel.inc'
      CHSUBP='REPHAS'
      PHITOT(1)=PHITOT(1)+PARBES(LPHAST,2)
      PHITOT(2)=PHITOT(2)+PARBES(LPHAST+1,2)
      if (lprint .gt. 0) write(lprint, 5110) phitot(1)/radian,
     1                                       phitot(2)/radian
 5110 format(/'Rephasing to', f7.1, ' deg;   ', f8.2, ' deg/ppm'/)
      CTERM(1)=CEXP(CMPLX(0.,SNGL(PARBES(LPHAST,2)+
     1                            PARBES(LPHAST+1,2)*DELPPM(1))))
      CTERM(2)=CEXP(CMPLX(0.,-SNGL(PARBES(LPHAST+1,2)*PPMINC)))
      JDATA=LDATST
      DO 110 JY=1,NY
         CY(JY)=CY(JY)*CTERM(1)
         CTERM(1)=CTERM(1)*CTERM(2)
  110 CONTINUE
      PARBES(LPHAST,2)=0.D0
      PARBES(LPHAST+1,2)=0.D0
      DO 120 JNONL=1,NNONL
         PARNLN(JNONL)=PARBES(JNONL,2)
  120 CONTINUE
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      REAL FUNCTION FSHSSQ (PREJ,
     1                      IDFISH, NYuse, REFNDF, SSQREF,
     2                      LPRINT, RRANGE)
C
C  FSHSSQ = the weighted sum of squared deviations
C    corresponding to the Fisher Varaiance-Ratio for PREJ (the
C    probability to reject), REFNDF (the degrees of freedom of the
C    Reference Solution), NYuse, and SSQREF (the SSQ for the Reference
C    Solution).
C  IDFISH .NE. 0 to always dump.
C         .LT. 0 to stop after first dump.
C
      CHARACTER CHSUBP*6
      DOUBLE PRECISION DGAMLN
      CHSUBP='FSHSSQ'
      mtry = 20
      ptol = 5.e-4
      IF (AMIN1(PREJ,SSQREF).LE.0. .OR. PREJ.GE.1. .OR. REFNDF.LE.1.
     1    .OR. REFNDF.GE.FLOAT(NYuse-1)) CALL ERRMES (1, 4, CHSUBP)
C
C     Get an approximate value for the inverse of the F-distribution
C     using formulas from Abramowitz and Stegun (A&S).
C
C     Put the inverse of the complementary normal distribution function
C     corresponding to PREJ into YP.  A&S 26.2.23 is used.
C
      EXMAX=ALOG(RRANGE)
      PCOMP=1.-PREJ
      IF (PCOMP .LE. .5) THEN
         PSMALL=PCOMP
      ELSE
         PSMALL=PREJ
      END IF
      TT=SQRT(-2.*ALOG(PSMALL))
      YP=TT-(2.515517+TT*(.802853+TT*.010328))/(1.+TT*(1.432788+TT*
     1   (.189269+TT*.001308)))
      IF (PCOMP .GT. .5) YP=-YP
C
C     Use A&S 26.6.16 and 26.5.22 to put approximate F value in FF.
C
      R2AM1=1./(FLOAT(NYuse-1)-REFNDF)
      R2BM1=1./(REFNDF-1.)
      SLAMBD=(YP*YP-3.)/6.
      HH=2./(R2AM1+R2BM1)
      DUM=HH+SLAMBD
      IF (DUM .LE. 0.) THEN
C
C        This is a special case where the degrees of freedom are so few
C        that this approximation is very poor.  DUM is arbitrarily set
C        to 0., and an error message warns that the result can be very
C        inaccurate.
C
         DUM=0.
         CALL ERRMES (2, 3, CHSUBP)
      END IF
      WW=YP*SQRT(DUM)/HH-(R2BM1-R2AM1)*(SLAMBD+(5.-4./HH)/6.)
      IF (2.*WW .GE. EXMAX) CALL ERRMES (3, 4, CHSUBP)
      FF=EXP(2.*WW)
C
C     Use Newton's method to refine value of FF so that it's PREJ is
C     within PTOL of the required value of PREJ.
C
      DPBEST=RRANGE
      DF1=REFNDF
      HDF1=.5*DF1
      DF2=FLOAT(NYuse)-REFNDF
      HDF2=.5*DF2
      FACLOG=DGAMLN(DBLE(HDF1+HDF2)) - DGAMLN(DBLE(HDF1)) -
     1       DGAMLN(DBLE(HDF2)) + HDF1*ALOG(DF1) + HDF2*ALOG(DF2)
      EXP1=HDF1-1.
      EXP2=-HDF1-HDF2
      fbest = rrange
      DO 210 JTRY=1,MTRY
         PRTRY=FISHNI(FF,DF1,DF2,LPRINT)
         DPRTRY=PRTRY-PREJ
         IF (ABS(DPRTRY) .LE. DPBEST) THEN
            DPBEST=ABS(DPRTRY)
            FBEST=FF
            IF (DPBEST .LE. PTOL) GO TO 300
         END IF
         DPDF=EXP(FACLOG+EXP1*ALOG(FF)+EXP2*ALOG(DF2+DF1*FF))
         IF (DPDF .LE. 0.) THEN
            CALL ERRMES (4, 2, CHSUBP)
            GO TO 300
         END IF
         FF=FF-DPRTRY/DPDF
         IF (FF .LE. 0.) THEN
            CALL ERRMES (5, 3, CHSUBP)
            GO TO 300
         END IF
  210 CONTINUE
      CALL ERRMES (6, 3, CHSUBP)
  300 FSHSSQ=SSQREF*(1.+FBEST*DF1/DF2)
C      IF (IABS(IDFISH) .GE. 1) THEN
C         SPREJ=PREJ
C         SFSH=FSHSSQ
C         SREFND=REFNDF
C         NAMELIST /NAM2/ SPREJ,PCOMP,R2AM1,R2BM1,SREFND,TT,YP,
C     1   SLAMBD,HH,WW,FF,SFSH,JTRY,DPRTRY,FBEST,FACLOG,DPDF
C         IF (LPRINT .GT. 0) WRITE (LPRINT,NML=NAM2)
C         IF (IDFISH .LE. 0) THEN
C            CALL ERRMES (7, 1, CHSUBP)
C            STOP
C         END IF
C      END IF
      END
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE PLINLS (ISTAGE, IERROR)
C
C  Nonlinear least-squares analysis with first NLIN parameters occurring
C    linearly and parameters NLIN+1,NLIN+NNONL=NPAR nonlinearly.
C  SOLUTN(JPAR) = linear parameters when JPAR=1,NLIN
C               = full steps for nonlinear parameters when
C                 JPAR=NLIN+1,NLIN+NNONL=NPAR
C  PARNLN(JNONL) = nonlinear parameters, JNONL=1,NNONL
C
C  ISTAGE = 1 for preliminary analysis with only 1 broadening and shift
C             parameter
C         = 2 for Reference Solution of full analysis or other difficult
C             solution, e.g., with one alpha = 0.
C         = 3 for regularized solution of full analysis
C  SDREF = rough estimate for SD of fit.  It is continually updated to the
C          minimum while LSTAGE=1 and during the Starting Solution when
C          LSTAGE=2 (i.e., if INISOL=T).
C          SDREF is used for weighting the priors, the regularizors, and
C            the Marquardt rows.
C          The continuous updating of SDREF will cause an extra decrease
C            in OBJECT during the Starting Solution, and this may require
C            extra iterations.
C
C  IERROR = 1 on normal return
C         = 2 on max. iterations.
C
      INCLUDE 'lcmodel.inc'
      DOUBLE PRECISION GRADST, GRAD2, OBJOLD, PMARQ, PMQACT, PMQOLD,
     1                 SDOLD, SOLOLD(MPAR), STEP2
      LOGICAL LERROR, TRYZER
      CHSUBP='PLINLS'
      IF (ISTAGE.LE.0 .OR. ISTAGE.GT.3) CALL ERRMES (1, 5, CHSUBP)
      IF (AMIN1(PMQST(ISTAGE),PMQSTL(ISTAGE),RSTPMX(ISTAGE),
     1          RCONVR(ISTAGE),RMQDEC(ISTAGE),RMQINC(1,ISTAGE),
     2          RMQINC(2,ISTAGE),COSMIN(ISTAGE),RINCRS(ISTAGE),
     3          RPMQMN(ISTAGE)) .LE. 0. .OR.
     3    AMAX1(RSTPMN(ISTAGE),RCONVR(ISTAGE),RMQDEC(ISTAGE),
     4          RINCRS(ISTAGE)) .GE. 1.) CALL ERRMES (2, 4, CHSUBP)
      LSTAGE=MIN0(2,ISTAGE)
      PMARQ=PMQST(ISTAGE)
      PMQACT=0.D0
      COSINE=-2.
      RSTEP=0.
      IERROR=1
      INTERP=0
      ACTRED=0.
      PRERED=0.
      TRYZER=.TRUE.
      NZBAD=0
      NZSKIP=0
C     -------------------------------------------------------------------------
C     Initialize nonnegativity constraints on delta(1/T2).
C     -------------------------------------------------------------------------
      DO 110 JNONL=LRT2ST,NNONL
         NONNEG(NLIN+JNONL)=PARNLN(JNONL) .LE. 0.D0
  110 CONTINUE
C     -------------------------------------------------------------------------
C     Get OBJECT = objective function.
C     -------------------------------------------------------------------------
      CALL SOLVE (LSTAGE, .FALSE., 0.D0, .FALSE., LERROR)
      IF (LERROR) THEN
         OBJECT=DRANGE
         STDDEV=DRANGE
      END IF
 5110 FORMAT (////' Iter', 3X, 'Obj. funct.', 3X, 'Rel. dec.', 3X,
     1         'Pred. dec.', 3X, 'NDF', 3X, 'Marquardt', 3X,
     2         'Rel. step', 6X, 'Cosine', 3X, 'Interps.', 3X,
     3         'Degrees', 3X, 'Deg/ppm')
      IF (LPRINT .GT. 0) WRITE (LPRINT,5110)
      DO 210 ITER=1,MITER(ISTAGE)+1
         PMQOLD=PMQACT
         OBJOLD=OBJECT
         SDOLD=STDDEV
         ITEROL=ITER-1
         DGZER=PARNLN(LPHAST)/RADIAN
         DGPPM=PARNLN(LPHAST+1)/RADIAN
 5210    FORMAT (1X, I4, 1PE14.6, E12.3, E13.3, I6, E12.2,
     1           0P2F12.6, I11, 2F10.2, 1PE15.4)
         IF (LPRINT .GT. 0) WRITE (LPRINT,5210) ITEROL, OBJECT, ACTRED,
     1         PRERED, NDF, PMQACT, RSTEP, COSINE, INTERP, DGZER, DGPPM
         IF (IDUMP(ISTAGE).GE.2 .AND. LPRINT.GT.0) CALL DUMP1 (LSTAGE)
         INTERP=0
         COSINE=-2.
         DO 215 JNONL=1,NNONL
            PAROLD(JNONL)=PARNLN(JNONL)
  215    CONTINUE
         DO 216 JPAR=1,NLIN
            SOLOLD(JPAR)=SOLUTN(JPAR)
  216    CONTINUE
         IF (TRYZER .AND. DOZERO(ISTAGE) .AND. NZSKIP.LE.0) THEN
C           -------------------------------------------------------------------
C           Compute new direction, first trying 0 Marquardt parameter.
C           -------------------------------------------------------------------
            CALL SOLVE (LSTAGE, .TRUE., 0.D0, .FALSE., LERROR)
            IF (LERROR) GO TO 222
            COSINE=-2.
            PMQACT=0.D0
            RSTEP=1.
            CALL PASTEP (RSTEP)
            CALL SOLVE (LSTAGE, .FALSE., 0.D0, .FALSE., LERROR)
            IF (OBJECT .GE. OBJOLD) THEN
               NZBAD=NZBAD+1
               NZSKIP=NZBAD
            ELSE
               NZBAD=0
            END IF
         ELSE
            NZSKIP=NZSKIP-1
         END IF
  222    IF (OBJECT.GE.OBJOLD .OR. .NOT.(TRYZER.AND.DOZERO(ISTAGE))
     1       .OR. LERROR) THEN
C           -------------------------------------------------------------------
C           Try again with PMARQ
C           -------------------------------------------------------------------
            DO 224 JNONL=1,NNONL
               PARNLN(JNONL)=PAROLD(JNONL)
  224       CONTINUE
            DO 225 JPAR=1,NLIN
               SOLUTN(JPAR)=SOLOLD(JPAR)
  225       CONTINUE
            CALL SOLVE (LSTAGE, .TRUE., PMARQ, .FALSE., LERROR)
            IF (LERROR) GO TO 280
            PMQACT=PMARQ
            RSTEP=1.
            CALL PASTEP (RSTEP)
            CALL SOLVE (LSTAGE, .FALSE., 0.D0, .FALSE., LERROR)
            IF (LERROR) GO TO 280
         END IF
         IF (OBJOLD .LE. 0.D0) THEN
            CALL ERRMES (3, 2, CHSUBP)
            GO TO 300
         ELSE
            PRERED=1.D0-OBJLIN/OBJOLD
            ACTRED=1.D0-OBJECT/OBJOLD
         END IF
C        ----------------------------------------------------------------------
C        Test objective function.
C        ----------------------------------------------------------------------
         PMQSAV=PMQACT
         TRYZER=ACTRED .GE. -RINCRS(ISTAGE)
         IF (TRYZER) THEN
C           -------------------------------------------------------------------
C           Objective function has not significantly increased with a full
C             step.  Decrease Marquardt parameter PMARQ.
C           -------------------------------------------------------------------
            PMARQ=DMAX1(RPMQMN(ISTAGE)*PRECIS,PMARQ*RMQDEC(ISTAGE))
C           -------------------------------------------------------------------
C           Convergence test.
C           -------------------------------------------------------------------
            IF (AMAX1(ABS(PRERED),ABS(ACTRED)) .LE. RCONVR(ISTAGE) .AND.
     1          ABS(ACTRED) .LT. 2.*ABS(PRERED) .AND.
     2          PMQACT .LT. PMQSTL(ISTAGE) .AND.
     3          RSTEP .GE. 1.) GO TO 300
            GO TO 210
         ELSE
C           -------------------------------------------------------------------
C           Objective function has significantly increased.
C           Compute dot products of gradient and step and test the cosine of
C             the angle between them.
C           -------------------------------------------------------------------
            GRAD2=0.D0
            STEP2=0.D0
            GRADST=0.D0
            DO 238 JNONL=1,NNONL
               GRAD2=GRAD2+GRAD(JNONL)**2
               STEP2=STEP2+SOLUTN(NLIN+JNONL)**2
               GRADST=GRADST+GRAD(JNONL)*SOLUTN(NLIN+JNONL)
  238       CONTINUE
            IF (GRADST .GT. 0.D0) CALL ERRMES (4, 1, CHSUBP)
            DTERM(1)=DSQRT(STEP2)*DSQRT(GRAD2)
            IF (DTERM(1) .LE. 0.D0) THEN
               CALL ERRMES (5, 2, CHSUBP)
               GO TO 280
            END IF
            COSINE=-GRADST/DTERM(1)
            IF (COSINE .LT. COSMIN(ISTAGE)) GO TO 280
C           -------------------------------------------------------------------
C           Gradient and step are close enough to being parallel.  Interpolate
C             to get RSTEP (fractional step size).
C           -------------------------------------------------------------------
            DO 240 INTERP=1,MINTER(ISTAGE)
               IF (PMQACT .GT. 0.D0) PMARQ=PMARQ*RMQINC(2,ISTAGE)
               DTERM(1)=OBJOLD-OBJECT+GRADST*RSTEP
               IF (DABS(DTERM(1)) .LE. 0.D0) THEN
C                 -------------------------------------------------------------
C                 In the unlikely case that the denominator is exactly zero,
C                   go to the next iteration with an increased Marquardt
C                   parameter.
C                 -------------------------------------------------------------
                  CALL ERRMES (6, 3, CHSUBP)
                  GO TO 280
               END IF
               RSTEP=.5D0*GRADST*RSTEP**2/DTERM(1)
C              ----------------------------------------------------------------
C              If the fractional step size is unreasonable, go to the next
C                iteration with an increased PMARQ.
C              ----------------------------------------------------------------
               IF (RSTEP.LT.RSTPMN(ISTAGE) .OR. RSTEP.GT.RSTPMX(ISTAGE))
     1               GO TO 280
C              ----------------------------------------------------------------
C              Compute the new parameter set.
C              ----------------------------------------------------------------
               CALL PASTEP (RSTEP)
C              ----------------------------------------------------------------
C              Compute the objective function.
C              ----------------------------------------------------------------
               CALL SOLVE (LSTAGE, .FALSE., 0.D0, .FALSE., LERROR)
               IF (LERROR) GO TO 280
               IF (OBJECT .LT. OBJOLD) GO TO 210
  240       CONTINUE
         END IF
C        ----------------------------------------------------------------------
C        The current solution was unsuccessful.  Restore PAROLD in PARNLN,
C          OBJOLD in OBJECT, and SDOLD in STDDEV.  Increase PMARQ and start
C          next iteration.
C        ----------------------------------------------------------------------
  280    DO 290 JNONL=1,NNONL
            PARNLN(JNONL)=PAROLD(JNONL)
  290    CONTINUE
         DO 295 JPAR=1,NLIN
            SOLUTN(JPAR)=SOLOLD(JPAR)
  295    CONTINUE
         OBJECT=OBJOLD
         STDDEV=SDOLD
         PMQSAV=PMQOLD
         IF (PMQACT .GT. 0.D0) PMARQ=dmax1(PMARQ*RMQINC(1,ISTAGE),
     1                                     dble(pmqstl(istage)))
  210 CONTINUE
      IERROR=2
      IF (ISTAGE .GE. 2) CALL ERRMES (7, 1, CHSUBP)
  300 ITEROL=ITER-1
      DGZER=PARNLN(LPHAST)/RADIAN
      DGPPM=PARNLN(LPHAST+1)/RADIAN
      IF (LPRINT .GT. 0) WRITE (LPRINT,5210) ITEROL, OBJECT, ACTRED,
     1      PRERED, NDF, PMQACT, RSTEP, COSINE, INTERP, DGZER, DGPPM
      IF (IDUMP(ISTAGE).GE.1 .AND. LPRINT.GT.0) CALL DUMP1 (LSTAGE)
      END
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE DUMP1 (LSTAGE)
C
      INCLUDE 'lcmodel.inc'
      IF (LPRINT .LE. 0) RETURN
 5110 FORMAT (' Conc =', 1P10E12.3/ (7X, 1P10E12.3))
      WRITE (LPRINT,5110) (SOLUTN(J),J=1,NMETAB)
 5120 FORMAT (' Backgr =', 1P10E12.3/ (9X, 1P10E12.3))
      if (nbackg .gt. 0)
     1   WRITE (LPRINT,5120) (SOLUTN(J),J=NMETAB+1,NMETAB+NBACKG)
 5140 FORMAT (' Lineshape =', 10F12.4/ (12X, 10F12.4))
      IF (NSIDE2 .GT. 0) WRITE (LPRINT,5140) (PARNLN(J),J=1,NSIDE2)
 5150 FORMAT (' 1000*Shift =', 3P10F11.2/ (13X, 10F11.2))
      WRITE (LPRINT,5150) (PARNLN(J)/(2.*PI*HZPPPM),J=LSHIST,
     1                       LSHIST+NEXPON-1)
      IF (LSTAGE .EQ. 1) THEN
 5160    FORMAT (' Gaussian FWHM (ppm) =', F8.4)
         WRITE (LPRINT,5160) TOFWHM*PARNLN(LRT2ST)
      ELSE
 5165    FORMAT (' delta(1/T2) =', 10F11.2/ (14X, 10F11.2))
         WRITE (LPRINT,5165) (PARNLN(J),J=LRT2ST,nnonl)
      END IF
      END
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE PASTEP (RSTEP)
C
      INCLUDE 'lcmodel.inc'
      CHSUBP='PASTEP'
      DO 110 JNONL=1,NNONL
         IF(SOLUTN(NLIN+JNONL) .NE. 0.D0) RSTEP=AMIN1(RSTEP,
     1        ABS(FSTPMQ*SNGL(DPARMQ(JNONL)/SOLUTN(NLIN+JNONL))))
  110 CONTINUE
C     -------------------------------------------------------------------------
C     Enforce nonnegativity of delta(1/T2).
C     -------------------------------------------------------------------------
      LPAR=0
      DO 115 JNONL=LRT2ST,NNONL
         JPAR=NLIN+JNONL
         IF (SOLUTN(JPAR).LT.0.D0 .AND. .NOT.NONNEG(JPAR)) THEN
            TERM=DABS(PARNLN(JNONL)/SOLUTN(JPAR))
            IF (TERM .LT. RSTEP) THEN
               RSTEP=TERM
               LPAR=JPAR
            END IF
         END IF
         NONNEG(JPAR)=NONNEG(JPAR) .AND. SOLUTN(JPAR).LE.0.D0
  115 CONTINUE
      IF (LPAR .NE. 0) NONNEG(LPAR)=.TRUE.
      DO 120 JNONL=1,NNONL
         PARNLN(JNONL)=PAROLD(JNONL)+RSTEP*SOLUTN(NLIN+JNONL)
  120 CONTINUE
      END
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE SOLVE (LSTAGE, DONONL, PMQACT, ONLYFT, LERROR)
C
C  Sets up and solves nonnegative linear least squares problem.
C
C  SOLVE must first be called with PMQACT=0 and DONONL=ONLYFT=F so that SDREF
C    can be initialized for computing the Marquardt rows.
C  SDREF must be initialized to DRANGE for the test of SDREF below to be
C    effective.
C
C  LSTAGE = 1 for preliminary unregularized analysis with only 1 Gaussian
C             peak-broadener, 1 shift, NSIDES=0, and no priors.
C         = 2 for full analysis.
C
C  ONLYFT = T to only compute for plotting:
C             YFITRE(JY,0) = the fit to the data,
C             YFITRE(JY,JMETAB) = the contribution of metabolite JMETAB +
C                                 background to the fit,
C           and return without changing DAMAT, so that error estimates can be
C           computed from DAMAT from previous call.
C         = F for normal computation of solution and variance from the real
C             data (from zero-filling).
C
C  DONONL = T for computation of SOLUTN and OBJLIN
C         = F for evaluation of OBJECT & initial linear part of SOLUTN only.
C
C  Needs (in COMMON) from previous iteration:
C    SOLUTN(JPAR), JPAR=1,NLIN (if DONONL=T)
C    PARNLN(JNONL), JNONL=1,NNONL (always)
C
C  Columns:
c    NLESS>0 will reduce indices above NLIN by NLESS (not shown here):
C    1, NMETAB : nonnegative concentration coefficients
C    NMETAB+1, NMETAB+NBACKG=NLIN : background coefficients
C     NLIN+1, NLIN+2*NSIDES+ : lineshape coefficients
C     LPHAST, LPHAST+1: 0- and 1st-order phase corrections
C      LSHIST, LSHIST-1+NMETAB : shift corrections
C      LRT2ST, LRT2ST-1+NMETAB : delta(1/T2) corrections
C
C  Rows:
C    1, NY : real parts of data from zero-filling
C    NY+1, NY+NRATIO_USED : priors for CONC ratios
C    NY+NRATIO_USED+1, NY+NRATIO_USED+NMETAB : priors for shift corrections
C    NY+NRATIO_USED+NMETAB+1, NY+NRATIO_USED+2*NMETAB : priors for
C                                                       delta(1/T2) corrections
C    NY+2*NMETAB+NRATIO_USED+1, NY+2*NMETAB+NRATIO_USED+[0--2] = NROWDA:
c                                             priors for phase corrections
C    NROWDA+1, NROWDA+NBACKG : regularizor (if ALPHAB>0)
C    NROWDA+(NBACKG)+1, NROWDA+(NBACKG)+(NSIDE2+3): regularizor
C                                                   (if ALPHAS>0 and DONONL=T).
C    NROWDA+(NBACKG)+(NSIDE2+3)+1, NROWDA+(NBACKG)+(NSIDE2+3)+NNONL:
C      Marquardt rows (if PMQACT>0 and DONONL=T).
C
      INCLUDE 'lcmodel.inc'
      external penlty
C      COMPLEX CYFIT(MY)!CT1!CT2
C      LOGICAL LTEST!CT1!CT2
C      COMMON /BLT1/ CYFIT, LTEST!CT1!CT2
      SAVE BASIYF, DCEXOL, LSTOLD
      COMPLEX*16 BASIYF(1-MINCSD*MSIDES:MY+MINCSD*MSIDES,mmetab,2),
     1           basiyf_power(MY, mcoeff_power),
     1           DCDATA(MDATA,5), DCEXOL(MMETAB,2), DCEXUS, DCFACT,
     2           DCPHAS, DCSUM(2), DCTERM, DCYFIT
C      COMPLEX*16 CDEXP!IRIX
      DOUBLE PRECISION DAMARQ(MNONL), DEXPRE,
     1                 DFZERO, DPPINC, DPPM, DRHS(MROW),
     2                 DDTIME, DTIME, DWORK(MROW+MPAR), PENLTY, OBJTOT,
     3                 PMQACT, SQRTWT
      INTEGER LSTOLD(2)
      LOGICAL DONONL, LERROR, NEWEXP, ONLYFT, PRIORP, PRIORZ
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      COMMON DAMARQ, DCDATA, DRHS, DWORK
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C      CDEXP(DCTERM)=ZEXP(DCTERM)!IRIX
      CHSUBP='SOLVE'
      dcsum(1) = (0.d0,0.d0)
      dcsum(2) = (0.d0,0.d0)
      if (initialize_solve) then
         initialize_solve = .false.
         do 50 k = 1, 2
            lstold(k) = 0
            do 55 j = 1, mmetab
               dcexol(j, k) = (0.D0,0.D0)
 55         continue
 50      continue
      end if
      IF (LSTAGE.LE.0 .OR. LSTAGE.GE.3) CALL ERRMES (1, 5, CHSUBP)
      PRIORZ=.NOT.(FXDEGZ .OR. SDDEGZ.GE.45.)
      PRIORP=.NOT.FXDEGP
C     -------------------------------------------------------------------------
C     Indices starting with K are only used instead of those with L for
C       temporarily contracting DAMAT, GRAD & NONNEG before the call to PNNLS
C       and right after restoring these.  This only is needed when FXDEGZ or
C       FXDEGP = T.
c     SOLUTN comes out of PNNLS contracted.
C     Outside of SOLVE these arrays are all the full size.
C     PARNLN is never compressed.
C     -------------------------------------------------------------------------
      IF (FXDEGZ) THEN
         NLESS=1
         KDEGP=LPHAST
      ELSE
         NLESS=0
         KDEGP=LPHAST+1
      END IF
      IF (FXDEGP) NLESS=NLESS+1
      KSHIST=LSHIST-NLESS
      KRT2ST=LRT2ST-NLESS
      KNONL=NNONL-NLESS
C     -------------------------------------------------------------------------
C     Compute broadened basis in frequency-domain.
C     -------------------------------------------------------------------------
      DDTIME=DBLE(DELTAT)
      IF (LSTAGE .EQ. 1) THEN
C        ----------------------------------------------------------------------
C        DCDATA(JDATA,1) = data for individual metabolites
C                     2  = sum over all metabolites of conc*(metabolite data)
C                     3  = broadening and shifting factors for time-domain
C                          data.
c                     4  = shifting factors for time-domain data (without
c                          broadening -- when LSHAPE=F).
C                     5  = sum over all broadened (LSHAPE=T) metabolites of
c                          conc*(metabolite data)
C        ----------------------------------------------------------------------
         IF (DONONL) THEN
            DO 101 JDATA=1,NDATA
               DCDATA(JDATA,2)=(0.D0,0.D0)
               DCDATA(JDATA,5)=(0.D0,0.D0)
  101       CONTINUE
         END IF

c         write (6, 9101) PARNLN(LRT2ST) * tofwhm
c 9101    format ('Broadening FWHM =', 1pe13.4)

         DEXPRE=PARNLN(LRT2ST)**2
         DCEXUS=DCMPLX(PARNLN(LRT2ST),PARNLN(LSHIST))
         NEWEXP=DCEXUS.NE.DCEXOL(1,1) .OR. LSTOLD(1).NE.1
         IF (NEWEXP .OR. DONONL) THEN
            DTIME=0.D0
            IF (NEWEXP) THEN
               DO 102 JDATA=1,NDATA
                  DCDATA(JDATA,4)=CDEXP(DCMPLX(0.d0,
     1                                         -dtime*PARNLN(LSHIST)))
                  dcdata(jdata,3) = dexp(-dexpre * dtime**2) *
     1                              dcdata(jdata,4)
                  DTIME=DTIME+DDTIME
  102          CONTINUE
            END IF
            DO 103 JMETAB=1,NMETAB
c              ----------------------------------------------------------------
c              LSHAPE = T to do Gaussian broadening (LSTAGE=1).
c              ----------------------------------------------------------------
               if (lshape(jmetab)) then
                  DO 104 JDATA=1,NDATA
                     DCDATA(JDATA,1)=DCDATA(JDATA,3)*
     1                               BASIST(JDATA,JMETAB)
 104              CONTINUE
                  if (dononl) then
                     do 1042 jdata = 1, ndata
                        dcterm = SOLUTN(JMETAB)*DCDATA(JDATA,1)
                        DCDATA(JDATA,2)=DCDATA(JDATA,2) + dcterm
                        DCDATA(JDATA,5)=DCDATA(JDATA,5) + dcterm
 1042                continue
                  end if
               else
c                 -------------------------------------------------------------
c                 No broadening (LSHAPE = F).
c                 -------------------------------------------------------------
                  DO 1045 JDATA=1,NDATA
                     DCDATA(JDATA,1)=DCDATA(JDATA,4)*
     1                               BASIST(JDATA,JMETAB)
 1045             CONTINUE
                  if (dononl) then
                     DO 1047 JDATA=1,NDATA
                        DCDATA(JDATA,2)=DCDATA(JDATA,2) +
     1                                  SOLUTN(JMETAB)*DCDATA(JDATA,1)
 1047                continue
                  end if
               end if
               IF (NEWEXP) THEN
                  LSTOLD(1)=1
                  DCEXOL(1,1)=DCEXUS
                  CALL DCFFT_R (DCDATA, DCDATA, NDATA, LDWFFT,
     1                        DWFFTC)
                  JDATA=LDATST
                  DO 105 JY=1,NY
                     BASIYF(JY,JMETAB,1)=DCDATA(JDATA,1)
                     JDATA=JDATA+1
  105             CONTINUE
               END IF
  103       CONTINUE
         END IF
         IF (DONONL) THEN
C           -------------------------------------------------------------------
C           i*exp(-phase)*BASIYF(JY,1,2) = derivative wrt shift parameter.
C             exp(-phase)*BASIYF(JY,2,2) = derivative wrt broadening parameter.
C           BASIYF(*,*,2) from previous calls cannot be used, because they
C             contain concentrations, which change in every call.
C           -------------------------------------------------------------------
            DTIME=0.D0
            DO 106 JDATA=1,NDATA
               DCDATA(JDATA,1)=DTIME*DCDATA(JDATA,2)
               DCDATA(JDATA,2)=DTIME**2 * DCDATA(JDATA,5)
               DTIME=DTIME-DDTIME
  106       CONTINUE
            CALL DCFFT_R (DCDATA, DCDATA, NDATA, LDWFFT,
     1                  DWFFTC)
            CALL DCFFT_R (DCDATA(1,2), DCDATA(1,2), NDATA, LDWFFT,
     1                  DWFFTC)
            JDATA=LDATST
            DO 107 JY=1,NY
               BASIYF(JY,1,2)=DCDATA(JDATA,1)
               BASIYF(JY,2,2)=-2.D0*PARNLN(LRT2ST)*DCDATA(JDATA,2)
               JDATA=JDATA+1
  107       CONTINUE
         END IF
      ELSE
C        ----------------------------------------------------------------------
C        LSTAGE = 2.
C        ----------------------------------------------------------------------
         DO 110 JMETAB=1,NMETAB
            if (imethd .eq. 3) then
               dtime = 0.d0
               do 112 jdata = 1, ndata
                  dterm(1) = 0.d0
                  do 114 jpower = 1, npower(jmetab)
                     dterm(1) = dterm(1) -
     1                          parnln(lpowen(jmetab - 1) + jpower) *
     2                          tpower(jpower, jdata)
 114              continue
                  dtime = dtime - ddtime
                  dcdata(jdata, 1) = cdexp(dcmplx(dterm(1),
     1               PARNLN(LSHIST-1+JMETAB) * dtime)) *
     2               BASIST(JDATA,JMETAB)
 112           continue
            else
               DCEXUS=DCMPLX(PARNLN(LRT2ST-1+JMETAB),PARNLN(LSHIST-1+
     1                                                      JMETAB))
               IF (DCEXUS.EQ.DCEXOL(JMETAB,1) .AND. LSTOLD(1).EQ.2)
     1            GO TO 110
               LSTOLD(1)=2
               DCEXOL(JMETAB,1)=DCEXUS
               DCFACT=CDEXP(-DCEXUS*DDTIME)
               DCTERM=(1.D0,0.D0)
               DO 120 JDATA=1,NDATA
                  DCDATA(JDATA,1)=DCTERM*BASIST(JDATA,JMETAB)
                  DCTERM=DCTERM*DCFACT
 120           CONTINUE
            end if
            CALL DCFFT_R (DCDATA, DCDATA, NDATA, LDWFFT,
     1                    DWFFTC)
C           -------------------------------------------------------------------
C           BASIYF(JYSIDE,JMETAB,1) = shifted frequency-domain basis spectra
C                                     in region of interest with extensions
C                                     of INCSID*NSIDES points at each end.
C           -------------------------------------------------------------------
            JDATA=LDATST-INCSID*NSIDES
            DO 130 JYSIDE=1-INCSID*NSIDES,NY+INCSID*NSIDES
               BASIYF(JYSIDE,JMETAB,1)=DCDATA(JDATA,1)
               JDATA=JDATA+1
  130       CONTINUE
  110    CONTINUE
         IF (DONONL) THEN
C           -------------------------------------------------------------------
C           Compute derivative wrt delta(1/T2) of broadened frequency-domain
C             basis spectra.
C           -------------------------------------------------------------------
            if (imethd .eq. 3) then
C              ----------------------------------------------------------------
C              BASIYF(JY,JMETAB,2) = (derivative wrt shift of exponential
c                                    term) / -sqrt(-1)
C              ----------------------------------------------------------------
               do 150 jmetab = 1, nmetab
                  dtime = 0.d0
                  do 151 jdata = 1, ndata
                     dterm(1) = 0.d0
                     do 152 jpower = 1, npower(jmetab)
                        dterm(1) = dterm(1) -
     1                       parnln(lpowen(jmetab - 1) + jpower) *
     2                       tpower(jpower, jdata)
 152                 continue
                     dtime = dtime - ddtime
                     dcdata(jdata, 1) = dtime *
     1                  cdexp(dcmplx(dterm(1),
     2                           PARNLN(LSHIST-1+JMETAB) * dtime)) *
     3                  BASIST(JDATA,JMETAB)
 151              continue
                  CALL DCFFT_R (DCDATA, DCDATA, NDATA, LDWFFT,
     1                          DWFFTC)
                  jdata = ldatst
                  DO 153 JY = 1, NY
                     BASIYF(JY, jmetab, 2)=DCDATA(JDATA,1)
                     JDATA=JDATA+1
 153              CONTINUE
 150           continue
C              ----------------------------------------------------------------
C              BASIYF_power(Jy,jcoeff_power) = derivative wrt coefficient of
c                                              POWER
C              ----------------------------------------------------------------
               jcoeff_power = 0
               do 155 jmetab = 1, nmetab
                  do 156 kpower = 1, npower(jmetab)
                     jcoeff_power = jcoeff_power + 1
                     dtime = 0.d0
                     do 157 jdata = 1, ndata
                        dterm(1) = 0.d0
                        do 159 jpower = 1, npower(jmetab)
                           dterm(1) = dterm(1) -
     1                          parnln(lpowen(jmetab - 1) + jpower) *
     2                          tpower(jpower, jdata)
 159                    continue
                        dtime = dtime - ddtime
                        dcdata(jdata, 1) = -tpower(kpower, jdata) *
     1                     cdexp(dcmplx(dterm(1),
     2                              PARNLN(LSHIST-1+JMETAB) * dtime)) *
     3                     BASIST(JDATA,JMETAB)
 157                 continue
                     CALL DCFFT_R (DCDATA, DCDATA, NDATA, LDWFFT,
     1                             DWFFTC)
                     jdata = ldatst
                     DO 158 JY = 1, NY
                        BASIYF_power(JY, jcoeff_power)=DCDATA(JDATA,1)
                        JDATA=JDATA+1
 158                 CONTINUE
 156              continue
 155           continue
            else
               DO 160 JMETAB=1,NMETAB
                  DCEXUS=DCEXOL(JMETAB,1)
                  IF (DCEXUS.EQ.DCEXOL(JMETAB,2) .AND. LSTOLD(2).EQ.2)
     1               go TO 160
                  LSTOLD(2)=2
                  DCEXOL(JMETAB,2)=DCEXUS
                  DCFACT=CDEXP(-DCEXUS*DDTIME)
                  DTIME=0.D0
                  DCTERM=(1.D0,0.D0)
                  DO 170 JDATA=1,NDATA
                     DCDATA(JDATA,1)=DTIME*DCTERM*BASIST(JDATA,JMETAB)
                     DCTERM=DCTERM*DCFACT
                     DTIME=DTIME-DDTIME
 170              CONTINUE
                  CALL DCFFT_R (DCDATA, DCDATA, NDATA, LDWFFT,
     1                          DWFFTC)
C                 -------------------------------------------------------------
C                 BASIYF(JYSIDE,JMETAB,2) = derivative wrt gamma (in MRM) of
C                                           shifted frequency-domain basis in
C                                           spectral region of interest with
C                                           extensions of INCSID*NSIDES points
C                                           at each end.
C                 -------------------------------------------------------------
                  JDATA=LDATST-INCSID*NSIDES
                  DO 180 JYSIDE=1-INCSID*NSIDES,NY+INCSID*NSIDES
                     BASIYF(JYSIDE,JMETAB,2)=DCDATA(JDATA,1)
                     JDATA=JDATA+1
 180              CONTINUE
 160           CONTINUE
            END IF
         END IF
      END IF
C     -------------------------------------------------------------------------
C     Load DAMAT and DRHS, or YFITRE.
C     -------------------------------------------------------------------------
      DSSQ=0.D0
      IF (.NOT.ONLYFT) THEN
         IF (DONONL) THEN
            DO 202 JNONL=1,KNONL
               GRAD(JNONL)=0.D0
  202       CONTINUE
         END IF
         DO 204 JPAR=1,NPAR
            DO 205 IROW=1,MROW
               DAMAT(IROW,JPAR)=0.D0
  205       CONTINUE
  204    CONTINUE
         DO 206 IROW=1,MROW
            DRHS(IROW)=0.D0
  206    CONTINUE
      END IF
      DFZERO=1.D0
      DO 208 JNONL=1,NSIDE2
         DFZERO=DFZERO-PARNLN(JNONL)
  208 CONTINUE
      DPPM=DBLE(DELPPM(1))
      DPPINC=DBLE(PPMINC)
      DCPHAS=CDEXP(DCMPLX(0.D0,
     1                    dble(-PARNLN(LPHAST)-PARNLN(LPHAST+1)*DPPM)))
      DCFACT=CDEXP(DCMPLX(0.D0,dble(PARNLN(LPHAST+1)*DPPINC)))
      nrow = 0
      DO 210 JY=1,NY
         if (lcy_skip(jy)) go to 210
         nrow = nrow + 1
         IF (ONLYFT) YFITRE(NROW,0)=0.
         DCYFIT=(0.D0,0.D0)
         jcoeff_power = 0
         DO 220 JMETAB=1,NMETAB
c           -------------------------------------------------------------------
c            LSHAPE(JMETAB) = F to eliminate convolution with Lineshape
c                               function for JMETAB.
c           -------------------------------------------------------------------
            if (lshape(jmetab)) then
               DCSUM(1)=DFZERO*BASIYF(JY,JMETAB,1)
               IF (DONONL .AND. LSTAGE.EQ.2) DCSUM(2)=DFZERO*
     1                                             BASIYF(JY,JMETAB,2)
               JNONL=1
               DO 230 JYSIDE=JY-INCSID*NSIDES,JY+INCSID*NSIDES,INCSID
                  IF (JYSIDE .EQ. JY) GO TO 230
                  DCSUM(1)=DCSUM(1)+PARNLN(JNONL)*
     1                              BASIYF(JYSIDE,JMETAB,1)
                  IF (DONONL) DCSUM(2)=DCSUM(2)+PARNLN(JNONL)*
     1                                          BASIYF(JYSIDE,JMETAB,2)
                  JNONL=JNONL+1
 230           CONTINUE
            else
               DCSUM(1)=BASIYF(JY,JMETAB,1)
               IF (DONONL .AND. LSTAGE.EQ.2) DCSUM(2)=
     1                                       BASIYF(JY,JMETAB,2)
            end if
            DCSUM(1)=DCSUM(1)*DCPHAS
            IF (ONLYFT) THEN
               YFITRE(NROW,JMETAB)=SOLUTN(JMETAB)*real(REAL(DCSUM(1)))
               YFITRE(NROW,0)=YFITRE(NROW,0)+YFITRE(NROW,JMETAB)
            ELSE
C              ----------------------------------------------------------------
C              Load derivatives wrt concentration coefficients.
C              ----------------------------------------------------------------
               DAMAT(NROW,JMETAB)=DREAL(DCSUM(1))
               IF (DONONL) THEN
                  DCYFIT=DCYFIT+SOLUTN(JMETAB)*DCSUM(1)
C                 -------------------------------------------------------------
C                 Load derivatives wrt shift and delta(1/T2)
C                 -------------------------------------------------------------
                  IF (LSTAGE .EQ. 2) THEN
                     DCSUM(2)=DCSUM(2)*DCPHAS*SOLUTN(JMETAB)
                     DAMAT(NROW,NLIN+KSHIST-1+JMETAB)=-DIMAG(DCSUM(2))
                     if (imethd .eq. 3) then
                        do 240 kpower = 1, npower(jmetab)
                           jcoeff_power = jcoeff_power + 1
                           DAMAT(NROW,NLIN+KRT2ST-1+jcoeff_power) =
     1                        dreal(DCPHAS * SOLUTN(JMETAB) *
     2                        BASIYF_power(JY, jcoeff_power))
 240                    continue
                     else
                        DAMAT(NROW,NLIN+KRT2ST-1+JMETAB)=DREAL(DCSUM(2))
                     end if
                  ELSE IF (JMETAB .EQ. 1) THEN
                     DAMAT(NROW,NLIN+KRT2ST)=
     1                  DREAL(DCPHAS*BASIYF(JY,2,2))
                     DAMAT(NROW,NLIN+KSHIST)=
     1                  -DIMAG(DCPHAS*BASIYF(JY,1,2))
                  END IF
               END IF
            END IF
  220    CONTINUE
C        ----------------------------------------------------------------------
C        Background is assumed real.
C        ----------------------------------------------------------------------
         BACFIT=0.
         JSOL=NMETAB
         DO 250 JBACKG=1,NBACKG
            JSOL=JSOL+1
            DCTERM=DCPHAS*DBLE(BACKGR(JY,JBACKG))
            IF (ONLYFT) THEN
               BACFIT=BACFIT+SNGL(SOLUTN(JSOL))*real(REAL(DCTERM))
            ELSE
               DAMAT(NROW,JSOL)=DREAL(DCTERM)
               DCYFIT=DCYFIT+SOLUTN(JSOL)*DCTERM
            END IF
  250    CONTINUE
         IF (ONLYFT) THEN
            BACKRE(NROW)=BACFIT
            IF (SUBBAS) THEN
               YREAL(NROW)=REAL(CY(JY))-BACFIT
            ELSE
               YREAL(NROW)=REAL(CY(JY))
               DO 260 JMETAB=0,NMETAB
                  YFITRE(NROW,JMETAB)=YFITRE(NROW,JMETAB)+BACFIT
  260          CONTINUE
            END IF
            GO TO 390
         END IF
C        ----------------------------------------------------------------------
C        Right-hand side.
C        ----------------------------------------------------------------------
         DRHS(NROW)=DBLE(REAL(CY(JY)))
         IF (DONONL) THEN
C           -------------------------------------------------------------------
C           Derivatives wrt phase corrections.
C           -------------------------------------------------------------------
            IF (.NOT.FXDEGZ) DAMAT(NROW,NLIN+LPHAST)=DIMAG(DCYFIT)
            IF (.NOT.FXDEGP) DAMAT(NROW,NLIN+KDEGP)=DPPM*DIMAG(DCYFIT)
            DPPM=DPPM-DPPINC
         END IF
         IF (DONONL) THEN
C           -------------------------------------------------------------------
C           Derivatives wrt to lineshape coefficients
C           -------------------------------------------------------------------
            ICOL=NLIN
            DO 310 JYSIDE=JY-INCSID*NSIDES,JY+INCSID*NSIDES,INCSID
               IF (JYSIDE .EQ. JY) GO TO 310
               DCSUM(1)=(0.D0,0.D0)
               DO 320 JMETAB=1,NMETAB
                  if (lshape(jmetab)) DCSUM(1)=DCSUM(1)+SOLUTN(JMETAB)*
     1                                         (BASIYF(JYSIDE,JMETAB,1)-
     2                                          BASIYF(JY,JMETAB,1))
  320          CONTINUE
               ICOL=ICOL+1
               DAMAT(NROW,ICOL)=DREAL(DCSUM(1)*DCPHAS)
  310       CONTINUE
C           -------------------------------------------------------------------
C           Gradients.
C           -------------------------------------------------------------------
            DTERM(1)=-2.D0*(DRHS(NROW)-DREAL(DCYFIT))
            DO 350 JNONL=1,KNONL
               GRAD(JNONL)=GRAD(JNONL)+DTERM(1)*DAMAT(NROW,NLIN+JNONL)
  350       CONTINUE
         END IF
  390    DCPHAS=DCPHAS*DCFACT
C      IF (LTEST) CYFIT(JY)=DCYFIT!CT1!CT2
  210 CONTINUE
      IF (ONLYFT) RETURN
C     -------------------------------------------------------------------------
c     Append priors for CONC ratios.
c     Weighting according to SDRATI*CSUM  has been done.  So, only need to
c       weight elements of CPRIOR by SDREF
c     For (linear) CONC, the row is simply the original constraint.
c       RHS=0 (not rhs_orig - fit).
C     -------------------------------------------------------------------------
      if (sdref .lt. drange) then
         do 401 jratio = 1, nratio_used
            nrow = nrow + 1
            do 402 jmetab = 1, nmetab
               damat(nrow, jmetab) = sdref *
     1                               dble(cprior(jratio, jmetab))
 402        continue
 401     continue
      end if
      IF (DONONL .AND. LSTAGE.EQ.2) THEN
C        ----------------------------------------------------------------------
C        Append rows for priors.
C        EXRT2(JMETAB) = prior mean of delta(1/T2)
C        SDRT2(JMETAB) = prior standard deviation of delta(1/T2)
C        SDREF = rough estimate for SD of fit.  It is continually updated
C                to the minimum while LSTAGE=1 and during the Starting
C                Solution when LSTAGE=2 (i.e., if INISOL=T).
C        First append rows for priors for shifts.
C        SDSHIF(JMETAB) = prior standard deviation of shift (prior mean is
C                         assumed 0).  No special provision for a larger
C                         SD in the overall shift of the data is (or
C                         should) be made, since this can be effected by
C                         a shift in the lineshape coefficients.
C        ----------------------------------------------------------------------
         DO 404 JMETAB=1,NMETAB
            NROW=NROW+1
            JNONL=KSHIST-1+JMETAB
            IF (SDSHIF(JMETAB) .LE. 0.) CALL ERRMES (2, 4, CHSUBP)
            SQRTWT=SDREF/SDSHIF(JMETAB)
            DAMAT(NROW,NLIN+JNONL)=SQRTWT
            DRHS(NROW)=-SQRTWT*PARNLN(JNONL+NLESS)
            GRAD(JNONL)=GRAD(JNONL)-2.D0*DRHS(NROW)*SQRTWT
 404     CONTINUE
C        ----------------------------------------------------------------------
C        Append rows for priors for group shifts.
C        ----------------------------------------------------------------------
         do 450 jrow_group_shift = 1, nrow_group_shift
            nrow = nrow + 1
            sqrtwt = sdref / sdgroup_shift_row(jrow_group_shift)
c           -------------------------------------------------------------------
c           DTERM(1) = weighted residual
c           -------------------------------------------------------------------
            dterm(1) = 0.d0
            do 460 jmetab = 1, nmetab
               jnonl = kshist + jmetab - 1
               dterm(2) = cgroup_shift(jrow_group_shift, jmetab) *
     1                    sqrtwt
               damat(nrow, nlin + jnonl) = dterm(2)
               dterm(1) = dterm(1) - dterm(2) * parnln(jnonl + nless)
 460        continue
            drhs(nrow) = dterm(1)
            do 470 jnonl = kshist, kshist + nmetab - 1
               grad(jnonl) = grad(jnonl) - 2.d0 * dterm(1) *
     1                                     damat(nrow, nlin + jnonl)
 470        continue
 450     continue
C        ----------------------------------------------------------------------
C        Append rows for priors for delta(1/T2).
C        ----------------------------------------------------------------------
         if (imethd.eq.3) then
            jcoeff_power = 0
            do 480 JMETAB=1,NMETAB
                do 485 kpower = 1, npower(jmetab)
                   NROW=NROW+1
                   jcoeff_power = jcoeff_power + 1
                   jnonl = krt2st - 1 + jcoeff_power
                   IF (coeff_power_sd(kpower, jmetab) .LE. 0.d0)
     1                CALL ERRMES (9, 4, CHSUBP)
                   SQRTWT = sdref / coeff_power_sd(kpower, jmetab)
                   DAMAT(NROW, nlin + jnonl)=SQRTWT
                   DRHS(NROW)=-SQRTWT*PARNLN(jnonl + nless)
                   GRAD(jnonl)=GRAD(jnonl)-2.D0*DRHS(NROW)*SQRTWT
 485            continue
 480         continue
         else
            DO 490 JMETAB=1,NMETAB
               NROW=NROW+1
               JNONL=KRT2ST-1+JMETAB
               IF (SDRT2(JMETAB) .LE. 0.) CALL ERRMES (5, 4, CHSUBP)
               SQRTWT=SDREF/SDRT2(JMETAB)
               DAMAT(NROW,NLIN+JNONL)=SQRTWT
               DRHS(NROW)=SQRTWT*(EXRT2(JMETAB)-PARNLN(JNONL+NLESS))
               GRAD(JNONL)=GRAD(JNONL)-2.D0*DRHS(NROW)*SQRTWT
 490        CONTINUE
         END IF
      END IF
      IF (DONONL) THEN
C        ----------------------------------------------------------------------
C        Append rows for priors for phases.
C        ----------------------------------------------------------------------
         IF (PRIORZ) THEN
            NROW=NROW+1
            SQRTWT=SDREF/(SDDEGZ*RADIAN)
            DAMAT(NROW,NLIN+LPHAST)=SQRTWT
            DRHS(NROW)=SQRTWT*(EXDEGZ*RADIAN-PARNLN(LPHAST)-PHITOT(1))
            GRAD(LPHAST)=GRAD(LPHAST)-2.D0*DRHS(NROW)*SQRTWT
         END IF
         IF (PRIORP) THEN
            NROW=NROW+1
            SQRTWT=SDREF/(SDDEGP*RADIAN)
            DAMAT(NROW,NLIN+KDEGP)=SQRTWT
            DRHS(NROW)=SQRTWT*(EXDEGP*RADIAN-PARNLN(LPHAST+1)
     1                                      -PHITOT(2))
            GRAD(KDEGP)=GRAD(KDEGP)-2.D0*DRHS(NROW)*SQRTWT
         END IF
      END IF
      NROWDA=NROW
      if (imethd .eq. 2   .and.   lstage .eq. 2   .and.
     1    alphas .gt. 0.d0) then
c        ---------------------------------------------------------------------
c        IMETHD = 2; Append rows for this special case with linewidths
c                    (rather than lineshape) being regularized.  It
c                    contains concentration and must therefore also be
c                    done with linear analysis (DONONL=F & T).
c        No idea why DRHS & GRAD should be commented out below, but it only
c           works this way.
c        ---------------------------------------------------------------------
         do 495 jmetab = 1, nmetab
            nrow = nrow + 1
            jnonl = krt2st - 1 + jmetab
            sqrtwt = sdref * alphas / conc_expect(jmetab)
            dterm(1) = rt2min(jmetab) + rlrntz * parnln(jnonl + nless)
            if (ipowrg .eq. 1) then
               damat(nrow, jmetab) = sqrtwt * dterm(1)
            else
               damat(nrow, jmetab) = sqrtwt * dterm(1)**2
            end if
            if (dononl) then
               if (ipowrg .eq. 1) then
                  DAMAT(NROW,NLIN+JNONL) = sqrtwt * solutn(jmetab) *
     1                                     rlrntz
               else
                  DAMAT(NROW,NLIN+JNONL) = 2.d0 * sqrtwt *
     1               solutn(jmetab) * dterm(1) * rlrntz
               end if
cc               drhs(nrow) = -solutn(jmetab) * damat(nrow, jmetab)
cc               grad(jnonl) = grad(jnonl) - 2.0 * drhs(nrow) * rlrntz *
cc     1                                     sqrtwt * solutn(jmetab)
            end if
 495     continue
      end if
      IF (ALPHAB.GT.0.D0 .AND. SDREF.LT.DRANGE) THEN
C        ----------------------------------------------------------------------
C        Append rows for background regularizor, REGB.
C        ----------------------------------------------------------------------
         DO 510 JBACKG=1,NBACKG
            NROW=NROW+1
            DO 520 JREG=1,NBACKG
               DAMAT(NROW,NMETAB+JREG)=SDREF*ALPHAB*REGB(JBACKG,JREG)
  520       CONTINUE
  510    CONTINUE
      END IF
      IF (ALPHAS.GT.0.D0  .AND. DONONL   .and.   imethd .ne. 2   .and.
     1    nside2 .gt. 0) then
C        ----------------------------------------------------------------------
C        Append rows for regularizor for lineshape coefficients.
C        REGF is assumed to be for the lineshape coefficients with the
C           center coefficient eliminated by the equality constraint.
C           Therefore, the 1st 3 rows are assumed to have the constants 2,
C           -1, -1 on the rhs, rather than 0.
c        NSIDE2 = 0 when LSTAGE = 1, but could conceivably have NSIDE2=0
c                   in other cases; so above test is safer.
C        ----------------------------------------------------------------------
         DO 530 IROWF=1,NREGF
            NROW=NROW+1
            IF (IROWF .EQ. 1) THEN
               DTERM(1)=2.*SDREF*ALPHAS
            ELSE IF (IROWF .LE. 3) THEN
               DTERM(1)=-SDREF*ALPHAS
            ELSE
               DTERM(1)=0.
            END IF
            ICOL=NLIN
            DO 540 JNONL=1,NSIDE2
               DTERM(2)=SDREF*ALPHAS*REGF(IROWF,JNONL)
               DTERM(1)=DTERM(1)-DTERM(2)*PARNLN(JNONL)
               ICOL=ICOL+1
               DAMAT(NROW,ICOL)=DTERM(2)
 540        CONTINUE
            DRHS(NROW)=DTERM(1)
            ICOL=NLIN
            DO 545 JNONL=1,NSIDE2
               ICOL=ICOL+1
               GRAD(JNONL)=GRAD(JNONL)-2.D0*DTERM(1)*DAMAT(NROW,ICOL)
 545        CONTINUE
 530     CONTINUE
      end if
      IF (PMQACT.GT.0.D0 .AND. DONONL) THEN
C        ----------------------------------------------------------------------
C        Append Marquardt rows.
C        ----------------------------------------------------------------------
         IF (SDREF .GE. DRANGE) CALL ERRMES (6, 4, CHSUBP)
         RTMARQ=SQRT(SNGL(PMQACT))
         INONL=0
         DO 550 JNONL=1,NNONL
            IF ((FXDEGZ .AND. JNONL.EQ.LPHAST) .OR.
     1          (FXDEGP .AND. JNONL.EQ.LPHAST+1)) GO TO 550
            INONL=INONL+1
            NROW=NROW+1
            IF (DPARMQ(JNONL) .LE. 0.) CALL ERRMES (7, 4, CHSUBP)
            DAMARQ(INONL)=RTMARQ*SDREF/DPARMQ(JNONL)
            DAMAT(NROW,NLIN+INONL)=DAMARQ(INONL)
  550    CONTINUE
      END IF
      IF (DONONL) THEN
         NCOL=NPAR-NLESS
         IF (NLESS .GT. 0) THEN
C           -------------------------------------------------------------------
C           Compress NONNEG
C           -------------------------------------------------------------------
            IF (FXDEGZ .AND. .NOT.FXDEGP) NONNEG(NLIN+LPHAST)=
     1                                    NONNEG(NLIN+LPHAST+1)
            DO 560 JNONL=KSHIST,KNONL
               NONNEG(NLIN+JNONL)=NONNEG(NLIN+JNONL+NLESS)
  560       CONTINUE
         END IF
      ELSE
         NCOL=NLIN
      END IF
C     -------------------------------------------------------------------------
C     Compute optimal SOLUTN with PNNLS.
C     -------------------------------------------------------------------------
      CALL PNNLS (DAMAT, MROW, NROW, NCOL, DRHS, SOLUTN, OBJTOT, DWORK,
     1            DWORK(NPAR+1), INDCOL, IERROR, DRANGE, NONNEG, 0.D0,
     2            NDF)
      LERROR=IERROR.NE.1
      IF (.NOT.LERROR) THEN
         IF (PMQACT.GT.0.D0 .AND. DONONL) THEN
C           -------------------------------------------------------------------
C           Subtract Marquardt penalty from OBJTOT.
C           -------------------------------------------------------------------
            INONL=0
            DO 610 JNONL=1,NNONL
               IF ((FXDEGZ .AND. JNONL.EQ.LPHAST) .OR.
     1             (FXDEGP .AND. JNONL.EQ.LPHAST+1)) GO TO 610
               INONL=INONL+1
               OBJTOT=OBJTOT-(DAMARQ(INONL)*SOLUTN(NLIN+INONL))**2
  610       CONTINUE
         END IF
         IF (NLESS .GT. 0   .and.   dononl) THEN
C           -------------------------------------------------------------------
C           Restore (expand) NONNEG, SOLUTION & GRAD.
C           -------------------------------------------------------------------
            DO 612 JNONL=NNONL,LSHIST,-1
               NONNEG(NLIN+JNONL)=NONNEG(NLIN+JNONL-NLESS)
               SOLUTN(NLIN+JNONL)=SOLUTN(NLIN+JNONL-NLESS)
               GRAD(JNONL)=GRAD(JNONL-NLESS)
 612        CONTINUE
            IF (FXDEGZ .AND. .NOT.FXDEGP) THEN
               NONNEG(NLIN+LPHAST+1)=NONNEG(NLIN+LPHAST)
               SOLUTN(NLIN+LPHAST+1)=SOLUTN(NLIN+LPHAST)
               GRAD(LPHAST+1)=GRAD(LPHAST)
            END IF
            IF (FXDEGZ) THEN
               NONNEG(NLIN+LPHAST)=.FALSE.
               SOLUTN(NLIN+LPHAST)=0.D0
               GRAD(LPHAST)=0.D0
            END IF
            IF (FXDEGP) THEN
               NONNEG(NLIN+LPHAST+1)=.FALSE.
               SOLUTN(NLIN+LPHAST+1)=0.D0
               GRAD(LPHAST+1)=0.D0
            END IF
         END IF
         IF (.NOT.DONONL .AND. SDREF.LT.DRANGE .AND. LSTAGE.EQ.2) THEN
C           -------------------------------------------------------------------
C           Add penalties for shift and 1/T2 priors to OBJTOT.
C           -------------------------------------------------------------------
            jcoeff_power = 0
            DO 615 JMETAB=1,NMETAB
               OBJTOT=OBJTOT+(PARNLN(LSHIST-1+JMETAB)*SDREF/
     1                        SDSHIF(JMETAB))**2
               if (imethd .eq. 3) then
                  do 616 kpower = 1, npower(jmetab)
                     jcoeff_power = jcoeff_power + 1
                     jnonl = LRT2ST-1+jcoeff_power
                     objtot = objtot + (parnln(jnonl) * sdref /
     1                        coeff_power_sd(kpower, jmetab))**2
 616              continue
               else
                  objtot = objtot + ((EXRT2(JMETAB)-
     3                         PARNLN(LRT2ST-1+JMETAB))*SDREF/
     4                        SDRT2(JMETAB))**2
               end if
 615        CONTINUE
            do 617 jrow_group_shift = 1, nrow_group_shift
               dterm(1) = 0.d0
               do 618 jmetab = 1, nmetab
                  jnonl = lshist + jmetab - 1
                  dterm(1) = dterm(1) + parnln(jnonl) *
     1                       cgroup_shift(jrow_group_shift, jmetab)
 618           continue
               objtot = objtot + (sdref * dterm(1) /
     1                           sdgroup_shift_row(jrow_group_shift))**2
 617        continue
         END IF
         IF (.NOT.DONONL .AND. SDREF.LT.DRANGE) THEN
C           -------------------------------------------------------------------
C           Add penalties for priors for phases to OBJTOT.
C           (The expressions below are simplified from the original
C             EXDEG?*RADIAN and SDDEG?*RADIAN.)
C           -------------------------------------------------------------------
            IF (PRIORZ) OBJTOT=OBJTOT+((EXDEGZ-(PARNLN(LPHAST)+
     1                         PHITOT(1))/RADIAN)*SDREF/SDDEGZ)**2
            IF (PRIORP) OBJTOT=OBJTOT+((EXDEGP-(PARNLN(LPHAST+1)+
     1                         PHITOT(2))/RADIAN)*SDREF/SDDEGP)**2
         END IF
C        ----------------------------------------------------------------------
C        DSSQ = OBJTOT - (regularizor penalty)
C        ----------------------------------------------------------------------
         DSSQ= OBJTOT-PENLTY(ALPHAB, 0.D0, SOLUTN, PARNLN)
         if (ALPHAS .GT. 0.D0   .and.   imethd .eq. 2   .and.
     1       lstage .eq. 2   .and.   sdref .lt. drange) then
            if (dononl) then
               do 630 jmetab = 1, nmetab
                  jnonl = lrt2st - 1 + jmetab
                  dwork(jnonl) = solutn(nlin + jnonl) + parnln(jnonl)
 630           continue
c              ---------------------------------------------------------------
c              Get identical final results if DPY is replaced with PARNLN in
c                 next statement (or if it is skipped).
c              Here IMETHD=2, and ALPHAS component is already in the
c                 solution when DONONL=F; so OBJTOT+=PENLTY(ALPHAS) should not
c                 be done.  Otherwise, much worse, often no convergence.
c              OBJ* affect the output of "Rel. dec." & "Pred. dec." in and
c                   the Marquardt criteria in PLINLS.  Negative "Rel. dec."
c                   occur frequently in Prel.  It also determines RSTEP.
c                   When IMETHD=2, PENLTY(ALPHAS) is already in OBJTOT from
c                   PNNLS and does not need to be added in below.
c              DSSQ determines the interpolations for ALPHA in RFALSI and
c                   the convergence criterion in PLINLS.  However, analysis
c                   is independent of following statement; PENLTY(...ALPS...)
c                   only affects output penB; i.e., different PENLTY function
c                   for ALPHAS yields identical solution.  So, DSSQ is
c                   apparently only used when DONONL=F.
c              ---------------------------------------------------------------
              DSSQ=DSSQ-PENLTY(0.D0, ALPHAS, SOLUTN, dwork)

c              dterm(1) = PENLTY(0.D0, ALPHAS, SOLUTN, dwork)
c              write (lprint, 9630) dssq,
c     1            dterm(1),
c     2            solutn(nlin + jnonl),
c     1            dwork(jnonl), parnln(jnonl), nlin, jnonl, jmetab
c 9630         format (1p5e13.3, 3i5)
c              if (nmetab .ne. 98) stop

            else
c               OBJTOT=OBJTOT+PENLTY(0.D0, ALPHAS, SOLUTN, PARNLN)
C              DSSQ=DSSQ-PENLTY(0.D0, ALPHAS, SOLUTN, parnln)!<<<<
            end if
         end if
         IF (NSIDE2.GT.0 .AND. ALPHAS.GT.0.D0 .and. imethd.ne.2) THEN
            IF (DONONL) THEN
               DO 640 JSIDE2=1,NSIDE2
                  DPY(JSIDE2)=SOLUTN(NLIN+JSIDE2)+PARNLN(JSIDE2)
  640          CONTINUE
               DSSQ=DSSQ-PENLTY(0.D0, ALPHAS, SOLUTN, DPY)
            ELSE
               OBJTOT=OBJTOT+PENLTY(0.D0, ALPHAS, SOLUTN, PARNLN)
            END IF
         END IF
         IF (DONONL) THEN
            OBJLIN=OBJTOT
         ELSE
            OBJECT=OBJTOT
C           -------------------------------------------------------------------
C           Correct NDF for KNONL nonlinear parameters.
C           -------------------------------------------------------------------
            NDF=NDF+KNONL
            IF (NROWDA.GT.NDF .AND. DSSQ.GT.0.D0) THEN
               STDDEV=DSQRT(DSSQ/DBLE(NROWDA-NDF))
C              ----------------------------------------------------------------
C              SDREF = rough estimate for SD of fit.  It is continually
C                      updated to the minimum while LSTAGE=1 and during the
C                      Starting Solution when LSTAGE=2 (i.e., if INISOL=T).
C              SDREF is used for weighting the priors, the regularizors, and
C                the Marquardt rows.
C              The continuous updating of SDREF will cause an extra decrease
C                in OBJECT during the Reference Solution, and this may require
C                extra iterations.
C              ----------------------------------------------------------------
               IF (INISOL) SDREF=DMIN1(SDREF,STDDEV)
            ELSE
               CALL ERRMES (8, 3, CHSUBP)
            END IF
         END IF
      END IF
      END
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE SAVBES (ILEVEL)
C
C  ILEVEL = 1 for saving the best solution from a Regula Falsi analysis for a
C             given alpha-ratio.
C         = 2 for saving the best of all solutions so far for the final output
C             and also loading PARNLN with PARBES.
c          =3 for saving the rephased solution with the max ALPHAB
c          =-3 for loading the *(3) values into *(2)
C
      INCLUDE 'lcmodel.inc'
      CHSUBP='SAVBES'
      IF (ILEVEL .EQ. 1) THEN
         PENBES(1)=OBJECT-DSSQ
         IF (SNGL(ALPHAB).LT.ALPBPN .AND. SDREF.LT.DRANGE) PENBES(1)=
     1        PENBES(1)+PNALPB*SDREF**2
         SSQBES(1)=DSSQ
         SDBEST(1)=STDDEV
         PMQBES(1)=PMQSAV
         ALPBBS(1)=ALPHAB
         ALPSBS(1)=ALPHAS
         DO 110 JNONL=1,NNONL
            PARBES(JNONL,1)=PARNLN(JNONL)
  110    CONTINUE
         DO 120 JPAR=1,NLIN
            SOLBES(JPAR,1)=SOLUTN(JPAR)
  120    CONTINUE
         phitot_sav(1, 1) = phitot(1)
         phitot_sav(1, 2) = phitot(2)
         do 130 j = 1, ny
            cy_sav(j, 1) = cy(j)
 130     continue

      ELSE IF (ILEVEL .EQ. 2) THEN
         PENBES(2)=PENBES(1)
         SSQBES(2)=SSQBES(1)
         SDBEST(2)=SDBEST(1)
         PMQBES(2)=PMQBES(1)
         ALPBBS(2)=ALPBBS(1)
         ALPSBS(2)=ALPSBS(1)
         DO 210 JNONL=1,NNONL
            PARBES(JNONL,2)=PARBES(JNONL,1)
            PARNLN(JNONL)=PARBES(JNONL,1)
  210    CONTINUE
         DO 220 JPAR=1,NLIN
            SOLBES(JPAR,2)=SOLBES(JPAR,1)
  220    CONTINUE
         phitot_sav(2, 1) = phitot_sav(1, 1)
         phitot_sav(2, 2) = phitot_sav(1, 2)
         do 230 j = 1, ny
            cy_sav(j, 2) = cy_sav(j, 1)
 230     continue

      else
         if (iabs(ilevel) .lt. 3   .or.
     1       iabs(ilevel) .gt. mmdegp3 + 7) call errmes (1, 5, chsubp)
         if (ilevel .gt. 0) then
            PENBES(ilevel)=PENBES(2)
            SSQBES(ilevel)=SSQBES(2)
            SDBEST(ilevel)=SDBEST(2)
            PMQBES(ilevel)=PMQBES(2)
            ALPBBS(ilevel)=ALPBBS(2)
            ALPSBS(ilevel)=ALPSBS(2)
            DO 310 JNONL=1,NNONL
               PARBES(JNONL,ilevel)=PARBES(JNONL,2)
               PARNLN(JNONL)=PARBES(JNONL,2)
 310        CONTINUE
            DO 320 JPAR=1,NLIN
               SOLBES(JPAR,ilevel)=SOLBES(JPAR,2)
 320        CONTINUE
            phitot_sav(ilevel, 1) = phitot_sav(2, 1)
            phitot_sav(ilevel, 2) = phitot_sav(2, 2)
            do 330 j = 1, ny
               cy_sav(j, ilevel) = cy_sav(j, 2)
 330        continue
         else
            PENBES(2)=PENBES(-ilevel)
            SSQBES(2)=SSQBES(-ilevel)
            SDBEST(2)=SDBEST(-ilevel)
            PMQBES(2)=PMQBES(-ilevel)
            ALPBBS(2)=ALPBBS(-ilevel)
            ALPSBS(2)=ALPSBS(-ilevel)
            DO 350 JNONL=1,NNONL
               PARBES(JNONL,2)=PARBES(JNONL,-ilevel)
               PARNLN(JNONL)=PARBES(JNONL,-ilevel)
 350        CONTINUE
            DO 360 JPAR=1,NLIN
               SOLBES(JPAR,2)=SOLBES(JPAR,-ilevel)
 360        CONTINUE
            phitot_sav(2, 1) = phitot_sav(-ilevel, 1)
            phitot_sav(2, 2) = phitot_sav(-ilevel, 2)
            do 370 j = 1, ny
               cy_sav(j, 2) = cy_sav(j, -ilevel)
 370        continue
         end if
      end if
      END
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE FINOUT ()
C
C  Output final summary.
C
      INCLUDE 'lcmodel.inc'
c     -----------------------------------------------------------------------
c     Excel only allows up to 256 columns; so must have MCSV <= 254/3 = 84 or
c        allow fewer than the three types (CONC, %SD, /NAMREL).
c     -----------------------------------------------------------------------
      external ilen, ldegmx
      parameter (mcsv=84)
      CHARACTER csv_element*56, csv_line(2)*(mcsv * 56 + 10),
     1          FMTC*8, fmtdat*(mchfmt), fmtpm*10, FMTR*6, id*(mchid)
      complex cfactor
      DOUBLE PRECISION DAPOSI(MPAR,MPAR), DSUM, dwork(mdwork_finout),
     1                 PHIOLD(2)
      integer nchar_metab(2)
      LOGICAL bruker, EFORM, INCLUD(MPAR), LDEGMX, LERROR, first_row,
     1        seqacq, skip_line
      REAL ERRCON(MCONC)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      COMMON DAPOSI, INCLUD, ERRCON, csv_line, dwork
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      save first_row
      data first_row/.true./
      namelist /seqpar/ hzpppm
      namelist /nmid/ bruker, fmtdat, id, seqacq, tramp, volume
      EFORM(TERM)=(abs(TERM).GT.999.999 .OR. ABS(TERM).lt..0995) .AND.
     1            TERM.NE.0.
      CHSUBP='FINOUT'
C     -------------------------------------------------------------------------
C     Rephase data and repeat analysis for plotting.
C     -------------------------------------------------------------------------
      IF (DOFULL) THEN
         ISTAGE=3
      ELSE
         ISTAGE=1
      END IF
      LSTAGE=MIN0(ISTAGE,2)
      DO 110 JREPHA=1,MREPHA(2)
         IF (.NOT.LDEGMX(2)) GO TO 140
         IF (LPRINT .GT. 0) WRITE (LPRINT,5110) JREPHA
 5110    FORMAT (////20X,
     1               'Rephase data for plotting and repeat analysis',
     2                5X, 'Iteration', I2)
         ALPHAB=ALPBBS(2)
         ALPHAS=ALPSBS(2)
         PHIOLD(1)=PARBES(LPHAST,2)
         PHIOLD(2)=PARBES(LPHAST+1,2)
         CALL REPHAS ()
         CALL PLINLS (ISTAGE, IERROR)
         IF (OBJECT .GE. DRANGE) THEN
            CALL ERRMES (1, 3, CHSUBP)
            PARBES(LPHAST,2)=-PHIOLD(1)
            PARBES(LPHAST+1,2)=-PHIOLD(2)
            CALL REPHAS()
            PARBES(LPHAST,2)=PHIOLD(1)
            PARBES(LPHAST+1,2)=PHIOLD(2)
            GO TO 140
         ELSE
            CALL SAVBES (1)
            CALL SAVBES (2)
         END IF
  110 CONTINUE
      IF (LDEGMX(2) .AND. MREPHA(2).GT.0) CALL ERRMES (2, 3, CHSUBP)
C     -------------------------------------------------------------------------
C     Reproduce best solution and matrix for covariance from values from
C       SAVBES.
C     Covariance matrix will actually correspond to the first stage of the
C       next iteration with DONONL=T.  Therefore, NONNEG is reset below to
C       remove the non-binding constraints.
C     The following are preserved throughout and do not have to be saved or
c       restored: EXDEGP & EXDEGZ
C     -------------------------------------------------------------------------
  140 DO 150 JPAR=1,NLIN
         SOLUTN(JPAR)=SOLBES(JPAR,2)
         NONNEG(JPAR)=SOLUTN(JPAR) .EQ. 0.D0
  150 CONTINUE
      DO 160 JNONL=1,NNONL
         PARNLN(JNONL)=PARBES(JNONL,2)
  160 CONTINUE
      do 161 j = 1, ny
         cy(j) = cy_sav(j, 2)
 161  continue
      phitot(1) = phitot_sav(2, 1)
      phitot(2) = phitot_sav(2, 2)
      ALPHAB=ALPBBS(2)
      ALPHAS=ALPSBS(2)
c     ------------------------------------------------------------------------
c     Save solution with SAVBES(3).  This overwrites old SAVBES(3) from
c        max ALPHAB solution, which is not needed anymore.
c     ------------------------------------------------------------------------
      CALL SOLVE (LSTAGE, .TRUE., PMQBES(2), .FALSE., LERROR)
      IF (LERROR) CALL ERRMES (3, 4, CHSUBP)
C     -------------------------------------------------------------------------
C     Now call SOLVE to get the following for plotting:
C     YREAL(JY) = real part of data, JY=1,NYuse
C     YFITRE(JY,0) =           fit
C     YFITRE(JY,JMETAB) = contribution of metabolite JMETAB and background to
C                         fit.
C     BACKRE(JY) = background
C     -------------------------------------------------------------------------
      DO 165 JPAR=1,NLIN
         SOLUTN(JPAR)=SOLBES(JPAR,2)
  165 CONTINUE
      CALL SOLVE (LSTAGE, .FALSE., 0.D0, .TRUE., LERROR)
      IF (LERROR) CALL ERRMES (4, 4, CHSUBP)
      ISTAGO=3
      IF (NSIDES .GT. 0) THEN
C        ----------------------------------------------------------------------
C        Print out lineshape smoothed with DGAUSS and use this to estimate
C          FWHMLS = approx. fwhm of lineshape.
C        DWORK(NSIDE2+3+1+JNONL) = smoothed lineshape at point JNONL.
C        The ordering of the lineshape is reversed for the plot.
C        ----------------------------------------------------------------------
         J=NEXTRE (PARNLN, NSIDE2, DWORK, DGAUSS, THRLIN, imethd)
         JNONL=NSIDE2+2
         DO 180 J=1,NSIDE2+1
            CPY(J)=INCSID*FLOAT(NSIDES+1-J)
            JNONL=JNONL-1
            CPY(NSIDE2+1+J)=SNGL(DWORK(NSIDE2+4+JNONL))
  180    CONTINUE
         HALFMX=-RRANGE
         DO 200 J=1,NSIDE2+1
            HALFMX=amax1(CPY(NSIDE2+1+J),halfmx)
  200    CONTINUE
         HALFMX=.5*HALFMX
         DO 210 jleft=1,NSIDE2+1
            IF (CPY(NSIDE2+1+jleft) .gE. HALFMX) GO TO 215
  210    CONTINUE
  215    DO 220 jright=NSIDE2+1,1,-1
            IF (CPY(NSIDE2+1+jright) .gE. HALFMX) GO TO 225
  220    CONTINUE
  225    FWHMLS=FLOAT(INCSID*(Jright-jleft+1))*PPMINC
         IF (LPRINT .GT. 0) THEN
            WRITE (LPRINT,5180) FWHMLS
 5180       FORMAT (////' Lineshape coefficients', 10X,
     1                  '(Approx. FWHM =', F6.3, ' ppm)')
            CALL PLPRIN (CPY, CPY(NSIDE2+1+1), CPY, NSIDE2+1, .TRUE.,
     1                   LPRINT, RRANGE, 0, 0, 0, CPY, .FALSE.)
         END IF
      END IF
C     -------------------------------------------------------------------------
C     Start compuation of error estimates and correlation coefficients.
C     First invert the NDF**2 upper triangular factor in DAMAT from PNNLS
C       onto itself and then square it using algorithm from Lawson & Hanson
C       pp. 68-69 to form the covariance matrix.
C     INDCOL(JDF) = the column no. of the JDFth parameter in the positive
C                     set; i.e., the column down to the diagonal has JDF
C                     elements.  INDCOL comes from PNNLS.
C     DAPOSI(JDF,KDF) = covariance between SOLUTN(INDCOL(JDF)) and
C                                          SOLUTN(INDCOL(KDF)).
C     -------------------------------------------------------------------------
      DO 310 I=1,NDF
         II=INDCOL(I)
         DAMAT(I,II)=1.D0/DAMAT(I,II)
  310 CONTINUE
      DO 320 I=1,NDF-1
         DO 330 J=I+1,NDF
            IJ=INDCOL(J)
            DSUM=0.D0
            DO 340 L=I,J-1
               IL=INDCOL(L)
               DSUM=DSUM+DAMAT(I,IL)*DAMAT(L,IJ)
  340       CONTINUE
            DAMAT(I,IJ)=-DAMAT(J,IJ)*DSUM
  330    CONTINUE
  320 CONTINUE
      DO 350 I=1,NDF
         DO 360 J=I,NDF
            DSUM=0.D0
            DO 370 L=J,NDF
               IL=INDCOL(L)
               DSUM=DSUM+DAMAT(I,IL)*DAMAT(J,IL)
  370       CONTINUE
            DAPOSI(I,J)=DSUM
            DAPOSI(J,I)=DSUM
  360    CONTINUE
  350 CONTINUE
C     -------------------------------------------------------------------------
C     CONCEN(NCONC-by-1) = BMAT(NCONC-by-NDF) * SOLUTN(NDF-by-1).
C     BMAT(JCONC,JDF) = 1 or 0, and is not expicitly formed, but rather
C                          determined by LCOMPO.
C     Cov_CONCEN = covariance between CONCEN(JCONC) and CONCEN(KCONC),
C                  JCONC.LE.KCONC
C                = BMAT * Cov_SOLUTN *BMAT**T, where Cov_SOLUTN is in DAPOSI.
C     DAMAT(JDF,KDF) = Cov_SOLUTN * BMAT**T
C     -------------------------------------------------------------------------
      DO 410 ICOL=1,NCONC
         DO 430 JDF=1,NDF
            DO 440 JCOMPO=1,NCOMPO(ICOL)
               INCLUD(JDF)=INDCOL(JDF) .EQ. LCOMPO(JCOMPO,ICOL)
               IF (INCLUD(JDF)) GO TO 430
  440       CONTINUE
  430    CONTINUE
         DO 450 IROW=1,NDF
            DSUM=0.D0
            DO 460 JDF=1,NDF
               IF (INCLUD(JDF)) DSUM=DSUM+DAPOSI(IROW,JDF)
  460       CONTINUE
            DAMAT(IROW,ICOL)=DSUM
  450    CONTINUE
  410 CONTINUE
C     -------------------------------------------------------------------------
C     DAPOSI(JCONC,KCONC) = covariance between CONCEN(JCONC) and
C                                              CONCEN(KCONC), JCONC.LE.KCONC
C                        = BMAT * DAMAT
C     -------------------------------------------------------------------------
      DO 470 IROW=1,NCONC
         DO 480 JDF=1,NDF
            DO 490 JCOMPO=1,NCOMPO(IROW)
               INCLUD(JDF)=INDCOL(JDF) .EQ. LCOMPO(JCOMPO,IROW)
               IF (INCLUD(JDF)) GO TO 480
  490       CONTINUE
  480    CONTINUE
         DO 510 ICOL=IROW,NCONC
            DSUM=0.D0
            DO 520 JDF=1,NDF
               IF (INCLUD(JDF)) DSUM=DSUM+DAMAT(JDF,ICOL)
  520       CONTINUE
            DAPOSI(IROW,ICOL)=DSUM
  510    CONTINUE
  470 CONTINUE
C     -------------------------------------------------------------------------
C     ERRCON(JCONC) = standard error estimate for CONCEN(JCONC) (temporarily
C                     not scaled by SDBEST(2) until after the
C                     correlation coefficients have been calculated).
C     -------------------------------------------------------------------------
      DO 530 JCONC=1,NCONC
         CONCEN(JCONC)=0.
         DO 540 JCOMPO=1,NCOMPO(JCONC)
            CONCEN(JCONC)=CONCEN(JCONC)+SOLBES(LCOMPO(JCOMPO,JCONC),2)
  540    CONTINUE
         TERM=DAPOSI(JCONC,JCONC)
         IF (TERM .LT. 0.) CALL ERRMES (5, 4, CHSUBP)
         ERRCON(JCONC)=SQRT(TERM)
  530 CONTINUE
C     -------------------------------------------------------------------------
C     DAPOSI(IROW,ICOL) = correlation coefficient between CONCEN(IROW) and
C                         CONCEN(ICOL), IROW<ICOL.
C     The output is in the form of the lower triangle.
C     -------------------------------------------------------------------------
 5560 FORMAT (//////20X,'Correlation coefficients')
      IF (LPRINT .GT. 0) WRITE (LPRINT,5560)
 5565 FORMAT (/(13X,17(1X,A6)))
      IF (LPRINT .GT. 0) WRITE (LPRINT,5565) (NACOMB(IROW),
     1                                        IROW=1,NCONC-1)
      DO 560 ICOL=1,NCONC
         DO 570 IROW=1,ICOL-1
            TERM=ERRCON(IROW)*ERRCON(ICOL)
            IF (TERM .LE. 0.) THEN
               DAPOSI(IROW,ICOL)=0.
            ELSE
               DAPOSI(IROW,ICOL)=DAPOSI(IROW,ICOL)/TERM
            END IF
  570    CONTINUE
 5570    FORMAT (1X,A11,17F7.3/(12X,17F7.3))
         IF (ICOL.GT.1 .AND. LPRINT .GT. 0) WRITE (LPRINT,5570)
     1         NACOMB(ICOL), (DAPOSI(IROW,ICOL),IROW=1,ICOL-1)
  560 CONTINUE
 5571 FORMAT ((13X,17(1X,A6)))
      IF (LPRINT .GT. 0) WRITE (LPRINT,5571) (NACOMB(IROW),
     1                                        IROW=1,NCONC-1)
C     -------------------------------------------------------------------------
c     Output number of SDs that CONC ratios deviate from prior expectation
c       values.
c     Priors are of form in 3rd line:
c       c_num / c_sum = exrati +- sdrati
c       c_num - c_sum * exrati = 0 +- c_sum * sdrati
c       [1 / (sdrati * csum)] [c_num - c_sum_true * exrati] = 0 +- 1
c       where (the approximate) CSUM is from the perliminary analysis with
c       ALP*ST.
c     FSD_CORR = sd_true / SD_USED = CSUM / CSUM_TRUE = factor to multiply
c               SD to correct for this approximation.
c     FSD_CORR < 1 means that the weighting was too strong.
C     -------------------------------------------------------------------------
      if (min0(nratio_used, lprint, ipdump - 2) .gt. 0) then
         write (lprint, 5572)
 5572    format (///5x, 'SDs', 3x, 'Corr Factor', 3x,
     1           'Concentration Ratio')
         do 572 jratio = 1, nratio_used
            csum = cprior(jratio, lmetab_prior(jratio)) *
     1             sdrati(jratio)
c           -------------------------------------------------------------------
c           Error -- neither of the above terms can be zero.
c           -------------------------------------------------------------------
            if (csum .le. 0.) call errmes (12, 5, chsubp)
            csum = 1. / csum
            prior_sum = sqrtwt_ratio_used(jratio) *
     1                  concen(lmetab_prior(jratio))
            sd_used = 0.
            do 573 jmetab = 1, nmetab
               term = cprior(jratio, jmetab) * concen(jmetab)
               sd_used = sd_used + term
               prior_sum = prior_sum - term
 573        continue
            if (prior_sum .le. 0.) then
               fsd_corr = 999.
            else
c              ----------------------------------------------------------------
c              csum_true = prior_sum * sdrati(jratio) * csum / exrati(jratio)
c              fsd_corr = csum / csum_true
c              ----------------------------------------------------------------
               fsd_corr = exrati(jratio) / (prior_sum * sdrati(jratio))
            end if
            len_chrato = ilen(chrato(jratio))
            write (lprint, 5573) sd_used, fsd_corr,
     1                           chrato(jratio)(:len_chrato)
 5573       format (f8.1, g14.2, 3x, a)
 572     continue
      end if
C     -------------------------------------------------------------------------
C     Output table of CONCEN and errors.  Load TABLE for plotting.
C     PCERR = standard percent error estimate for CONCEN(JCONC).
C     -------------------------------------------------------------------------
      NTABLE=NCONC+1
      IF (LCOORD .GT. 0) WRITE (LCOORD,5581) NTABLE
 5581 FORMAT (1X,I2,' lines in following concentration table = NCONC+1')
      IF (LTABLE .GT. 0) WRITE (LTABLE,6581) NTABLE
 6581 FORMAT (/'$$CONC',I3,
     1        ' lines in following concentration table = NCONC+1')
      LINTBL=1
      IPCERR(1)=999
      ratio_outlier(1) = .false.
      FACREL=0.
      DO 574 JCONC=1,NCONC
         IF ((NAMREL.EQ.NACOMB(JCONC)   .or.
     1       namrel .eq. nacom2(jconc))   .and.    CONCEN(JCONC).GT.0.)
     2      THEN
            FACREL=CONREL/CONCEN(JCONC)
            GO TO 575
         END IF
  574 CONTINUE
c     -------------------------------------------------------------------------
c     NAMREL not in NACOMB.  Check for synonyms
c     -------------------------------------------------------------------------
      do 5742 jconc = 1, nconc
         do 5744 jsyn = 1, mpmet
            IF (SYNUS1(1,JSYN).EQ.' ' .OR. SYNUS1(2,JSYN).EQ.' ')
     1           GO TO 5742
            IF (((SYNUS1(1,JSYN) .EQ. namrel   .AND.
     1            SYNUS1(2,JSYN) .EQ. nacomb(jconc))   .OR.
     2           (SYNUS1(2,JSYN) .EQ. nacomb(jconc)   .AND.
     3            SYNUS1(1,JSYN) .EQ. namrel))   .and.
     4          CONCEN(JCONC) .GT. 0.) then
              namrel = nacomb(jconc)
              FACREL=CONREL/CONCEN(JCONC)
              GO TO 575
           END IF
 5744   continue
 5742 continue
c     -----------------------------------------------------------------------
c     Use NAMREL='Cr+PCr' or 'Cre+PCr' instead of only Cr or Cre, if PCr is
c       also present.
c     This can be blocked by using CHCOMB(9)='PCr+Cr' instead of the default
c       'Cr+PCr'
c     -----------------------------------------------------------------------
  575 if (namrel .eq. 'Cr'  .or.  namrel .eq. 'Cre') then
         do 576 jconc = 1, nconc
            if ((nacomb(jconc) .eq. 'Cr+PCr'  .or.
     1           nacomb(jconc) .eq. 'Cre+PCr')  .and.
     2          concen(jconc) .gt. 0.) then
               namrel = nacomb(jconc)
               FACREL=CONREL/CONCEN(JCONC)
               go to 579
            end if
 576     continue
      end if
c     -----------------------------------------------------------------------
c     Use NAMREL='GPC+PCh+Cho' or as many as present, if fewer are in NAMREL.
c     This can be blocked by ordering the names differently in CHCOMB.
c     The ordering of the Metabolite Name pairs below must be that in CHCOMB.
c     -----------------------------------------------------------------------
      if (namrel .eq. 'PCh+GPC') namrel = 'GPC+PCh'
      if (namrel .eq. 'Cho+GPC') namrel = 'GPC+Cho'
      if (namrel .eq. 'Cho+PCh') namrel = 'PCh+Cho'
      if (namrel .eq. 'GPC+PCh'  .or.  namrel .eq. 'GPC+Cho'   .or.
     1    namrel .eq. 'PCh+Cho') then
          do 577 jconc = 1, nconc
            if (nacomb(jconc) .eq. 'Cho+GPC+PCh'  .and.
     1          concen(jconc) .gt. 0.) then
               namrel = nacomb(jconc)
               FACREL=CONREL/CONCEN(JCONC)
               go to 579
            end if
 577     continue
      end if
      if (namrel .eq. 'GPC'  .or.  namrel .eq. 'PCh'   .or.
     1    namrel .eq. 'Cho') then
         do 578 jconc = 1, nconc
            if ((nacomb(jconc) .eq. 'GPC+PCh'   .or.
     1           nacomb(jconc) .eq. 'GPC+Cho'   .or.
     2           nacomb(jconc) .eq. 'PCh+Cho'   .or.
     3           nacomb(jconc) .eq. 'Cho+GPC+PCh')   .and.
     4           concen(jconc) .gt. 0.) then
               namrel = nacomb(jconc)
               FACREL=CONREL/CONCEN(JCONC)
               go to 579
            end if
 578     continue
      end if
 579  do 5792 jpage = 1, 2
         nchar_metab(jpage) = nchlin(jpage) - 22
         if (nchar_metab(jpage) .lt. 12) then
            IF (NAMREL(5:6) .NE. '  ') THEN
               WRITE (TABLE(1,JPAGE),5582) NAMREL
 5582          FORMAT (3X, 'Conc.', 2X, '%SD', ' /', A6, 2X, 'Metab.')
            ELSE
               WRITE (TABLE(1,JPAGE),5583) NAMREL
 5583          FORMAT (3X, 'Conc.', 2X, '%SD', '   /', A4, 2X, 'Metab.')
            END IF
         else
            IF (NAMREL(5:6) .NE. '  ') THEN
               WRITE (TABLE(1,JPAGE),5584) NAMREL
 5584          FORMAT (3X, 'Conc.', 2X, '%SD', ' /', A6, 2X,
     1                 'Metabolite')
            ELSE
               WRITE (TABLE(1,JPAGE),5585) NAMREL
 5585          FORMAT (3X, 'Conc.', 2X, '%SD', '   /', A4, 2X,
     1                 'Metabolite')
            END IF
         end if
 5792 continue
      len_namrel = 0
      if (lcsv .gt. 0) then
         if (first_row   .and.   ioffset_current_in .le. 0) then
            csv_line(1) = 'Row, Col'
         end if
         len_namrel = ilen(namrel)
         write (csv_line(2), 5586) idrow, idcol
 5586    format (i3, ', ', i3)
      end if
      if (lprint .gt. 0) then
         if (.not.fxdegp   .and.   ndegppm3_used .gt. 0)
     1      write (lprint, 5603) (degp_degp(j), ssq_degp(j),
     2                            alpb_degp(j), dist_degp(j),
     3                           j = 0, ndegppm3_used)
 5603       format(///'  DEGPPM', 8x, 'SSQ', 5x,
     1             'ALPHAB   Spline Distance'/(0pf8.2, 1p2e11.2, e18.2))

         write (lprint, 5587)
 5587    format (///14x, '1000Shift', 3x, 'SDs', 2x,
     1              'delta(1/T2)', 3x, 'SDs', 8x, 'CONC',
     2              2x, '%SD')
      end if
      ncsv = 0
      DO 580 Jline = 1,NCONC
         lconc = iconc_line_table(jline)
         skip_line = onlyco   .and.   lconc .le. nmetab
         if (skip_line) then
            ipcerr(lintbl) = -99
            go to 581
         end if
c        --------------------------------------------------------------------
c        Output concentration table.
c        --------------------------------------------------------------------
         ncsv = ncsv + 1
         LINTBL=LINTBL+1
         ERRCON(LCONC)=ERRCON(LCONC)*SDBEST(2)
         RELCON=FACREL*CONCEN(LCONC)
         IF (CONCEN(LCONC) .LE. 0.) THEN
            concen(lconc) = 0.
            PCERR=9999.
         ELSE
            PCERR=100.*ERRCON(LCONC)/CONCEN(LCONC)
         END IF
         IPCERR(LINTBL)=NINT(AMIN1(PCERR,999.))
         IF (EFORM(CONCEN(LCONC))) THEN
            if (conc3f) then
               FMTC='SS1PE8.2'
            else
               FMTC='SS1PE8.1'
            end if
         ELSE
            FMTC='0PF8.3'
         END IF
         IF (EFORM(RELCON)) THEN
            FMTR='1PE8.1'
         ELSE
            FMTR='0PF8.3'
         END IF
         fmtpm = ', '' '', a)'
         do 582 jratio = 1, nratio_used
            if (lmetab_prior(jratio) .eq. lconc) go to 583
 582     continue
         go to 586
 583     sum = 0.
         do 584 jmetab = 1, nmetab
            sum = sum + cprior(jratio, jmetab) * concen(jmetab)
 584     continue
         ratipm = abs(ratipm)
         ratio_outlier(lintbl) = abs(sum) .gt. ratipm
         if (sum .gt. ratipm) then
            fmtpm = ', ''+'', a)'
         else if (sum .lt. -ratipm) then
            fmtpm = ', ''-'', a)'
         end if
c        ---------------------------------------------------------------------
c        NACOMB(J) is changed here, but only for J > NMETAB, and these are
c           needed again (and NACOMB is redefined with next CSI voxel)
c        ---------------------------------------------------------------------
 586     if (nacom2(lconc) .ne. ' ') nacomb(lconc) = nacom2(lconc)
         do 587 jpage = 1, 2
            WRITE (TABLE(LINTBL, jpage),
     1             '(' // FMTC // ',I4,''%'',' // FMTR // fmtpm )
     2            CONCEN(LCONC), IPCERR(LINTBL), RELCON,
     3            NACOMB(LCONC)(:nchar_metab(jpage))
 587     continue
c        -------------------------------------------------------------------
c        Print final table of shifts & broadenings for all lines, even lines
c           skipped in concentration table (where IPCERR was set to -99 above).
c        -------------------------------------------------------------------
 581     if (lprint .gt. 0   .and.   lconc .le. nmetab   .and.
     1       dofull) then
            if (imethd .eq. 3) then
               write (lprint, 5588) lconc, nacomb(lconc)(:6),
     1          parbes(lshist+lconc-1,2)/(2.*PI*HZPPPM),
     2          parbes(lshist+lconc-1,2)/sdshif(lconc),
     3          parbes(lpowen(lconc - 1) + 1, 2),
     4          parbes(lpowen(lconc - 1) + 1, 2) /
     5            coeff_power_sd(1, lconc),
     6          CONCEN(LCONC), IPCERR(LINTBL)
               do 588 jpower = 2, npower(lconc)
                  write (lprint, 5604)
     1               parbes(lpowen(lconc - 1) + jpower, 2),
     2               parbes(lpowen(lconc - 1) + jpower, 2) /
     3                  coeff_power_sd(jpower, lconc)
 5604             format (29x, f13.2, f6.1)
 588           continue
            else
               write (lprint, 5588) lconc, nacomb(lconc)(:6),
     1           parbes(lshist+lconc-1,2)/(2.*PI*HZPPPM),
     2           parbes(lshist+lconc-1,2)/sdshif(lconc),
     3           parbes(lrt2st+lconc-1,2),
     4           (parbes(lrt2st+lconc-1,2) - exrt2(lconc))/SDRT2(lconc),
     5           CONCEN(LCONC), IPCERR(LINTBL)
 5588          format(i3, 1x, 'met= ', a6, 3pf8.1, 0pf6.1, f13.2, f6.1,
     1                1pe12.2, i5)
            end if
         end if
c        -------------------------------------------------------------------
c        Output to CSV file.
c        -------------------------------------------------------------------
         if (skip_line) go to 580
         if (lcsv .gt. 0   .and.   ncsv .le. mcsv) then
            len_nacomb = min0(13, ilen(NACOMB(LCONC)))
            if (first_row   .and.   ioffset_current_in .le. 0) then
               len_line = ilen(csv_line(1))
               csv_line(1) = csv_line(1)(:len_line) // ', ' //
     1                       nacomb(lconc)(:len_nacomb) // ', ' //
     2                       nacomb(lconc)(:len_nacomb) // ' %SD, ' //
     3                       nacomb(lconc)(:len_nacomb) // '/' //
     4                       namrel(:len_namrel)
            end if
            len_line = ilen(csv_line(2))
            write (csv_element, '(' // fmtc // ''', '',i4, '', '',' //
     1                          fmtr // ')')
     2               concen(lconc), IPCERR(LINTBL), RELCON
            len_line = ilen(csv_line(2))
            csv_line(2) = csv_line(2)(:len_line) // ', ' // csv_element
         end if
  580 CONTINUE
 5590 FORMAT (1X,A)
      IF (LPRINT .GT. 0) THEN
 5003    FORMAT (//1X)
         WRITE (LPRINT,5003)
 5580    FORMAT (1X, A)
         WRITE (LPRINT,5580) VERSIO, (TITLE_line(j), j=1,nlines_title)
 5001    FORMAT (1X)
         WRITE (LPRINT,5001)
         WRITE (LPRINT,5590) (TABLE(J,2),J=1,LINTBL)
      END IF
      IF (LCOORD .GT. 0) WRITE (LCOORD,5590) (TABLE(J,2),J=1,LINTBL)
      IF (LTABLE .GT. 0) WRITE (LTABLE,5590) (TABLE(J,2),J=1,LINTBL)
      if (lcsv .gt. 0) then
         if (first_row   .and.   ioffset_current_in .le. 0) then
            first_row = .false.
            len_line = ilen(csv_line(1))
            write (lcsv, 5589) csv_line(1)(:len_line)
         end if
         len_line = ilen(csv_line(2))
         write (lcsv, 5589) csv_line(2)(:len_line)
 5589    format(a)
      end if
C     -------------------------------------------------------------------------
C     Load ETCOUT with further output.
C     LINETC = no. of lines in ETCOUT.
C     -------------------------------------------------------------------------
      IF (SDBEST(2) .GT. 0.D0) THEN
         SIGMAX=0.
         DO 590 JY=1,NYuse
            IF (SUBBAS) THEN
               SIGMAX=AMAX1(SIGMAX, abs(YFITRE(JY,0)))
            ELSE
               SIGMAX=AMAX1(SIGMAX, abs(YFITRE(JY,0)-BACKRE(JY)))
            END IF
  590    CONTINUE
         SIGTON=.5*SIGMAX/SDBEST(2)
      ELSE
         CALL ERRMES (6, 2, CHSUBP)
         SIGTON=-1.
      END IF
      if (nsides .gt. 0) then
         WRITE (ETCOUT,5591) fwhmls, NINT(SIGTON)
      else
         WRITE (ETCOUT,5591) SQRT(fwhmst_full**2+FWHMBA**2),
     1                       NINT(SIGTON)
      end if
 5591 FORMAT (' FWHM =', F6.3, ' ppm', 4X, 'S/N =', I4)
      SHIFD=PPMINC*FLOAT(ISHIFD)
      WRITE (ETCOUT(2),5593) SHIFD
 5593 FORMAT (' Data shift =', F6.3, ' ppm')
      WRITE (ETCOUT(4),5594) ALPBBS(2), ALPSBS(2)
 5594 FORMAT (' alphaB,S =',1PE8.1, ',', E10.1)
      IF (ALPBBS(2).LE.DBLE(ALPBPN) .AND. ALPBBS(2).gt.0.d0 .and.
     1    NBACKG.GE.10) CALL ERRMES (7, 1, CHSUBP)
c     -------------------------------------------------------------------------
c     Put PHITOT(1) in range +-180
c     -------------------------------------------------------------------------
      PHITOT(1)=DMOD((PHITOT(1)+PARBES(LPHAST,2))/RADIAN, 360.D0)
      IF (PHITOT(1) .LT. -180.d0) PHITOT(1)=PHITOT(1)+360.
      if (phitot(1) .gt.  180.d0) PHITOT(1)=PHITOT(1)-360.
      PHITOT(2)=(PHITOT(2)+PARBES(LPHAST+1,2))/RADIAN
      IF (PHITOT(2) .lt. dgppmn - sddegp  .or.
     1    PHITOT(2) .gt. dgppmx + sddegp) CALL ERRMES (8, 2, CHSUBP)
      WRITE (ETCOUT(3),5595) NINT(PHITOT(1)), PHITOT(2)
 5595 FORMAT (' Ph:', I4, ' deg', f10.1, ' deg/ppm')
      WRITE (ETCOUT(5),5596) NBACKG, NSIDES, INCSID
 5596 FORMAT (1X,I3, ' spline knots.', 3X, 'Ns =', I2, '(', I1, ')')
      LINETC=5
      IF (NSIDE2 .GT. 0) THEN
         IF (NINFL(2) .LT. 0) THEN
            IF (NEXTR(1) .GT. 1) CALL ERRMES (9, 1, CHSUBP)
            WRITE (ETCOUT(6),5597) NINFL(1), NEXTR(1)
 5597       FORMAT (1X, I2, ' inflections.',  I6, ' extrema')
         ELSE
            IF (NEXTR(2) .GT. 1) CALL ERRMES (9, 1, CHSUBP)
            WRITE (ETCOUT(6),5598) NINFL, NEXTR
 5598       FORMAT (' (', I2, ')', I2, ' infls.', 2X,
     1              ' (', I2, ')', I2, ' extrs.')
         END IF
         LINETC=6
      END IF
      if (.NOT.(FXDEGZ .OR. SDDEGZ.GE.45.)) then
c        ----------------------------------------------------------------------
c        Manual says that EXDEGZ (input as DEGZER) must be in range 0--360.
c          Bring PHITOT(1) back to this range.
c        ----------------------------------------------------------------------
         IF (PHITOT(1) .LT. 0.) PHITOT(1)=PHITOT(1)+360.
         TEST=AMOD(ABS(phitot(1)-EXDEGZ),360.)
         IF (AMIN1(TEST,360.-TEST).GT.4.*SDDEGZ)
     1        call errmes (10, 2, chsubp)
      end if
      if (.not.fxdegp) then
         if (abs(phitot(2) - exdegp) .gt. 6. * sddegp)
     1        call errmes (11, 2, chsubp)
      end if
      IF (LPRINT .GT. 0) THEN
         WRITE (LPRINT,5003)
         WRITE (LPRINT,5590) (ETCOUT(J),J=1,LINETC)
      END IF
      IF (LCOORD .GT. 0) THEN
         WRITE (LCOORD,5602) LINETC
 5602    FORMAT (1X,I3, ' lines in following misc. output table')
         WRITE (LCOORD,5590) (ETCOUT(J),J=1,LINETC)
C        ----------------------------------------------------------------------
C        Finish output onto unit LCOORD.
C        ----------------------------------------------------------------------
         WRITE (LCOORD,5610) NYuse, (PPM(JY),JY=1,NYuse)
 5610    FORMAT (1X,I4,' points on ppm-axis = NY'/(1X,10F13.6))
         WRITE (LCOORD,5620) (YREAL(JY),JY=1,NYuse)
 5620    FORMAT (' NY phased data points follow'/(1X,1P10E13.5))
         WRITE (LCOORD,5630) (YFITRE(JY,0),JY=1,NYuse)
 5630    FORMAT (' NY points of the fit to the data follow'/
     1           (1X,1P10E13.5))
         IF (NBACKG .GT. 0) THEN
C           -------------------------------------------------------------------
C           Output background.
C           -------------------------------------------------------------------
 5640       FORMAT (' NY background values follow'/(1X,1P10E13.3))
            WRITE (LCOORD,5640) (BACKRE(JY),JY=1,NYuse)
         END IF
         IF (NEACH .GE. 1) THEN
            DO 660 JMETAB=1,NMETAB
               IF (CONCEN(JMETAB) .le. 0.) go to 660
               do 670 JEACH=1,MIN0(MMETAB,NEACH)
                  IF (NAMEAC(JEACH).EQ.NACOMB(JMETAB)(1:6) .OR.
     1                NEACH.GT.NMETAB) THEN
                     WRITE (LCOORD,5660) NACOMB(JMETAB), CONCEN(JMETAB),
     1                                  (YFITRE(JY,JMETAB),JY=1,NYuse)
 5660                FORMAT (1X, A6, '   Conc. =', 1PE9.2/ (1X,10E13.5))
                     go to 660
                  end if
 670           continue
  660       CONTINUE
         END IF
      END IF
      IF (LTABLE .GT. 0) THEN
         WRITE (LTABLE,5662) LINETC
 5662    FORMAT (/'$$MISC',I3,
     1           ' lines in following misc. output table')
         WRITE (LTABLE,5590) (ETCOUT(J),J=1,LINETC)
      END IF
      if (lcoraw .gt. 0) then
C        ----------------------------------------------------------------------
C             Output corrected RAW file to FILCOR (which has already been
c        opened).
c             DATAT has already been scaled by FCALIB*TRAMP/VOLUME, ECC'd and
c        been corrected for BRUKER=T & SEQACQ=T.
c             Only need phase & shift corrections.  Use method of CHANGE-RAW.f
C        ----------------------------------------------------------------------
         cterm(1) = cexp(cmplx(0.,
     1              radian * (phitot(1) + sngl(parbes(lphast, 2)))))
         cfactor = cexp(cmplx(0., -2. * pi * hzpppm * deltat * shifd))
         do 710 junfil = 1, nunfil
            datat(junfil) = datat(junfil) * cterm(1)
            cterm(1) = cterm(1) * cfactor
 710     continue
         do 720 jdata = nunfil + 1, ndata
            datat(jdata) = (0., 0.)
 720     continue
         call cfft_r (datat, dataf, ndata, lwfft, wfftc)
         delta_ppm = float(nunfil) * ppminc
         do 730 jdata = 1, ndata
            dataf(jdata) = dataf(jdata) * cexp(cmplx(0., radian *
     1         delta_ppm * (phitot(2) + sngl(parbes(lphast + 1, 2)))))
            delta_ppm = delta_ppm - ppminc
 730     continue
         do 740 junfil = 1, nunfil
            cterm(1) = dataf(nunfil + junfil)
            dataf(nunfil + junfil) = dataf(junfil)
            dataf(junfil) = cterm(1)
 740     continue
         call cfftin (dataf, datat, ndata, lwfft, wfftc)
         write (lcoraw, nml=seqpar)
         bruker = .false.
         fmtdat = '(2e15.6)'
         id = 'FILCOR'
         seqacq = .false.
         tramp = 1.
         volume = 1.
         write (lcoraw, nml=nmid)
         write (lcoraw, fmt=fmtdat) (datat(junfil), junfil = 1, nunfil)
      END IF
      CALL EXITPS (.false.)
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE EXITPS (lstop)
C
C  Output Postscript plot file.
C  Load error message table into ERRORS and output this.
C  LSTOP = T to exit with STOP.
C
      INCLUDE 'lcmodel.inc'
      logical lstop
      CHARACTER BUFOUT(20)*132
      LOGICAL STRIP1
      COMMON /BLPS/ BUFOUT, LLPS, STRIP1
      CHSUBP='EXITPS'
      IF (LPS .LE. 0) THEN
         CALL ERRTBL ()
      ELSE
         LLPS=LPS
         STRIP1=.NOT.CCNTRL
         CALL MAKEPS ()
         CLOSE (LPS)
      END IF
      IF (MAX0(LPRINT,LCOORD,LTABLE) .GT. 0) CALL ERRTBL ()
      IF (LPRINT .GT. 0) THEN
         WRITE (LPRINT, 5110) (ERRORS(J), J=1,LINERR)
 5110    FORMAT (////' Summary of diagnostics'/(A))
         WRITE (LPRINT, 5002)
 5002    FORMAT (/' ')
         CLOSE (LPRINT)
      END IF
      IF (LCOORD .GT. 0) THEN
         WRITE (LCOORD, 5120) LINERR, (ERRORS(J), J=1,LINERR)
 5120    FORMAT (1X,I3, ' lines in following diagnostic table:'/(A))
         WRITE (LCOORD, 5130) LINCHG(2), (CHANGE(J,2), J=1,LINCHG(2))
 5130    FORMAT (1X, I3, ' lines in following table of input changes:'/
     1           (A))
         CLOSE (LCOORD)
      END IF
      IF (LTABLE .GT. 0) THEN
         WRITE (LTABLE, 5122) LINERR, (ERRORS(J), J=1,LINERR)
 5122    FORMAT (/'$$DIAG',I3,
     1           ' lines in following diagnostic table:'/(A))
         WRITE (LTABLE, 5132) LINCHG(2), (CHANGE(J,2), J=1,LINCHG(2))
 5132    FORMAT (/'$$INPU', I3,
     1           ' lines in following table of input changes:'/ (A))
         CLOSE (LTABLE)
      END IF
      if (lcoraw .gt. 0) then
c        ---------------------------------------------------------------------
c        Intel Windows version outputs Namelists that cannot be read; so do
c           not bother to fix Cyg Namelist.
c        ---------------------------------------------------------------------
C        call fix_g77_namelist(lcoraw) !sun
         close (lcoraw)
      end if
      if (lstop) STOP
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE ERRTBL ()
C
C  Load error message table into ERRORS.
C
      INCLUDE 'lcmodel.inc'
      CHARACTER*9 CHTYPE(5,2)
      LOGICAL ILLOG
      DATA CHTYPE/'info', 'warning', 'ERROR', 'FATAL', 'ILLOGICAL',
     1            'info''s', 'warnings', 'ERRORS', 'FATAL', 'ILLOGICAL'/
      CHSUBP='ERRTBL'
      DO 110 J=1,LINERR
         ILLOG=LEVERR(J).LT.1 .OR. LEVERR(J).GT.5
         IF (ILLOG) THEN
            NERROR(J)=1
            LEVERR(J)=5
            CHERR(J)=CHSUBP
            IERRNO(J)=1
         END IF
         WRITE (ERRORS(J),5110) NERROR(J),
     1     CHTYPE(LEVERR(J),MIN0(2,NERROR(J))), CHERR(J), IERRNO(J)
 5110    FORMAT (i4, 1X, A9, 1X, A6, I3)
         IF (ILLOG) GO TO 120
  110 CONTINUE
  120 LINERR=MIN0(J,LINERR)
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE MAKEPS ()
C
C  Compute and output Postscript plot file onto unit LPS.
C
C  ISTAGO tells what output is available for plotting as follows:
C  ISTAGO = 0 when nothing yet is available in DATAT for plotting;
C         = 1 when DATAT is loaded with time-domain data;
C         = 2 when CY is loaded with frequency-domain data (not necessarily
C             properly referenced or phased);
C         = 3 when YFITRE, BACKRE, and PPM are available
C         < 3 means that the run was aborted, and only the absolute value of
C             CY (if ISTAGO > 0) can be plotted.
C
      INCLUDE 'lcmodel.inc'
      CHARACTER SUBTIT*25
      CHSUBP='MAKEPS'
      call toupper_lower (.true., pgnorm)
      IF (PGNORM .EQ. 'US') THEN
         PAGEWD=8.5*2.54
         PAGEHT=11.*2.54
      ELSE IF (PGNORM.EQ.'EU' .OR. PGNORM.EQ.'A4') THEN
         PAGEWD=21.
         PAGEHT=29.7
      ELSE
         IF (AMIN1(PAGEWD,PAGEHT) .LE. 0.) CALL ERRMES (1, -4, CHSUBP)
      END IF
      IF (LANDSC) THEN
         PAGEX=PAGEHT
         PAGEY=PAGEWD
      ELSE
         PAGEX=PAGEWD
         PAGEY=PAGEHT
      END IF
C     -------------------------------------------------------------------------
C     Initial setup of PostScript file.
C     -------------------------------------------------------------------------
      IF (FILPS .NE. ' ') THEN
C         OPEN (LPS, FILE=FILPS, STATUS='UNKNOWN', !OSF
C     1         CARRIAGECONTROL='LIST', err=802)!OSF
          OPEN (LPS, FILE=FILPS, STATUS='UNKNOWN', err=802)!Cyg
C        OPEN (LPS, FILE=FILPS, STATUS='UNKNOWN', err=802)!sun
C         OPEN (LPS, FILE=FILPS, STATUS='UNKNOWN', err=802)!IRIX
         CALL PSETUP (.true., PAGEWD, PAGEHT, LANDSC)
      END IF
      IF (ISTAGO. EQ. 0) THEN
         CALL ONEPAG (0, CPY, CPY, NCHLIN(1), 0,
     1                PAGEX, PAGEY, SUBTIT)
      ELSE IF (ISTAGO .LE. 2) THEN
C        ----------------------------------------------------------------------
C        Put absolute value of (possibly unreferenced) spectrum into
C          YREAL(JY)
C        ----------------------------------------------------------------------
         IF (ISTAGO .EQ. 1) CALL FTDATA (0)
         DO 110 JY=1,NY
            YREAL(JY)=CABS(CY(JY))
  110    CONTINUE
C        ----------------------------------------------------------------------
C        Reverse order of arrays for easier plotting.
C        ----------------------------------------------------------------------
         CALL REVERS (PPM, NYUSE)
         CALL REVERS (YREAL, NYUSE)
         CALL ONEPAG (1, YREAL, CPY, NCHLIN(1), 0,
     1                PAGEX, PAGEY, SUBTIT)
      ELSE
         CALL REVERS (PPM, NYUSE)
         CALL REVERS (YREAL, NYUSE)
         CALL REVERS (BACKRE, NYUSE)
         CALL REVERS (YFITRE(1,0), NYUSE)
         CALL ONEPAG (4, YFITRE(1,0), YREAL, NCHLIN(1), 0,
     1                PAGEX, PAGEY, SUBTIT)
         DO 210 JMETAB=1,NMETAB
            IF (CONCEN(JMETAB) .LE. 0.) GO TO 210
            DO 220 JEACH=1,MIN0(MMETAB,NEACH)
               IF (NAMEAC(JEACH).EQ.NACOMB(JMETAB)(1:6) .OR.
     1             NEACH.GT.NMETAB) THEN
                  if (ldump(4) .and. subbas) then
                     sumy = 0.
                     do 230 jy = 1, nyuse
                        sumy = sumy + yfitre(jy, jmetab)
 230                 continue
 5230                format ('metab = ', a6, 3x, 'Conc =', 1pe10.3, 3x,
     1                       'Area/Conc =', 1pe10.3)
                     write (lprint, 5230) nacomb(JMETAB)(1:6),
     1                     concen(jmetab), sumy / CONCEN(JMETAB)
                  end if
                  WRITE (SUBTIT,5220) NACOMB(JMETAB)(1:6),
     1                                CONCEN(JMETAB)
 5220             FORMAT (A6, '   Conc. =', 1PE9.2)
                  CALL REVERS (YFITRE(1,JMETAB), NYUSE)
                  CALL ONEPAG (3, YFITRE(1,JMETAB), YREAL, 0, 1,
     1                         PAGEX, PAGEY, SUBTIT)
                  GO TO 210
               END IF
  220       CONTINUE
  210    CONTINUE
      END IF
      CALL ENDPS ()
      return
 802  call errmes (2, -4, chsubp)
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE REVERS (X, N)
C
C  Reverse order of array X.
C
      REAL X(N)
      K=N
      DO 110 J=1,N/2
         TERM=X(K)
         X(K)=X(J)
         X(J)=TERM
         K=K-1
  110 CONTINUE
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE ONEPAG (NCURVE, YFIT, YDATA, LCHLIN, NSUBTI,
     1                   PAGEX, PAGEY, SUBTIT)
C
C  Make one PostScript page.
C
C  NCURVE = no. of curves to be plotted;
C           0 if only the table is to be output.
C           1 if only the table (with diagnostics and input) and the absolute
C             value of the data (in YFIT in this routine) are to be plotted;
C           3 if the contribution of one metabolite (in YFIT), the data (in
C             YDATA), the background (in BACKRE) are to be plotted.  No table
C             is plotted.
C           4 if the fit (in FIT), the data (in YDATA), the background (in
C             BACKRE), the residuals, and the table are to be plotted.
C
c  LCHLIN is only used to compute axis length for plot on page 1.
c         So, normally the actual argument in the calling program is NCHLIN(1).
c
C  All distances are in cm, except variables beginning with PT, which are in
C    points.
C                      YFITRE(*,JMETAB)] and the data are to be plotted.
C
      INCLUDE 'lcmodel.inc'
      CHARACTER CHREAL*8, CHSTR*132, SUBTIT*(*), XLABEL*20
      logical outside
      REAL YDATA(*), YFIT(*)
      DATA RBOXSP/.3/, XLABEL/'Chemical Shift (ppm)'/
      CHSUBP='ONEPAG'
      IF (NCURVE.LE.-1 .OR. NCURVE.EQ.2 .OR. NCURVE.GE.5) CALL ERRMES
     1      (1, -5, CHSUBP)
      IF (AMIN1(PTLABL,PTTITL,PTOUTP,PTVERS).LE.0. .OR.
     1    AMIN1(RHLABL,RHTITL,RHOUTP,RHVERS).LT.1.) CALL ERRMES
     1      (2, -4, CHSUBP)
      CALL PSETUP (.false., PAGEWD, PAGEHT, LANDSC)
C     -------------------------------------------------------------------------
C     SZ* = the character height in cm.
C     SP* = the total height of a line, including the space between the
C           current line and the line toward the center of the plot.
C         = (SZ*)*(RH*)
C     -------------------------------------------------------------------------
      PTTOCM=2.54/72.
      SZLABL=PTLABL*PTTOCM
      SZTITL=PTTITL*PTTOCM
      SZOUTP=PTOUTP*PTTOCM
      SZVERS=PTVERS*PTTOCM
      SPLABL=SZLABL*RHLABL
      SPTITL=SZTITL*RHTITL
      SPOUTP=SZOUTP*RHOUTP
      SPVERS=SZVERS*RHVERS
      TCKLNG=.6*SZLABL
      IF (MIN0(LCHLIN,NSUBTI).LT.0 .OR. NSUBTI.GT.1 .OR.
     1    LCHLIN.GT.NCHLIN(1)) CALL ERRMES (3, -5, CHSUBP)
      XORIG=XLEFT +SPLABL +TCKLNG
      XAXIS=PAGEX -XORIG -RWFONT*FLOAT(LCHLIN)*SZOUTP -XRIGHT
      YORIG=YBOTT +2.*SPLABL +TCKLNG
      YAXIS=PAGEY -YORIG -FLOAT(NSUBTI+nlines_title)*SPTITL -2.*SPVERS
     1      -YTOP
      IF (AMIN1(XORIG,XAXIS,YORIG,YAXIS) .LT. 0.) CALL ERRMES (4, -4,
     1                                                         CHSUBP)
C     -------------------------------------------------------------------------
C     Outer box for plots, titles, and version.
C     DSHPAT(J,1) = dash pattern for fine grid lines (J=1,2);
C              2  =                  data.
C       CALL DASH (0,DSHPAT) produces a solid curve.
C       CALL DASH (J,DSHPAT) produces DSHPAT(*,J) if J=1,2
C     WDLINE(1) = linewidth of fit to data (except for absolute value of the
C                                           data when NCURVE=1);
C            2  =              baseline;
C            3  =              data;
C            4  =              residuals;
C            5  =              axes and frame;
C            6  =              fine grid;
C     -------------------------------------------------------------------------
      CALL DASH (0, DSHPAT)
      CALL LINEWD (WDLINE(5))
      CALL RGB (RGBLIN(1,5))
      CALL BOX (XORIG, YORIG, XAXIS, YAXIS)
      call rgb (black)
      CALL FONT (PTTITL, 'Helvetica')
      XCENTR=.5*(PAGEX -XLEFT -XRIGHT) +XLEFT
      YCURR=PAGEY -YTOP -SZTITL +sptitl
      do 110 jline = 1, nlines_title
         CALL STRCHK (TITLE_line(jline), CHSTR)
         YCURR=ycurr - sptitl
         if (nlines_title .eq. 1) then
            CALL STRING ('c', 0, XCENTR, YCURR, CHSTR)
         else
            CALL STRING ('l', 0, XORIG+.3, YCURR, CHSTR)
         end if
 110  continue
      IF (NSUBTI .EQ. 1) THEN
         CALL STRCHK (SUBTIT, CHSTR)
         YCURR=YCURR-SPTITL
         CALL STRING ('c', 0, XCENTR, YCURR, CHSTR)
      END IF
      CALL FONT (PTVERS, 'Helvetica-Oblique')
      CALL STRCHK (OWNOUT, CHSTR)
      YCURR=YCURR-SPTITL+SZTITL-SZVERS
      CALL STRING ('c', 0, XCENTR, YCURR, CHSTR)
      CALL STRCHK (VERSIO, CHSTR)
      YCURR=YCURR-SPVERS
      CALL STRING ('l', 0, XORIG+.3, YCURR, CHSTR)
      CALL STRCHK (CHDATE, CHSTR)
      CALL STRING ('r', 0, PAGEX-XRIGHT, YCURR, CHSTR)
      IF (NCURVE .GT. 0) THEN
C        ----------------------------------------------------------------------
C        X-axis (ppm).
C        ----------------------------------------------------------------------
         CALL FONT (PTLABL, 'Helvetica')
         CALL STRING ('c', 0, XORIG+.5*XAXIS, YBOTT, XLABEL)
         IF (XSTEP .LE. 0.) THEN
            XSTEP=.2
            CALL ERRMES (5, 3, CHSUBP)
         END IF
C        ----------------------------------------------------------------------
C        PPM is now in increasing order (since call to REVERS in MAKEPS).
C        X-axis frame has ends that are integer multiples of XSTEP.
C        Allow the curve to extend out of the x-axis frame by up to PPMINC.
C        ----------------------------------------------------------------------
         CALL ENDRND (PPM(1), PPM(NYUSE), XSTEP, PPMINC, XBEG, XEND)
         IF (XEND .LE. XBEG) CALL ERRMES (6, -4, CHSUBP)
         CALL LINEWD (WDLINE(5))
         CALL RGB (RGBLIN(1,5))
         CALL AXIS (0, XORIG+XAXIS, YORIG, -XAXIS, XBEG, XEND, XBEG,
     1              XSTEP, 1., .TRUE.)
         IF (NSUBTK .LE. 0) THEN
            NSUBTK=1
            CALL ERRMES (7, 3, CHSUBP)
         END IF
         CALL TICK (0, XORIG+XAXIS, YORIG, -XAXIS, XBEG, XEND, XBEG,
     1              XSTEP/FLOAT(NSUBTK), -.3*SZLABL)
         CALL LINEWD (WDLINE(6))
         CALL RGB (RGBLIN(1,6))
         IF (WDLINE(6) .GT. 0.) then
            CALL LINEWD (WDLINE(6))
            CALL RGB (RGBLIN(1,6))
            CALL DASH (1, DSHPAT)
            CALL TICK (0, XORIG+XAXIS, YORIG, -XAXIS, XBEG, XEND, XBEG,
     1                 XSTEP/FLOAT(NSUBTK), YAXIS)
         end if
         CALL LINEWD (WDLINE(5))
         CALL RGB (RGBLIN(1,5))
         YMIN=0.
         YMAX=0.
         IF (NCURVE .EQ. 1) THEN
            DO 210 J=1,NYUSE
               YMIN=AMIN1(YMIN, YFIT(J))
               YMAX=AMAX1(YMAX, YFIT(J))
  210       CONTINUE
         ELSE IF (SUBBAS) THEN
            DO 215 J=1,NYUSE
               YMIN=AMIN1(YMIN, YFIT(J), YDATA(J))
               YMAX=AMAX1(YMAX, YFIT(J), YDATA(J))
  215       CONTINUE
         ELSE
            DO 220 J=1,NYUSE
               YMIN=AMIN1(YMIN, YFIT(J), YDATA(J), BACKRE(J))
               YMAX=AMAX1(YMAX, YFIT(J), YDATA(J), BACKRE(J))
  220       CONTINUE
         END IF
         XSPACE=SPLABL-SZLABL+TCKLNG
         IF (NCURVE .LT. 4) THEN
            YAXIS1=YAXIS
            YTOTAL=YMAX-YMIN
            IF (YTOTAL .LE. 0.) CALL ERRMES (8, -4, CHSUBP)
            YTOCM=YAXIS/YTOTAL
         ELSE
C           -------------------------------------------------------------------
C           Plot residuals above main plot.
C           CPY = residuals.
C           -------------------------------------------------------------------
            RESMAX=0.
            RESMIN=0.
            DO 230 J=1,NYUSE
               CPY(J)=YDATA(J)-YFIT(J)
               RESMIN=AMIN1(RESMIN,CPY(J))
               RESMAX=AMAX1(RESMAX,CPY(J))
  230       CONTINUE
            YTOTAL=RESMAX-RESMIN+YMAX-YMIN
            IF (YTOTAL .LE. 0.) CALL ERRMES (9, -4, CHSUBP)
            YAXIS1=YAXIS*(YMAX-YMIN)/YTOTAL
            YAXIS2=YAXIS*(RESMAX-RESMIN)/YTOTAL
            YTOCM=YAXIS/YTOTAL
            IF (RESMAX .LE. RESMIN) THEN
               CALL ERRMES (10, 3, CHSUBP)
            ELSE
               YZERO=YORIG+YAXIS-RESMAX*YTOCM
               CALL LINEWD (WDLINE(6))
               CALL RGB (RGBLIN(1,6))
               CALL LINE (XORIG, YZERO, XAXIS, 0.)
               IF (AMIN1(RESMAX,-RESMIN)*YTOCM .GT. 1.) CALL STRING
     1               ('c', 90, XORIG-XSPACE, YZERO, '0')
               if (resmax * ytocm .gt. .6) then
                  CALL STRING ('c', 90, XORIG-XSPACE, YORIG+YAXIS,
     1                         CHREAL(RESMAX, RESMAX, .falsE.))
               else
                  CALL STRING ('l', 90, XORIG-XSPACE, YORIG+YAXIS,
     1                         CHREAL(RESMAX, RESMAX, .truE.))
               end if
               CALL DASH (0, DSHPAT)
               CALL LINEWD (WDLINE(5))
               CALL RGB (RGBLIN(1,5))
               CALL LINE (XORIG-TCKLNG, YZERO, TCKLNG, 0.)
               CALL LINE (XORIG-TCKLNG, YORIG+YAXIS, TCKLNG, 0.)
               CALL LINEWD (WDLINE(4))
               CALL RGB (RGBLIN(1,4))
               CALL PLOT_gap (NYUSE, PPM, CPY, XBEG, XEND, RESMIN,
     1            RESMAX, XORIG+XAXIS, YORIG+YAXIS1, -XAXIS, YAXIS2)
            END IF
         END IF
         if (solgrd   .and.   wdline(6) .gt. 0.) then
            CALL LINEWD (WDLINE(6))
            CALL RGB (RGBLIN(1,6))
            CALL DASH (0, DSHPAT)
            CALL TICK (0, XORIG+XAXIS, YORIG, -XAXIS, XBEG, XEND,
     1                 XBEG, XSTEP, YAXIS1)
         end if
C        ----------------------------------------------------------------------
C        Label main Y-axis, and plot first curve (in YFIT).
C        ----------------------------------------------------------------------
         CALL DASH (1, DSHPAT)
         CALL LINEWD (WDLINE(6))
         CALL RGB (RGBLIN(1,6))
         YZERO=YORIG+YAXIS1-YMAX*YTOCM
         CALL LINE (XORIG, YZERO, XAXIS, 0.)
         CALL DASH (0, DSHPAT)
         CALL LINEWD (WDLINE(5))
         CALL RGB (RGBLIN(1,5))
         IF (YMAX*YTOCM .GT. 1.) CALL STRING ('c', 90, XORIG-XSPACE,
     1                                        YZERO, '0')
         if (-resmin * ytocm .gt. .6) then
            CALL STRING ('c', 90, XORIG-XSPACE, YORIG+YAXIS1,
     1                   CHREAL(YMAX, YMAX, .falsE.))
         else
            CALL STRING ('r', 90, XORIG-XSPACE, YORIG+YAXIS1,
     1                   CHREAL(YMAX, YMAX, .falsE.))
         end if
         CALL LINE (XORIG-TCKLNG, YZERO, TCKLNG, 0.)
         CALL LINE (XORIG-TCKLNG, YORIG+YAXIS1, TCKLNG+XAXIS, 0.)
         CALL LINEWD (WDLINE(1))
         CALL RGB (RGBLIN(1,1))
         IF (YMAX .LE. YMIN) CALL ERRMES (11, -4, CHSUBP)
         CALL PLOT_gap (NYUSE, PPM, YFIT, XBEG, XEND, YMIN, YMAX,
     1                  XORIG+XAXIS, YORIG, -XAXIS, YAXIS1)
         IF (NCURVE .GE. 3) THEN
C           -------------------------------------------------------------------
C           Plot curves 2 and 3 (in BACKRE and YDATA).
C           -------------------------------------------------------------------
            IF (WDLINE(2).GT.0. .AND. .NOT.SUBBAS   .and.
     1          nbackg .gt. 0) THEN
               CALL LINEWD (WDLINE(2))
               CALL RGB (RGBLIN(1,2))
               CALL PLOT_gap (NYUSE, PPM, BACKRE, XBEG, XEND, YMIN,
     1                        YMAX, XORIG+XAXIS, YORIG, -XAXIS, YAXIS1)
            END IF
            CALL DASH (2, DSHPAT)
            CALL LINEWD (WDLINE(3))
            CALL RGB (RGBLIN(1,3))
            CALL PLOT_gap (NYUSE, PPM, YDATA, XBEG, XEND, YMIN, YMAX,
     1                     XORIG+XAXIS, YORIG, -XAXIS, YAXIS1)
         END IF
      END IF
      IF (LCHLIN .le. 0) go to 800
C     ----------------------------------------------------------------------
C     Output data for licensing
c            table of concentrations (in TABLE),
C            misc. output (in ETCOUT),
C            diagnostics (in ERRORS), and
C            input changes to Control Variables (in CHANGES).
C     Goes right to the bottom of the page, if necessary, ignoring YBOTT.
C     ----------------------------------------------------------------------
      CALL DASH (0, DSHPAT)
      CALL LINEWD (WDLINE(5))
      CALL RGB (RGBLIN(1,5))
      XBOXLO=XORIG+XAXIS
      XBOXHI=PAGEX-XRIGHT
      XCENTR=.5*(XBOXHI+XBOXLO)
      YBOXHI=PAGEY -YTOP - FLOAT(NSUBTI+nlines_title)*SPTITL -2.*SPVERS
      YCURR=YBOXHI-SPOUTP
      NLINE=0
      YBOXSP=RBOXSP*SPOUTP
      LOUTMX=INT(YBOXHI/SPOUTP)
      NETCOU=MAX0(0,MIN0(LINETC,IETCOU))
C     ------------------------------------------------------------------
C     Output data that users must return for licensing.
c     NOLINE = T means that there is no license.
c     LETT = 0 if this is not Linux, which means that DATA FOR LICENSING table
c              must be output.
C     ------------------------------------------------------------------
      IF (NOLINE) THEN
         nline=1
         CALL FONT (PTOUTP, 'Courier-Bold')
         if (lett .eq. 0) then
            CALL STRING ('c', 0, XCENTR, YCURR, 'DATA FOR LICENSING')
         else
            CALL STRING ('l', 0, XBOXLO+.5*RWFONT*SZOUTP, ycurr,
     1                   'Send the following file:')
         end if
         CALL FONT (PTOUTP, 'Courier-Bold')
         call rgb (rgberr)
         if (lett .eq. 0) then
            DO 305 JDEV=1,4
               IF (LDEV1(JDEV) .LT. 0.) GO TO 306
               nline=nline+1
               WRITE (CHSTR, '(I10)') LDEV1(JDEV)
               YCURR=YCURR-SPOUTP
               CALL STRING ('l', 0, XBOXLO+.5*RWFONT*SZOUTP, YCURR,
     1                      CHSTR)
 305        CONTINUE
         else
            nline = nline + 1
            YCURR=YCURR-SPOUTP
            CALL STRING ('c', 0, XCENTR, YCURR,
     1                   '~/.lcmodel/data-for-licensing')
         end if
 306     CALL FONT (PTOUTP, 'Courier')
         call rgb (black)
         YBOXLO=YCURR-YBOXSP
         IF (YBOXLO .LE. 0.) GO TO 700
         CALL LINEWD (WDLINE(5))
         CALL RGB (RGBLIN(1,5))
         CALL BOX (XBOXLO, YBOXLO, XBOXHI-XBOXLO, YBOXHI-YBOXLO)
         CALL RGB (BLACK)
         YCURR=YCURR-SPOUTP+YBOXSP
         nline=nline+1
      END IF
c
      IF (LINTBL+nline .GE. LOUTMX   .and.   ipage2 .le. 0) THEN
         LINTBL=LOUTMX-1-nline
         CALL ERRMES (12, 3, CHSUBP)
      END IF
      IF (LINTBL .GE. 1) THEN
C     -------------------------------------------------------------------
C     Concentration table.
C     -------------------------------------------------------------------
         call rgb (black)
         CALL FONT (PTOUTP, 'Courier-Bold')
         if (noline) YCURR=YCURR-SPOUTP
         CALL STRING ('l', 0, XBOXLO+.5*RWFONT*SZOUTP, YCURR,
     1                TABLE(1,1))
         DO 310 J=2,LINTBL
            IF (IPCERR(J) .LT. ISDBOL) THEN
               if (ratio_outlier(j)) then
                  call rgb(rgbrat)
                  CALL FONT (PTOUTP, 'Courier-BoldOblique')
               else
                  CALL RGB (RGBBOL)
                  CALL FONT (PTOUTP, 'Courier-Bold')
               end if
            ELSE
               if (ratio_outlier(j)) then
                  call rgb(rgbrat)
                  CALL FONT (PTOUTP, 'Courier-BoldOblique')
               else
                  CALL RGB (BLACK)
                  CALL FONT (PTOUTP, 'Courier')
               end if
            END IF
            YCURR=YCURR-SPOUTP
            CALL STRING ('l', 0, XBOXLO+.5*RWFONT*SZOUTP, YCURR,
     1                   TABLE(J,1))
            if (j - 1 .eq. ntable_top   .and.   j .lt. lintbl) then
               ycurr = ycurr - yboxsp
               CALL RGB (BLACK)
               call line (xboxlo, ycurr, xboxhi - xboxlo, 0.)
            end if
 310     CONTINUE
         YBOXLO=YCURR-YBOXSP
         CALL LINEWD (WDLINE(5))
         CALL RGB (RGBLIN(1,5))
         CALL BOX (XBOXLO, YBOXLO, XBOXHI-XBOXLO, YBOXHI-YBOXLO)
         CALL RGB (BLACK)
         YBOXHI=YBOXLO
         YCURR=YCURR-SPOUTP+YBOXSP
         NLINE=nline+LINTBL+1
      END IF
      CALL FONT (PTOUTP, 'Courier-Bold')
      NLINE=NLINE+1
      IF (NLINE .GE. LOUTMX) GO TO 700
      YCURR=YCURR-SPOUTP
      IF (LINERR.GE.1 .OR. lline .or. .NOT.DOFULL .or.  wsdone) THEN
C        -------------------------------------------------------------------
C        Diagnostics.
C        -------------------------------------------------------------------
         CALL STRING ('c', 0, XCENTR, YCURR, 'DIAGNOSTICS')
         CALL ERRTBL ()
         DO 320 J=1,LINERR
            NLINE=NLINE+1
            IF (NLINE .GE. LOUTMX) GO TO 700
            IF (INDEX(ERRORS(J),'info') .gt. 0) THEN
               CALL FONT (PTOUTP, 'Courier')
               CALL RGB (black)
            else if (INDEX(ERRORS(J),'warning') .gt. 0) then
               CALL FONT (PTOUTP, 'Courier-Bold')
               CALL RGB (rgbbol)
            ELSE
               CALL FONT (PTOUTP, 'Courier-Bold')
               CALL RGB (rgberr)
            END IF
            YCURR=YCURR-SPOUTP
            CALL STRING ('l', 0, XBOXLO+.5*RWFONT*SZOUTP, YCURR,
     1                   ERRORS(J))
 320     CONTINUE
         call rgb(black)
         IF (LLINE) THEN
            NLINE=NLINE+1
            IF (NLINE .GE. LOUTMX) GO TO 700
            YCURR=YCURR-SPOUTP
            CALL FONT (PTOUTP, 'Courier-Bold')
            call rgb (rgberr)
            CALL STRING ('l', 0, XBOXLO+.5*RWFONT*SZOUTP, YCURR,
     1           '  LICENSE REQUIRED FOR THIS.')
            CALL FONT (PTOUTP, 'Courier')
            call rgb (black)
         else
            IF (.NOT.DOFULL) THEN
               NLINE=NLINE+1
               IF (NLINE .GE. LOUTMX) GO TO 700
               YCURR=YCURR-SPOUTP
               CALL FONT (PTOUTP, 'Courier-Bold')
               call rgb (rgberr)
               CALL STRING ('l', 0, XBOXLO+.5*RWFONT*SZOUTP, YCURR,
     1              '  CRUDE MODEL')
               CALL FONT (PTOUTP, 'Courier')
               call rgb (black)
            END IF
            if (wsdone) then
               NLINE=NLINE+1
               IF (NLINE .GE. LOUTMX) GO TO 700
               YCURR=YCURR-SPOUTP
               CALL FONT (PTOUTP, 'Courier')
               call rgb (black)
               CALL STRING ('l', 0, XBOXLO+.5*RWFONT*SZOUTP, YCURR,
     1              '  Doing Water-Scaling')
            END IF
         END IF
      ELSE
         CALL STRING ('c', 0, XCENTR, YCURR, 'NO DIAGNOSTICS')
      END IF
      YBOXLO=YCURR-YBOXSP
      IF (YBOXLO .LE. 0.) GO TO 700
      CALL LINEWD (WDLINE(5))
      CALL RGB (RGBLIN(1,5))
      CALL BOX (XBOXLO, YBOXLO, XBOXHI-XBOXLO, YBOXHI-YBOXLO)
      CALL RGB (BLACK)
      YBOXHI=YBOXLO
      YCURR=YCURR-SPOUTP+YBOXSP
      NLINE=NLINE+1
      IF (NETCOU .GE. 1) THEN
C     -------------------------------------------------------------------
C     Misc. output.
C     -------------------------------------------------------------------
         CALL FONT (PTOUTP, 'Courier-Bold')
         NLINE=NLINE+1
         IF (NLINE .GE. LOUTMX) GO TO 700
         YCURR=YCURR-SPOUTP
         CALL STRING ('c', 0, XCENTR, YCURR, 'MISCELLANEOUS OUTPUT')
         CALL FONT (PTOUTP, 'Courier')
         DO 330 J=1,NETCOU
            NLINE=NLINE+1
            IF (NLINE .GE. LOUTMX) GO TO 700
            YCURR=YCURR-SPOUTP
            CALL STRING ('l', 0, XBOXLO+.5*RWFONT*SZOUTP, YCURR,
     1                   ETCOUT(J))
 330     CONTINUE
         YBOXLO=YCURR-YBOXSP
         IF (YBOXLO .LE. 0.) GO TO 700
         CALL LINEWD (WDLINE(5))
         CALL RGB (RGBLIN(1,5))
         CALL BOX (XBOXLO, YBOXLO, XBOXHI-XBOXLO, YBOXHI-YBOXLO)
         YBOXHI=YBOXLO
         CALL RGB (BLACK)
         YCURR=YCURR-SPOUTP+YBOXSP
         NLINE=NLINE+1
      END IF
      IF (LINCHG(1) .GE. 1) THEN
C     -------------------------------------------------------------------
C     Input changes.
C     -------------------------------------------------------------------
         CALL FONT (PTOUTP, 'Courier-Bold')
         NLINE=NLINE+1
         IF (NLINE .GE. LOUTMX) GO TO 700
         YCURR=YCURR-SPOUTP
         CALL STRING ('c', 0, XCENTR, YCURR, 'INPUT CHANGES')
         CALL FONT (PTOUTP, 'Courier')
         DO 340 J=1,LINCHG(1)
            NLINE=NLINE+1
            IF (NLINE .GE. LOUTMX) GO TO 700
            YCURR=YCURR-SPOUTP
            CALL STRCHK (CHANGE(J,1), CHSTR)
            CALL STRING ('l', 0, XBOXLO+.5*RWFONT*SZOUTP, YCURR, CHSTR)
 340     CONTINUE
         YBOXLO=YCURR-YBOXSP
         IF (YBOXLO .LE. 0.) GO TO 700
         CALL LINEWD (WDLINE(5))
         CALL RGB (RGBLIN(1,5))
         CALL BOX (XBOXLO, YBOXLO, XBOXHI-XBOXLO, YBOXHI-YBOXLO)
         CALL RGB (BLACK)
         YBOXHI=YBOXLO
         YCURR=YCURR-SPOUTP+YBOXSP
      END IF
  700 CALL SHOWPG()
      IF (ipage2 .LE. 0) return
      IF (IPAGE2.EQ.1 .AND. NLINE.LT.LOUTMX) return
C     -----------------------------------------------------------------------
C     Plot tables on page 2.
C     -----------------------------------------------------------------------
      CALL PSETUP (.false., PAGEWD, PAGEHT, LANDSC)
      XORIG=XLEFT
      XAXIS=PAGEX -XORIG -XRIGHT
C     -----------------------------------------------------------------------
C     Title, owner, version & date (as page 1)
C     -----------------------------------------------------------------------
      CALL DASH (0, DSHPAT)
      CALL FONT (PTTITL, 'Helvetica')
      XCENTR=.5*(PAGEX -XLEFT -XRIGHT) +XLEFT
      YCURR=PAGEY -YTOP -SZTITL +sptitl
      do 410 jline = 1, nlines_title
         CALL STRCHK (TITLE_line(jline), CHSTR)
         YCURR=ycurr - sptitl
         if (nlines_title .eq. 1) then
            CALL STRING ('c', 0, XCENTR, YCURR, CHSTR)
         else
            CALL STRING ('l', 0, XORIG+.3, YCURR, CHSTR)
         end if
 410  continue
      IF (NSUBTI .EQ. 1) THEN
         CALL STRCHK (SUBTIT, CHSTR)
         YCURR=YCURR-SPTITL
         CALL STRING ('c', 0, XCENTR, YCURR, CHSTR)
      END IF
      CALL FONT (PTVERS, 'Helvetica-Oblique')
      CALL STRCHK (OWNOUT, CHSTR)
      YCURR=YCURR-SPTITL+SZTITL-SZVERS
      CALL STRING ('c', 0, XCENTR, YCURR, CHSTR)
      CALL STRCHK (VERSIO, CHSTR)
      YCURR=YCURR-SPVERS
      CALL STRING ('l', 0, XORIG+.3, YCURR, CHSTR)
      CALL STRCHK (CHDATE, CHSTR)
      CALL STRING ('r', 0, PAGEX-XRIGHT, YCURR, CHSTR)
C     -----------------------------------------------------------------------
C     Set column dimensions.
C     -----------------------------------------------------------------------
      column_width=rwfont*float(nchlin(2))*szoutp
      xboxlo = xorig
      xboxlo_max = pagex - xright - column_width
      ytop_column = PAGEY -YTOP - FLOAT(NSUBTI+nlines_title)*SPTITL
     1              -2.*SPVERS
      ycurr = ytop_column
C     -----------------------------------------------------------------------
C     For each table:
C       Draw top line.
C       If at bottom, draw side lines (and update positions)
C       If at end of table, draw side lines & bottom line.
C     -----------------------------------------------------------------------
      CALL LINEWD (WDLINE(5))
      CALL RGB (RGBLIN(1,5))
      call line (xboxlo, ycurr, column_width, 0.)
C     ------------------------------------------------------------------
C     Output data that users must return for licensing.
c     NOLINE = T means that there is no license.
c     LETT = 0 if this is not Linux, which means that DATA FOR LICENSING table
c              must be output.
C     ------------------------------------------------------------------
      IF (NOLINE) THEN
         ycurr = ycurr - spoutp
         CALL FONT (PTOUTP, 'Courier-Bold')
         xcentr = xboxlo + .5*column_width
         if (lett .eq. 0) then
            CALL STRING ('c', 0, XCENTR, YCURR, 'DATA FOR LICENSING')
         else
            CALL STRING ('l', 0, XBOXLO+.5*RWFONT*SZOUTP, ycurr,
     1                   'Send the following file:')
         end if
         call rgb (rgberr)
         if (lett .eq. 0) then
            DO 705 JDEV=1,4
               IF (LDEV1(JDEV) .LT. 0.) GO TO 706
               WRITE (CHSTR, '(I10)') LDEV1(JDEV)
               call check_bottom (ycurr, spoutp, xboxlo, outside,
     1              ytop_column, column_width, xboxlo_max)
               if (outside) go to 800
               CALL STRING ('l', 0, XBOXLO+.5*RWFONT*SZOUTP, YCURR,
     1                      CHSTR)
 705        CONTINUE
         else
            call check_bottom (ycurr, spoutp, xboxlo, outside,
     1                         ytop_column, column_width, xboxlo_max)
            if (outside) go to 800
            CALL STRING ('c', 0, XCENTR, YCURR,
     1                   '~/.lcmodel/data-for-licensing')
         end if
 706     CALL FONT (PTOUTP, 'Courier')
         call rgb (black)
         call end_table (ycurr-yboxsp, xboxlo, ytop_column,
     1        column_width)
      END IF
      IF (LINTBL .GE. 1) THEN
C     -------------------------------------------------------------------
C     Concentration table.
C     -------------------------------------------------------------------
         if (noline) then
            call check_bottom (ycurr, spoutp-yboxsp, xboxlo, outside,
     1           ytop_column, column_width, xboxlo_max)
            if (outside) go to 800
         end if
         CALL FONT (PTOUTP, 'Courier-Bold')
         call check_bottom (ycurr, spoutp, xboxlo, outside,
     1        ytop_column, column_width, xboxlo_max)
         if (outside) go to 800
         xcentr = xboxlo + .5*column_width
         call rgb (black)
         CALL STRING ('l', 0, XBOXLO+.5*RWFONT*SZOUTP, YCURR,
     1                TABLE(1,2))
         DO 710 J=2,LINTBL
            call check_bottom (ycurr, spoutp, xboxlo, outside,
     1           ytop_column, column_width, xboxlo_max)
            if (outside) go to 800
            IF (IPCERR(J) .LT. ISDBOL) THEN
               if (ratio_outlier(j)) then
                  call rgb(rgbrat)
                  CALL FONT (PTOUTP, 'Courier-BoldOblique')
               else
                  CALL RGB (RGBBOL)
                  CALL FONT (PTOUTP, 'Courier-Bold')
               end if
            ELSE
               if (ratio_outlier(j)) then
                  call rgb(rgbrat)
                  CALL FONT (PTOUTP, 'Courier-Oblique')
               else
                  CALL RGB (BLACK)
                  CALL FONT (PTOUTP, 'Courier')
               end if
            END IF
            CALL STRING ('l', 0, XBOXLO+.5*RWFONT*SZOUTP, YCURR,
     1                   TABLE(J,2))
            if (j - 1 .eq. ntable_top   .and.   j .lt. lintbl   .and.
     1          ycurr .lt. ytop_column - 1.01 * spoutp) then
               CALL RGB (BLACK)
               ycurr = ycurr - yboxsp
               call line (xboxlo, ycurr, column_width, 0.)
            end if
 710     CONTINUE
         call end_table (ycurr-yboxsp, xboxlo, ytop_column,
     1        column_width)
      end if
C     -------------------------------------------------------------------
C     Diagnostics.
C     -------------------------------------------------------------------
      call check_bottom (ycurr, spoutp-yboxsp, xboxlo, outside,
     1     ytop_column, column_width, xboxlo_max)
      if (outside) go to 800
      CALL RGB (BLACK)
      CALL FONT (PTOUTP, 'Courier-Bold')
      call check_bottom (ycurr, spoutp, xboxlo, outside,
     1     ytop_column, column_width, xboxlo_max)
      if (outside) go to 800
      xcentr = xboxlo + .5*column_width
      IF (LINERR.GE.1 .OR. lline .or..NOT.DOFULL .or. wsdone) THEN
         CALL STRING ('c', 0, XCENTR, YCURR, 'DIAGNOSTICS')
         CALL ERRTBL ()
         DO 720 J=1,LINERR
            call check_bottom (ycurr, spoutp, xboxlo, outside,
     1           ytop_column, column_width, xboxlo_max)
            if (outside) go to 800
            IF (INDEX(ERRORS(J),'info') .gt. 0) THEN
               CALL FONT (PTOUTP, 'Courier')
               CALL RGB (black)
            else if (INDEX(ERRORS(J),'warning') .gt. 0) then
               CALL FONT (PTOUTP, 'Courier-Bold')
               CALL RGB (rgbbol)
            ELSE
               CALL FONT (PTOUTP, 'Courier-Bold')
               CALL RGB (rgberr)
            END IF
            CALL STRING ('l', 0, XBOXLO+.5*RWFONT*SZOUTP, YCURR,
     1                   ERRORS(J))
 720     CONTINUE
         call rgb(black)
         IF (LLINE) THEN
            call check_bottom (ycurr, spoutp, xboxlo, outside,
     1           ytop_column, column_width, xboxlo_max)
            if (outside) go to 800
            CALL FONT (PTOUTP, 'Courier-Bold')
            call rgb (rgberr)
            CALL STRING ('l', 0, XBOXLO+.5*RWFONT*SZOUTP, YCURR,
     1           '  LICENSE REQUIRED FOR THIS.')
            CALL FONT (PTOUTP, 'Courier')
            call rgb (black)
         else
            IF (.NOT.DOFULL) THEN
               call check_bottom (ycurr, spoutp, xboxlo, outside,
     1              ytop_column, column_width, xboxlo_max)
               if (outside) go to 800
               CALL FONT (PTOUTP, 'Courier-Bold')
               call rgb (rgberr)
               CALL STRING ('l', 0, XBOXLO+.5*RWFONT*SZOUTP, YCURR,
     1              '  CRUDE MODEL')
               CALL FONT (PTOUTP, 'Courier')
               call rgb (black)
            END IF
            if (wsdone) then
               call check_bottom (ycurr, spoutp, xboxlo, outside,
     1              ytop_column, column_width, xboxlo_max)
               if (outside) go to 800
               CALL FONT (PTOUTP, 'Courier')
               call rgb (black)
               CALL STRING ('l', 0, XBOXLO+.5*RWFONT*SZOUTP, YCURR,
     1              '  Doing Water-Scaling')
            END IF
         END IF
      ELSE
         CALL STRING ('c', 0, XCENTR, YCURR, 'NO DIAGNOSTICS')
      END IF
      call end_table (ycurr-yboxsp, xboxlo, ytop_column, column_width)
      IF (NETCOU .GE. 1) THEN
C        -------------------------------------------------------------------
C        Misc. output.
C        -------------------------------------------------------------------
         call check_bottom (ycurr, spoutp-yboxsp, xboxlo, outside,
     1        ytop_column, column_width, xboxlo_max)
         if (outside) go to 800
         CALL FONT (PTOUTP, 'Courier-Bold')
         call check_bottom (ycurr, spoutp, xboxlo, outside,
     1        ytop_column, column_width, xboxlo_max)
         if (outside) go to 800
         xcentr = xboxlo + .5*column_width
         CALL STRING ('c', 0, XCENTR, YCURR, 'MISCELLANEOUS OUTPUT')
         CALL FONT (PTOUTP, 'Courier')
         DO 730 J=1,NETCOU
            call check_bottom (ycurr, spoutp, xboxlo, outside,
     1           ytop_column, column_width, xboxlo_max)
            if (outside) go to 800
            CALL STRING ('l', 0, XBOXLO+.5*RWFONT*SZOUTP, YCURR,
     1                   ETCOUT(J))
 730     CONTINUE
         call end_table (ycurr-yboxsp, xboxlo, ytop_column,
     1        column_width)
      END IF
      IF (LINCHG(2) .GE. 1) THEN
C     -------------------------------------------------------------------
C     Input changes.
C     -------------------------------------------------------------------
         call check_bottom (ycurr, spoutp-yboxsp, xboxlo, outside,
     1        ytop_column, column_width, xboxlo_max)
         if (outside) go to 800
         CALL FONT (PTOUTP, 'Courier-Bold')
         call check_bottom (ycurr, spoutp, xboxlo, outside,
     1        ytop_column, column_width, xboxlo_max)
         if (outside) go to 800
         xcentr = xboxlo + .5*column_width
         CALL STRING ('c', 0, XCENTR, YCURR, 'INPUT CHANGES')
         CALL FONT (PTOUTP, 'Courier')
         DO 740 J=1,LINCHG(2)
            call check_bottom (ycurr, spoutp, xboxlo, outside,
     1           ytop_column, column_width, xboxlo_max)
            if (outside) go to 800
            CALL STRCHK (CHANGE(J,2), CHSTR)
            CALL STRING ('l', 0, XBOXLO+.5*RWFONT*SZOUTP, YCURR, CHSTR)
 740     CONTINUE
         call end_table (ycurr-yboxsp, xboxlo, ytop_column,
     1        column_width)
      end if
 800  call showpg ()
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      subroutine end_table (ycurr, xboxlo, ytop_column, column_width)
c
c  Draw side lines and bottom line at end of table.
c
      include 'lcmodel.inc'
      CALL LINEWD (WDLINE(5))
      CALL RGB (RGBLIN(1,5))
      call line (xboxlo, ybott, 0., ytop_column - ybott)
      call line (xboxlo + column_width, ycurr, 0.,
     1        ytop_column - ycurr)
      call line (xboxlo, ycurr, column_width, 0.)
      call rgb (black)
      end
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      subroutine check_bottom (ycurr, decrement, xboxlo, outside,
     1     ytop_column, column_width, xboxlo_max)
c
c  If YCURR is below YBOTT, then draw side lines and shift to the top of next
c    column.
c    OUTSIDE=T if this new column is out of bounds (i.e., if the updated
c              xboxlo > xboxlo_max
c
      include 'lcmodel.inc'
      logical outside
      outside = .false.
      ycurr = ycurr - decrement
      if (ycurr .lt. ybott) then
         CALL LINEWD (WDLINE(5))
         CALL RGB (RGBLIN(1,5))
c        ---------------------------------------------------------------------
c        Draw sidelines for full column.
c        ---------------------------------------------------------------------
         call line (xboxlo, ybott, 0., ytop_column - ybott)
         xboxlo = xboxlo + column_width
         call line (xboxlo, ybott, 0., ytop_column - ybott)
         ycurr = ytop_column - decrement
         outside = xboxlo .gt. xboxlo_max
         if (.not.outside) then
c           ------------------------------------------------------------------
c           Draw top line for new column.
c           ------------------------------------------------------------------
            call line (xboxlo, ytop_column, column_width, 0.)
         end if
         call rgb (black)
      end if
      end
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE HEX(VAL,INUM,FLUSH)
      SAVE CHBUF
      CHARACTER CHBUF(19)*4, CHDIGT(0:15)*1, CHSUBP*6
      INTEGER INUM
      REAL VAL, POWER(4)
        LOGICAL FLUSH
      CHARACTER BUFOUT(20)*132
      LOGICAL STRIP1
      COMMON /BLPS/ BUFOUT, LLPS, STRIP1
      DATA CHDIGT/'0', '1', '2', '3', '4', '5', '6', '7', '8', '9',
     1            'A', 'B', 'C', 'D', 'E', 'F'/,
     2     POWER/4096., 256., 16., 1./
      CHSUBP='HEX'
        IF (.NOT.FLUSH) THEN
         INUM=INUM+1
         REMAIN=INT(MAX(-1.0,MIN(1.0,VAL))*32767.)+32768
         DO 110 J=1,4
            IDIGIT=INT(REMAIN/POWER(J))
            IF (IDIGIT.LE.-1 .OR. IDIGIT.GE.16) CALL ERRMES (1, -5,
     1                                                       CHSUBP)
            CHBUF(INUM)(J:J)=CHDIGT(IDIGIT)
            REMAIN=REMAIN-FLOAT(IDIGIT)*POWER(J)
  110    CONTINUE
         ENDIF
        IF (INUM.EQ.19.OR.(FLUSH.AND.INUM.GT.0))THEN
10       FORMAT(1X, 19A4)
         WRITE(BUFOUT,10)(CHBUF(I),I=1,INUM)
         CALL STRPOU ()
         IF(.NOT.FLUSH)INUM=0
         ENDIF
        END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      subroutine remove_blank_start (str)
c
      implicit none
      character str*(*)
      integer ilen, j, length, nblanks
      external ilen
c
      length = ilen(str)
      do 110 nblanks = 1, length
         if (str(nblanks:nblanks) .ne. ' ') go to 200
 110  continue
 200  nblanks = nblanks - 1
      if (nblanks .gt. 0) then
         do 210 j = 1, length - nblanks
            str(j:j) = str(j + nblanks : j + nblanks)
 210     continue
      end if
      end
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      subroutine toupper_lower (lupper_out, str)
c
c LUPPER_OUT = T to put STR in all upper case
c              F                   lower
c
      implicit none
      character ch(26,2)*(1), str*(*)
      integer iin, iout, jalpha, jstr
      logical lupper_out
      data ch/'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j',
     1        'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't',
     2        'u', 'v', 'w', 'x', 'y', 'z',
     3        'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J',
     1        'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T',
     2        'U', 'V', 'W', 'X', 'Y', 'Z'/
c
      if (lupper_out) then
         iin = 1
         iout = 2
      else
         iin = 2
         iout = 1
      end if
      do 110 jstr = 1, len(str)
         do 120 jalpha = 1, 26
            if (str(jstr:jstr) .eq. ch(jalpha, iin)) then
               str(jstr:jstr) = ch(jalpha, iout)
               go to 110
            end if
 120     continue
 110  continue
      end
c
c
C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c
c Converts g77 Namelist format to that readable by Sun, SGI, DEC.
c
      subroutine fix_g77_namelist (lunit)
      parameter (lscratch=31)
      character line*526
      external ilen
      open (lscratch, status='SCRATCH')
      rewind lunit
c
c     1st copy lunit to lscratch.
c
      do 110 jline = 1, 9999999
         read (lunit, 5110, end=200) line
 5110    format (a)
         llen = ilen(line)
         write (lscratch, 5110) line(1:llen)
 110  continue
c
c     Read lscratch, correct the format, and overwrite lunit.
c
 200  rewind lunit
      rewind lscratch
      do 210 jline = 1, 9999999
         read (lscratch, 5110, end=310) line
         llen = ilen(line)
         if (llen .gt. 520) then
            write (*, 5210) line
 5210       format ('***** The following line exceeds 520 charcters:'/a)
         endif
c        -----------------------------------------------------------------
c        Replace gfortran's quote delimiters with apostrophes.
c        -----------------------------------------------------------------
         do 215 jchar = 1, len(line)
            if (line(jchar:jchar) .eq. '"') line(jchar:jchar) = ''''
 215     continue
         if (index(line, '&') .eq. 1) then
            llen = llen + 1
            do 220 jchar = llen, 3, -1
               line(jchar:jchar) = line(jchar-1:jchar-1)
 220        continue
            line(1:2) = ' $'
         endif
c
         if (line(llen:llen) .eq. '/') then
            write (lunit, 5110) line(1:llen-1)
            line = ' $END'
            llen = 5
         endif
         write (lunit, 5110) line(1:llen)
 210  continue
 310  close (lscratch)
      return
      end
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE ENDRND (XMN, XMX, XSTEP, XINC, XMNRND, XMXRND)
C
C  Finds endpoints enclosing the interval [XMN,XMX] (to within a grace margin
C    of XINC) that are integer multiples of XSTEP.
C
C  XSTEP should be positive, and cannot be zero.
C
      XMNRND=XSTEP*FLOAT(NINT(XMN/XSTEP))
      XGRACE=XMNRND-ABS(XINC)
      IF (XGRACE .GT. XMN) XMNRND=XMNRND-ABS(XSTEP)
      XMXRND=XSTEP*FLOAT(NINT(XMX/XSTEP))
      XGRACE=XMXRND+ABS(XINC)
      IF (XGRACE .LT. XMX) XMXRND=XMXRND+ABS(XSTEP)
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      CHARACTER*8 FUNCTION CHREAL (X, XSTEP, LJUST)
C
C  Outputs X into CHREAL in the shortest FORMAT, assuming that the E FORMAT
C    requires 7 characters for a positive number
C    and that at least 2 significant figures are required
C    and that X+XSTEP must be distinguishable from X.
C
      CHARACTER CH*8, FMTR*10
      LOGICAL LJUST
c     -------------------------------------------------------------------------
c     LJUST = T to left-justify numbers.
c               (Previously, it just returned a blank (commented out below) to
c                avoid rightmost axis number running against the tables in the
c                One_page output.)
c     -------------------------------------------------------------------------
c      if (ljust) then
c         chreal = ' '
c         return
c      end if
      AX=ABS(X)
      ASTEP=ABS(XSTEP)
      IF ((AX.LT.1.E-7 .AND. ASTEP.GT.1.E-5) .OR. AX.LE.0.) THEN
         IF (LJUST) THEN
            CHREAL='0.0'
         ELSE
            CHREAL='  0.0'
         END IF
         RETURN
      END IF
      CH=' '
      IF (AX.LT..0001 .OR. AX.GE.999999.) THEN
         IF (LJUST .AND. X.GE.0.) THEN
            FMTR='(1PE7.1E2)'
         ELSE
            FMTR='(1PE8.1E2)'
         END IF
         WRITE (CH,FMTR) X
         CHREAL=CH
         RETURN
      END IF
      IF (AX .LT. .001) THEN
         RFMT=8.5
      ELSE IF (AX .LT. .01) THEN
         RFMT=7.4
      ELSE IF (AX .LT. .1) THEN
         RFMT=6.3
      ELSE IF (AX .LT. 1.) THEN
         RFMT=5.2
      ELSE IF (AX .LT. 9.95) THEN
         RFMT=4.1
      ELSE
C        ----------------------------------------------------------------------
C        Here provision is made for Fn.0 so that it can be expanded below if
C          necessary to distinguish between neihboring numbers.  Otherwise,
C          I(n-1) will be used.
C        ----------------------------------------------------------------------
         RFMT=FLOAT(INT(ALOG10(FLOAT(NINT(AX))))+3)+.001
      END IF
      DO 210 J=1,4
         FACT=10.**NINT(10.*AMOD(RFMT,1.))
         IF (INT(FACT*(AX+.9999*ASTEP)).NE.INT(FACT*AX) .OR.
     1       RFMT.GE.8.) GO TO 220
         RFMT=RFMT+1.1
  210 CONTINUE
  220 IF (AMOD(RFMT,1.) .LT. .01) THEN
         L=INT(RFMT)
         IF (LJUST) THEN
            L=L-1
            IF (X .GE. 0.) L=L-1
         END IF
 5100    FORMAT ('(I', I1, ')')
         WRITE (FMTR,5100) L
         WRITE (CH,FMTR) NINT(X)
         CHREAL=CH
         RETURN
      END IF
      IF (RFMT.LT.8. .AND. .NOT.LJUST) RFMT=RFMT+1.
      IF (LJUST .AND. X.GE.0.) RFMT=RFMT-1.
 5110 FORMAT ('(F', F3.1, ')')
      WRITE (FMTR,5110) RFMT
      WRITE (CH,FMTR) X
      CHREAL=CH
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE STRCHK(ST,PS)
C
C  PS will be truncated to a max. of 123 characters to prevent BUFOUT from
C    being longer than 132 characters.
C
      EXTERNAL ILEN
      CHARACTER ST*(*),PS*(*)
      PS=' '
      IPS=0
      DO 110 I=1,ILEN(ST)
         IF (IPS .GE. 122) RETURN
         IF (ST(I:I).EQ.'('
     &     .OR.ST(I:I).EQ.')'
     &     .OR.ST(I:I).EQ.'%'
     &     .OR.ST(I:I).EQ.'\') THEN
            PS(IPS+1:IPS+2)='\'//ST(I:I)
            IPS=IPS+2
         ELSE
            IF (IPS .GE. 123) RETURN
               PS(IPS+1:IPS+1)=ST(I:I)
            IPS=IPS+1
         END IF
  110 CONTINUE
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C:TICK
C
C
C
        SUBROUTINE TICK(ANG,OX,OY,LENGTH,GMN,GMX,TCKBEG,TCKINC,GRID)
        INTEGER ANG
        REAL OX,OY,LENGTH,GMN,GMX,TCKBEG,TCKINC,GRID
        INTEGER I,J
      CHARACTER BUFOUT(20)*132
      LOGICAL STRIP1
      COMMON /BLPS/ BUFOUT, LLPS, STRIP1
        I=1
        VAL=TCKBEG
        DO 110 K=1,199
         IF (VAL-GMN .GE. -.001*ABS(TCKINC)) GO TO 115
         VAL=TCKBEG+FLOAT(I)*TCKINC
         I=I+1
  110   CONTINUE
  115   J=0
        DO 120 K=1,199
         IF (VAL-GMX .GT. .001*ABS(TCKINC)) GO TO 125
         VAL=TCKBEG+FLOAT(I)*TCKINC
         I=I+1
         J=J+1
  120   CONTINUE
10      FORMAT(1X, i3,3(1x,f8.4),i5,2(1x,f8.4),' ticks')
  125   WRITE(BUFOUT,10)J,LENGTH*TCKINC/ABS(GMX-GMN),
     &  LENGTH*(TCKBEG-GMN)/ABS(GMX-GMN),GRID,ANG,OX,OY
        CALL STRPOU ()
        END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C:AXIS
C
C
C  LJUST1 = T to skip call to CHREAL and output of rightmost number to avoid
C             it running into the tables at the right.
C
        SUBROUTINE AXIS(ANG,OX,OY,LENGTH,GMN,GMX,
     &    TCKBEG,TCKINC,POS,LJUST1)
      EXTERNAL CHREAL
      INTEGER ANG
      CHARACTER CHREAL*8, chstr*8
      LOGICAL LJUST1
      REAL POS,OX,OY,LENGTH,GMN,GMX,TCKBEG,TCKINC
      REAL VAL
      CHARACTER BUFOUT(20)*132
      LOGICAL STRIP1
      COMMON /BLPS/ BUFOUT, LLPS, STRIP1
10    FORMAT(1X, '(',a,')')
      I=1
      VAL=TCKBEG
      DO 110 K=1,199
       IF (VAL-GMN .GE. -.001*ABS(TCKINC)) GO TO 115
       VAL=TCKBEG+FLOAT(I)*TCKINC
       I=I+1
  110 CONTINUE
  115 J=0
      DO 120 K=1,199
       IF (VAL-GMX .GT. .001*ABS(TCKINC)) GO TO 125
       if (k .eq. 1   .and.   ljust1) then
          chstr=' '
       else
          chstr = CHREAL(VAL, TCKINC, .false.)
       end if
       WRITE(BUFOUT,10) chstr
       CALL STRPOU ()
       VAL=TCKBEG+FLOAT(I)*TCKINC
       I=I+1
       J=J+1
  120 CONTINUE
11    FORMAT(1X, i2,4(1x,f8.4),i5,2(1x,f8.4),' axis')
  125 WRITE(BUFOUT,11)J,POS,LENGTH*TCKINC/ABS(GMX-GMN),
     &LENGTH*(TCKBEG-GMN)/ABS(GMX-GMN),LENGTH,ANG,OX,OY
      CALL STRPOU ()
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C:LINEWD
C
C LINEWD sets the line width using the current units (default cm).
C
        SUBROUTINE LINEWD(WIDTH)
        REAL WIDTH
      CHARACTER BUFOUT(20)*132
      LOGICAL STRIP1
      COMMON /BLPS/ BUFOUT, LLPS, STRIP1
 5110 FORMAT (1X, F8.4, A)
        WRITE(BUFOUT,5110)WIDTH,' setlinewidth'
        CALL STRPOU ()
        END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C:RGB
C
C RGB sets the current color.
C
        SUBROUTINE RGB (RGBV)
        REAL RGBV(3)
      CHARACTER BUFOUT(20)*132
      LOGICAL STRIP1
      COMMON /BLPS/ BUFOUT, LLPS, STRIP1
 5110 FORMAT (1X, 3F8.4, A)
        WRITE(BUFOUT,5110) RGBV, ' setrgbcolor'
        CALL STRPOU ()
        END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C:DASH
C
        SUBROUTINE DASH (IDSHPT, DSHPAT)
        REAL DSHPAT(2,*)
      CHARACTER BUFOUT(20)*132
      LOGICAL STRIP1
      COMMON /BLPS/ BUFOUT, LLPS, STRIP1
10      FORMAT(1X, '[] 0 setdash')
12      FORMAT(1X, '[',f8.4,1x,f8.4,'] 0 setdash')
      IF (IDSHPT.LE.0 .OR. IDSHPT.GE.3) THEN
         WRITE(BUFOUT,10)
      ELSE IF (AMIN1(DSHPAT(1,IDSHPT),DSHPAT(2,IDSHPT)) .GT. 0.) THEN
         WRITE(BUFOUT,12) (DSHPAT(J,IDSHPT),J=1,2)
      ELSE
         WRITE(BUFOUT,10)
      END IF
      CALL STRPOU ()
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C:PLOT
C
C
C
        SUBROUTINE PLOT(N,X,Y,XMN,XMX,YMN,YMX,OX,OY,WD,HT)
        INTEGER N,I,INUM
        REAL X(N),Y(N),XMN,XMX,YMN,YMX,OX,OY,WD,HT
        REAL DX,DY,XN,YN,XX,YX,XPAND,YPAND,XOFF,YOFF
      CHARACTER BUFOUT(20)*132
      LOGICAL STRIP1
      COMMON /BLPS/ BUFOUT, LLPS, STRIP1
        DX=ARBBOX(N,X,XN,XX)
        DY=ARBBOX(N,Y,YN,YX)
        ABSX=ABS(XMX-XMN)
        ABSY=ABS(YMX-YMN)
        IF (AMIN1(ABSX,ABSY,ABS(DX),ABS(DY)) .LE. 0.) RETURN
        XPAND=WD*DX/ABSX
        YPAND=HT*DY/ABSY
        XOFF=WD*(XN-MIN(XMN,XMX))/ABSX
        YOFF=HT*(YN-MIN(YMN,YMX))/ABSY
10      FORMAT(1X, i5,6(1x,f9.4),' plot')
        WRITE(BUFOUT,10)N,XOFF,YOFF,XPAND,YPAND,OX,OY
        CALL STRPOU ()
        INUM=0
        CALL HEX((X(1)-XN)/DX,INUM,.FALSE.)
        CALL HEX((Y(1)-YN)/DY,INUM,.FALSE.)
        DO 110 I=1,N
         CALL HEX((X(I)-XN)/DX,INUM,.FALSE.)
         CALL HEX((Y(I)-YN)/DY,INUM,.FALSE.)
  110   CONTINUE
        CALL HEX(0.,INUM,.TRUE.)
        END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C:PLOT_gap
C
c Skips connecting lines thru gaps [detected by changes in X(J)-X(J-1)]
C
      SUBROUTINE PLOT_gap(N,X,Y,XMN,XMX,YMN,YMX,OX,OY,WD,HT)
      INTEGER N,I,INUM
      REAL X(N),Y(N),XMN,XMX,YMN,YMX,OX,OY,WD,HT
      REAL DX,DY,XN,YN,XX,YX,XPAND,YPAND,XOFF,YOFF
      CHARACTER BUFOUT(20)*132
      LOGICAL STRIP1
      COMMON /BLPS/ BUFOUT, LLPS, STRIP1
      DX=ARBBOX(N,X,XN,XX)
      DY=ARBBOX(N,Y,YN,YX)
      ABSX=ABS(XMX-XMN)
      ABSY=ABS(YMX-YMN)
      IF (AMIN1(ABSX,ABSY,ABS(DX),ABS(DY)) .LE. 0.) RETURN
      XPAND=WD*DX/ABSX
      YPAND=HT*DY/ABSY
      XOFF=WD*(XN-MIN(XMN,XMX))/ABSX
      YOFF=HT*(YN-MIN(YMN,YMX))/ABSY
      nend = 0
      do 110 jgap = 1, 10
         nstart = nend + 1
         if (nstart .ge. n) return
         xtol = .5 * abs(x(nstart + 1) - x(nstart))
         do 120 jx = nstart + 2, n
            if (abs(x(jx) - 2. * x(jx-1) + x(jx-2)) .gt. xtol)
     1         go to 130
 120     continue
 130     nend = jx - 1
 5110    FORMAT(1X, i5,6(1x,f9.4),' plot')
         WRITE(BUFOUT,5110) nend-nstart+1, XOFF,YOFF,XPAND,YPAND,OX,OY
         CALL STRPOU ()
         INUM=0
         CALL HEX((X(nstart)-XN)/DX,INUM,.FALSE.)
         CALL HEX((Y(nstart)-YN)/DY,INUM,.FALSE.)
         DO 150 I=nstart, nend
            CALL HEX((X(I)-XN)/DX,INUM,.FALSE.)
            CALL HEX((Y(I)-YN)/DY,INUM,.FALSE.)
 150     CONTINUE
         CALL HEX(0.,INUM,.TRUE.)
 110  continue
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
        REAL FUNCTION ARBBOX(N,A,AMN,AMX)
        INTEGER N
        REAL A(N),AMN,AMX
        AMN=A(1)
        AMX=A(N)
        DO 110 I=1,N
         AMN=MIN(AMN,A(I))
         AMX=MAX(AMX,A(I))
  110   CONTINUE
        ARBBOX=ABS(AMX-AMN)
        IF(ARBBOX.EQ.0.)ARBBOX=1.0
        END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C:BOX
C
C BOX draws box defined by the origin, the width and the height.
C
        SUBROUTINE BOX(OX,OY,WD,HT)
        REAL OX,OY,WD,HT
      CHARACTER BUFOUT(20)*132
      LOGICAL STRIP1
      COMMON /BLPS/ BUFOUT, LLPS, STRIP1
10      FORMAT(1X, 4(f8.4,1x),'box')
        WRITE(BUFOUT,10)WD,HT,OX,OY
        CALL STRPOU ()
        END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C:LINE
C
C LINE draws a line from the origin to the specified width and height.
C Intensive use of LINE could produce very large files.
C
        SUBROUTINE LINE(OX,OY,WD,HT)
        REAL OX,OY,WD,HT
      CHARACTER BUFOUT(20)*132
      LOGICAL STRIP1
      COMMON /BLPS/ BUFOUT, LLPS, STRIP1
10      FORMAT(1X, 4(f8.4,1x),'li')
        WRITE(BUFOUT,10)WD,HT,OX,OY
        CALL STRPOU ()
        END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C:PSETUP
C
      SUBROUTINE PSETUP (top_of_file, WD, HT, LANDSC)
      save kpage
      LOGICAL LANDSC, top_of_file
      CHARACTER BUFOUT(20)*132
      LOGICAL STRIP1
      COMMON /BLPS/ BUFOUT, LLPS, STRIP1
      data kpage/0/
C     -------------------------------------------------------------------------
C     Initialize output buffer BUFOUT.
C     -------------------------------------------------------------------------
      DO 110 J=1,20
         BUFOUT(J)=' '
  110 CONTINUE
      if (top_of_file) then
 10      FORMAT(1X, '%!PS-Adobe-2.0',/,1X,
     &          '%%Creator: LCModel',/,1X,
     &          '%%BoundingBox: 0 0 ',i4,' ',i4,/,1X,
     &          '%%EndComments')
         WRITE (BUFOUT,10) NINT(WD*72.0/2.54),NINT(HT*72.0/2.54)
         CALL STRPOU ()
         kpage = 0
         return
      end if
11      FORMAT(1X, '/MPGdict 100 dict def MPGdict begin',/,1X,
     &  '/bd{bind def}def',/,1X,
     &  '/set{exch def}bd',/,1X,
     &  '/cm{initmatrix 72 2.54 div dup scale 0 ',
     &  'setgray .015 setlinewidth',/,1X,
     &  '  1 selectplot /Helvetica 11 font}bd',/,1X,
     &  '/font{/pitch exch 72 div 2.54 mul def ',
     &  'findfont pitch scalefont setfont}bd',/,1X,
     &  '/s{show}bd',/,1X,
     &  '/lst{exec}bd')
12      FORMAT(1X, '/rst{stlen neg 0 rmoveto exec}bd',/,1X,
     &  '/cst{stlen -2 div 0 rmoveto exec}bd',/,1X,
     &  '/r{rotate}bd',/,1X,
     &  '/m{moveto}bd',/,1X,
     &  '/li{newpath moveto rlineto stroke}bd',/,1X,
     &  '/boxpath{newpath moveto dup 3 1 roll 0 exch',
     &  ' rlineto 0 rlineto 0 exch neg ',/,1X,
     &  ' rlineto closepath} bd',/,1X,
     &  '/box{boxpath stroke}def',/,1X,
     &  '/go{save exch 1 add 1 roll translate}bd')
13      FORMAT(1X, '/axis{',/,1X,
     &  '  8 go rotate',/,1X,
     &  '  /wd set',/,1X,
     &  '  /beg set',/,1X,
     &  '  /inc set',/,1X,
     &  '  /tick exch neg pitch mul def',/,1X,
     &  '  /n set',/,1X,
     &  '  newpath 0 0 moveto wd 0 lineto stroke',/,1X,
     &  '  newpath beg n 1 sub inc mul add 0 moveto',/,1X,
     &  '  n{0 tick 0.6 mul rlineto',/,1X,
     &  '    0 tick 0 gt{0.25}{1}ifelse tick mul rmoveto',/,1X,
     &  '    exch currentpoint pop inc sub exch',/,1X,
     &  '    dup stringwidth pop -0.5 mul 0 rmoveto show',/,1X,
     &  '    stroke 0 moveto}repeat',/,1X,
     &  '  restore}bd')
14      FORMAT(1X, '/readflt{currentfile 2 string readhexstring pop ',
     &  'dup 1 get exch 0 get',/,1X,
     &  '  256 mul add 32768 sub 32767 div mul}bd',/,1X,
     &  '/selectplot{/n set /plotproc',/,1X,
     &  '  n 1 eq{{lineto}}if',/,1X,
     &  '  def}bd',/,1X,
     &  '/plot{',/,1X,
     &  '  7 go /ypand set /xpand set /yoff set /xoff set /n set')
15      FORMAT(1X, '  /xy{xpand readflt xoff add ypand ',
     &  'readflt yoff add}bd',/,1X,
     &  '  xy moveto',/,1X,
     &  '  n{xy lineto currentpoint stroke moveto}repeat',/,1X,
     &  '  restore',/,1X,
     &  '}bd')
17      FORMAT(1X, '/ticks{',/,1X,
     &  '  7 go rotate',/,1X,
     &  '  /wd set',/,1X,
     &  '  /beg set',/,1X,
     &  '  /inc set',/,1X,
     &  '  /n set',/,1X,
     &  '  newpath beg 0 moveto',/,1X,
     &  '  n{0 wd rlineto currentpoint pop inc add 0',/,1X,
     &  '  stroke moveto}repeat',/,1X,
     &  ' restore}bd')
20      FORMAT(1X, '/stlen{',/,1X,
     &  '  dup currentpoint 3 -1 roll',/,1X,
     &  '  /len 0 def',/,1X,
     &  '  /dlen 0 store',/,1X,
     &  '  /s{',/,1X,
     &  '   stringwidth pop len add dlen add /len exch def',/,1X,
     &  '   /dlen 0 store}bd',/,1X,
     &  '  exec ',/,1X,
     &  '  moveto /s{show}bd len',/,1X,
     &  '  }bd')

        WRITE(BUFOUT,11)
        CALL STRPOU ()
        WRITE(BUFOUT,12)
        CALL STRPOU ()
        WRITE(BUFOUT,13)
        CALL STRPOU ()
        WRITE(BUFOUT,14)
        CALL STRPOU ()
        WRITE(BUFOUT,15)
        CALL STRPOU ()
        WRITE(BUFOUT,17)
        CALL STRPOU ()
        WRITE(BUFOUT,20)
        CALL STRPOU ()

        kpage = kpage + 1
30      FORMAT(1X, 'end',/,1X, '%%EndProlog',/, ' %%Page:', 2i4/
     1       1X, 'MPGdict begin cm')
        WRITE(BUFOUT,30) kpage, kpage
        CALL STRPOU ()
31      FORMAT(1X, '0 ',f7.4,' translate -90 rotate')
        IF (LANDSC) WRITE(BUFOUT,31)HT
        CALL STRPOU ()
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C:FONT
C
C For convenience the FONT is called using the conventional
C pitch size of popular word-processing softwares; thus a
C 11 pitch size font will be 0.388 cm high (i.e. 11./72.*2.54).
C The name of the fonts can be any fonts available on your
C PostScript printer; typically;
C
C       CALL FONT(PITCH,'Helvetica-Bold')
C       CALL FONT(PITCH,'Times-Roman')
C       CALL FONT(PITCH,'Times-Italic')
C       CALL FONT(PITCH,'Times-Bold')
C       CALL FONT(PITCH,'Courier')
C       CALL FONT(PITCH,'Courier-Bold')
C       CALL FONT(PITCH,'Palatino-Bold')
C       CALL FONT(PITCH,'Palatino-Italic')
C       CALL FONT(PITCH,'Symbol')
C
        SUBROUTINE FONT(PITCH,POLICE)
      EXTERNAL ILEN
        CHARACTER POLICE*(*)
        REAL PITCH
      CHARACTER BUFOUT(20)*132
      LOGICAL STRIP1
      COMMON /BLPS/ BUFOUT, LLPS, STRIP1
10      FORMAT(1X, '/',a,' ',f8.4,' font')
        WRITE(BUFOUT,10)POLICE(1:ILEN(POLICE)),PITCH
        CALL STRPOU ()
        END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C:STRING
C
C STRING prints a character chain.  The string can be left
C justified ('l'), right justified ('r') or centered ('c').
C It can be written at an angle (integer in degrees) from
C the specified origin.
C Some editing commands have been incorporated for convenience, but a plain
C text string will always be easier to print.  A special care
C with '(', ')' and '%' signs should be made since they are
C interprated by PostScript.  They should be replaced by
C respectively '/('  '/)' and '/%'.
C
        SUBROUTINE STRING(FLUSH,ANG,OX,OY,ST)
        INTEGER ANG
        REAL OX,OY
        CHARACTER ST*(*),FLUSH*1
      CHARACTER BUFOUT(20)*132
      LOGICAL STRIP1
      COMMON /BLPS/ BUFOUT, LLPS, STRIP1
10      FORMAT(1X, i4,' r')
11      FORMAT(1X, 2(f7.3,1x), 'm ',i4,' r')
12      FORMAT(1X, 2(f7.3,1x),'m')
        IF (ABS(ANG) .GT. 1.E-4) THEN
         WRITE(BUFOUT,11)OX,OY,ANG
         CALL STRPOU ()
         CALL SHOW(FLUSH,ST)
         WRITE(BUFOUT,10)-ANG
         CALL STRPOU ()
        ELSE
         WRITE(BUFOUT,12)OX,OY
         CALL STRPOU ()
         CALL SHOW(FLUSH,ST)
        ENDIF
        END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
        SUBROUTINE SHOW(FLUSH,ST)
      EXTERNAL ILEN
        CHARACTER ST*(*),FLUSH*1
      CHARACTER BUFOUT(20)*132
      LOGICAL STRIP1
      COMMON /BLPS/ BUFOUT, LLPS, STRIP1
10      FORMAT(1X, '{(',a,')s}',a1, 'st')
        WRITE(BUFOUT,10)ST(1:ILEN(ST)),FLUSH
        CALL STRPOU ()
        END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C:SHOWPG
C
        SUBROUTINE SHOWPG()
      CHARACTER BUFOUT(20)*132
      LOGICAL STRIP1
      COMMON /BLPS/ BUFOUT, LLPS, STRIP1
10      FORMAT(1X, 'showpage')
        WRITE(BUFOUT,10)
        CALL STRPOU ()
        END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE ENDPS ()
      CHARACTER BUFOUT(20)*132
      LOGICAL STRIP1
      COMMON /BLPS/ BUFOUT, LLPS, STRIP1
 5110 FORMAT (1X, '%%Trailer',/,1X, '%%EOF')
      WRITE (BUFOUT, 5110)
      CALL STRPOU ()
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
        INTEGER FUNCTION ILEN(ST)
        CHARACTER ST*(*)
        ILEN=LEN(ST)
        DO 110 J=1,IABS(ILEN)
           IF (ST(ILEN:ILEN).NE.' ') RETURN
           ILEN=ILEN-1
  110   CONTINUE
        ILEN=1
        END
C
C
C  +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE STRPOU ()
C
C  Strips the first (blank) character from each record in BUFOUT if STRIP1=T.
C  Writes BUFOUT onto LLPS.
C  Fills first characters of BUFOUT with blanks.
C
      EXTERNAL ILEN
      CHARACTER BUFOUT(20)*132
      LOGICAL STRIP1
      COMMON /BLPS/ BUFOUT, LLPS, STRIP1
      IF (STRIP1) THEN
         ICOL1=2
      ELSE
         ICOL1=1
      END IF
      DO 160 J=1,20
         L=ILEN(BUFOUT(J))
         IF (L.LE.ICOL1 .AND. BUFOUT(J)(ICOL1:ICOL1).EQ.' ') GO TO 200
         WRITE (LLPS,5160) BUFOUT(J)(ICOL1:L)
 5160    FORMAT (A)
  160 CONTINUE
  200 DO 210 J=1,20
         BUFOUT(J)=' '
  210 CONTINUE
      END
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE csft_r (DATAT, ft, ncap)
C
C  Input:
C    DATAT(J), J=1,Ncap
C  Output:
C    FT = FT of DATAT WITH rearrangement.  The FT is normalized; i.e.,
C         the sum is divided by sqrt(Ncap).  This is compatible with DCFFT
C         and CFFTIN and Siemens FFTs.
c
c Uses formula and notation of IMSL Math, p 716.
c
      complex cfact, cterm, datat(ncap), ft(ncap)
      TwoPI = 6.28318530717959d0
      do 150 m = 1, ncap
         cterm = (1., 0.)
         ft(m) = (0., 0.)
         cfact = cexp(cmplx(0., -twopi * float(m - 1) / float(ncap)))
         cterm = (1., 0.)
         do 180 n = 1, ncap
            ft(m) = ft(m) + datat(n) * cterm
            cterm = cterm * cfact
 180     continue
 150  continue
C     ------------------------------------------------------------------------
C     Scale & rearrange
C     ------------------------------------------------------------------------
      FACT=1./SQRT(FLOAT(Ncap))
      nunfil = ncap / 2
      DO 210 J=1,nunfil
         CTERM=FT(NUNFIL+J)
         FT(NUNFIL+J)=FT(J) * fact
         FT(J)=CTERM * fact
  210 CONTINUE
      END
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE csftin_r (ft, ftwork, ftinv, ncap)
C
C  Input:
C    Rearranged FT(J), J=1,N.  This will be unrearranged (in FTWORK) for the
c       inverse FFT.
c    FTWORK is an extra array used for the unrearranged FT.
C  Output:
C    FTINV = inverse FFT of FT without rearrangement.  FTINV is normalized;
C             i.e., the sum is divided by sqrt(N).  This is compatible with
C             DCFFT and CFFT and Siemens FFTs.
c Uses formula and notation of IMSL Math, p 716.
c
c     -------------------------------------------------------------------------
c     Unrearrange.
c     -------------------------------------------------------------------------
      complex cfact, cterm, ft(ncap), ftinv(ncap), ftwork(ncap)
      TwoPI = 6.28318530717959d0
      nunfil = ncap / 2
      do 110 J=1,nunfil
         ftwork(j)=FT(NUNFIL+J)
         FTwork(NUNFIL+J)=FT(J)
  110 CONTINUE
      do 150 n = 1, ncap
         cterm = (1., 0.)
         ftinv(n) = (0., 0.)
         cfact = cexp(cmplx(0., twopi * float(n - 1) / float(ncap)))
         cterm = (1., 0.)
         do 180 m = 1, ncap
            ftinv(n) = ftinv(n) + ftwork(m) * cterm
            cterm = cterm * cfact
 180     continue
 150  continue
      FACT=1./SQRT(FLOAT(Ncap))
      DO 210 J=1,Ncap
         ftinv(J)=ftinv(J)*FACT
  210 CONTINUE
      END
C
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE SEQTOT (DATAT, DATAF, NUNFIL, LWFFT, WFFTC)
C
C  DATAT = NUNFIL sequentially acquired Bruker time-domain data on input.
C        = NUNFIL time-domain data after the correction (which includes
C          complex-conjugation of the time-domain data, since the Bruker
C          quadrature data are apparently at -90, rather than 90 deg)
C          on output.
C  DATAF : must be at least 2*NUNFIL long.
C  There cannot be any peaks in the last RENDS*NUNFIL/2 spectrum points at
C    each end.
C
      COMPLEX ENDAVG, DATAT(NUNFIL), DATAF(2*NUNFIL)
      REAL WFFTC(*)
      DATA NZERO/20/, RENDS/.05/, RZERO/.01/
C     -------------------------------------------------------------------------
C     Scale by sqrt(2) because the inverse FFT will be twice as long and
C       scaled by 1/sqrt(2*NUNFIL) rather than 1/sqrt(NUNFIL).
C     -------------------------------------------------------------------------
      DO 110 J=1,NUNFIL
         DATAF(J)=CMPLX(0., -AIMAG(DATAT(J))*1.414214)
  110 CONTINUE
      CALL CFFT (DATAF, DATAF, NUNFIL, LWFFT, WFFTC)
C     -------------------------------------------------------------------------
C     Fill FFT of imaginary part of DATAT with the mean of the high-frequency
C       ends.
C     -------------------------------------------------------------------------
      NHALF=NUNFIL/2
      NENDS=NINT(RENDS*FLOAT(NHALF))
      ENDAVG=(0.,0.)
      DO 115 J=NHALF-NENDS+1, NHALF+NENDS
         ENDAVG=ENDAVG+DATAF(J)
  115 CONTINUE
      ENDAVG=ENDAVG/FLOAT(2*NENDS)
      DO 120 J=NHALF+1,NUNFIL
         DATAF(J+NUNFIL)=DATAF(J)
         DATAF(J)=ENDAVG
         DATAF(J+NHALF)=ENDAVG
  120 CONTINUE
      NDATA=2*NUNFIL
      CALL CFFTIN (DATAF, DATAF, NDATA, LWFFT, WFFTC)
C     -------------------------------------------------------------------------
C     Insert interpolated imag. part into DATAT [except for first point, which
C       will be left (extrapolated) as the first original imag. point; this
C       will be corrected below anyway].
C     -------------------------------------------------------------------------
      DATAT(1)=CONJG(DATAT(1))
      JF=0
      DO 130 J=2,NUNFIL
         JF=JF+2
         DATAT(J)=CMPLX(REAL(DATAT(J)), AIMAG(DATAF(JF)))
  130 CONTINUE
C     -------------------------------------------------------------------------
C     Adjust DATAT(1) so that the high-frequency ends of the spectrum are about
C       zero.
C     -------------------------------------------------------------------------
      CALL CFFT (DATAT, DATAF, NUNFIL, LWFFT, WFFTC)
      ENDAVG=(0.,0.)
      DO 150 J=NHALF-NENDS+1, NHALF+NENDS
         ENDAVG=ENDAVG+DATAF(J)
  150 CONTINUE
      ENDAVG=ENDAVG/FLOAT(2*NENDS)
      DATAT(1)=DATAT(1)-ENDAVG
C     -------------------------------------------------------------------------
C     Zero up to RZERO*NUNFIL points if CABS of the preceding NZERO points are
C       all smaller.
C     -------------------------------------------------------------------------
      DO 210 JZERO=MAX0(1,NINT((1.-RZERO)*FLOAT(NUNFIL))), NUNFIL
         TERM=REAL(DATAT(JZERO))**2+AIMAG(DATAT(JZERO))**2
         IF (NZERO .GE. JZERO) RETURN
         DO 220 J=JZERO-1, JZERO-NZERO, -1
            IF (TERM .LE. REAL(DATAT(J))**2+AIMAG(DATAT(J))**2) GO TO
     1                                                          210
  220    CONTINUE
         DO 230 J=JZERO,NUNFIL
            DATAT(J)=(0.,0.)
  230    CONTINUE
         RETURN
  210 CONTINUE
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE CFFTIN (FT, FTINV, N, LWFFT,
     1                   WFFTC)
C
C  Input:
C    FT(J), J=1,N
C    LWFFT = argument in last call to CALL FFTCI (LWFFT, WFFTC)
C  Output:
C    FTINV = inverse FFT of FT without rearrangement.  FFTINV is normalized;
C            i.e., the sum is divided by sqrt(N).  This is compatible with
C            DCFFT and CFFT and Siemens FFTs.
C
      COMPLEX FT(N), FTINV(N)
      REAL WFFTC(4*N+15)
      IF (N. NE. LWFFT) THEN
         CALL FFTCI (N, WFFTC)
         LWFFT=N
      END IF
      CALL F2TCB (N, FT, FTINV, WFFTC)
      FACT=1./SQRT(FLOAT(N))
      DO 210 J=1,N
         FTINV(J)=FTINV(J)*FACT
  210 CONTINUE
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE CFFTIN_r (FT, ftwork, FTINV, N, LWFFT,
     1                     WFFTC)
C
C  Input:
C    Rearranged FT(J), J=1,N.  This will be unrearranged (in FTWORK) for the
c       inverse FFT.
c    FTWORK is an extra array used for the unrearranged FT.  So, FT is
c           unchanged (unless FT & FTINV are identical in calling program).
C    LWFFT = argument in last call to CALL FFTCI (LWFFT, WFFTC)
C  Output:
C    FTINV = inverse FFT of FT without rearrangement.  FFTINV is normalized;
C            i.e., the sum is divided by sqrt(N).  This is compatible with
C            DCFFT and CFFT and Siemens FFTs.
C
      COMPLEX FT(N), FTINV(N), ftwork(n)
      REAL WFFTC(4*N+15)
c     -------------------------------------------------------------------------
c     Unrearrange.
c     -------------------------------------------------------------------------
      nunfil = n / 2
      do 110 J=1,nunfil
         ftwork(j)=FT(NUNFIL+J)
         FTwork(NUNFIL+J)=FT(J)
  110 CONTINUE
      IF (N .NE. LWFFT) THEN
         CALL FFTCI (N, WFFTC)
         LWFFT=N
      END IF
      CALL F2TCB (N, FTwork, FTINV, WFFTC)
      FACT=1./SQRT(FLOAT(N))
      DO 210 J=1,N
         FTINV(J)=FTINV(J)*FACT
  210 CONTINUE
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE CFFT (DATAT, FT, N, LWFFT,
     1                 WFFTC)
C
C  Input:
C    DATAT(J), J=1,N
C    LWFFT = argument in last call to CALL FFTCI (LWFFT, WFFTC)
C  Output:
C    FT = FFT of DATAT without rearrangement.  The FFT is normalized; i.e.,
C             the sum is divided by sqrt(N).  This is compatible with DCFFT
C             and CFFTIN and Siemens FFTs.
C
      COMPLEX DATAT(N), FT(N)
      REAL WFFTC(4*N+15)
      IF (N .NE. LWFFT) THEN
         CALL FFTCI (N, WFFTC)
         LWFFT=N
      END IF
      CALL F2TCF (N, DATAT, FT, WFFTC)
      FACT=1./SQRT(FLOAT(N))
      DO 210 J=1,N
         FT(J)=FT(J)*FACT
  210 CONTINUE
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE CFFT_r (DATAT, FT, N, LWFFT,
     1                   WFFTC)
C
C  Input:
C    DATAT(J), J=1,N
C    LWFFT = argument in last call to CALL FFTCI (LWFFT, WFFTC)
C  Output:
C    FT = FFT of DATAT WITH rearrangement.  The FFT is normalized; i.e.,
C             the sum is divided by sqrt(N).  This is compatible with DCFFT
C             and CFFTIN and Siemens FFTs.
C
      COMPLEX cterm, DATAT(N), FT(N)
      REAL WFFTC(4*N+15)
      IF (N .NE. LWFFT) THEN
         CALL FFTCI (N, WFFTC)
         LWFFT=N
      END IF
      CALL F2TCF (N, DATAT, FT, WFFTC)
C     ------------------------------------------------------------------------
C     Scale & rearrange
C     ------------------------------------------------------------------------
      FACT=1./SQRT(FLOAT(N))
      nunfil = n / 2
      DO 210 J=1,nunfil
         CTERM=FT(NUNFIL+J)
         FT(NUNFIL+J)=FT(J) * fact
         FT(J)=CTERM * fact
  210 CONTINUE
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE DF2TCF (N, C, YOUT, WSAVE)
C
C  From Paul Swarztrauber's FFTPACK
C
      DOUBLE PRECISION C(*), YOUT(*), WSAVE(*)
      DO 110 J=1,2*N
         YOUT(J)=C(J)
  110 CONTINUE
      IF (N .EQ. 1) RETURN
      IW1 = N+N+1
      IW2 = IW1+N+N
      CALL DCFTF1 (N,YOUT,WSAVE,WSAVE(IW1),WSAVE(IW2))
      RETURN
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE DCFTF1 (N,C,CH,WA,IFAC)
C
C  From Paul Swarztrauber's FFTPACK
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       CH(*)      ,C(*)       ,WA(*)      ,IFAC(*)
      NF = IFAC(2)
      NA = 0
      L1 = 1
      IW = 1
      DO 116 K1=1,NF
         IP = IFAC(K1+2)
         L2 = IP*L1
         IDO = N/L2
         IDOT = IDO+IDO
         IDL1 = IDOT*L1
         IF (IP .NE. 4) GO TO 103
         IX2 = IW+IDOT
         IX3 = IX2+IDOT
         IF (NA .NE. 0) GO TO 101
         CALL DPASF4 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
         GO TO 102
  101    CALL DPASF4 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
  102    NA = 1-NA
         GO TO 115
  103    IF (IP .NE. 2) GO TO 106
         IF (NA .NE. 0) GO TO 104
         CALL DPASF2 (IDOT,L1,C,CH,WA(IW))
         GO TO 105
  104    CALL DPASF2 (IDOT,L1,CH,C,WA(IW))
  105    NA = 1-NA
         GO TO 115
  106    IF (IP .NE. 3) GO TO 109
         IX2 = IW+IDOT
         IF (NA .NE. 0) GO TO 107
         CALL DPASF3 (IDOT,L1,C,CH,WA(IW),WA(IX2))
         GO TO 108
  107    CALL DPASF3 (IDOT,L1,CH,C,WA(IW),WA(IX2))
  108    NA = 1-NA
         GO TO 115
  109    IF (IP .NE. 5) GO TO 112
         IX2 = IW+IDOT
         IX3 = IX2+IDOT
         IX4 = IX3+IDOT
         IF (NA .NE. 0) GO TO 110
         CALL DPASF5 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))
         GO TO 111
  110    CALL DPASF5 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))
  111    NA = 1-NA
         GO TO 115
  112    IF (NA .NE. 0) GO TO 113
         CALL DPASF (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))
         GO TO 114
  113    CALL DPASF (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))
  114    IF (NAC .NE. 0) NA = 1-NA
  115    L1 = L2
         IW = IW+(IP-1)*IDOT
  116 CONTINUE
      IF (NA .EQ. 0) RETURN
      N2 = N+N
      DO 117 I=1,N2
         C(I) = CH(I)
  117 CONTINUE
      RETURN
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE DPASF (NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)
C
C  From Paul Swarztrauber's FFTPACK
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       CH(IDO,L1,IP)          ,CC(IDO,IP,L1)          ,
     1                C1(IDO,L1,IP)          ,WA(*)      ,C2(IDL1,IP),
     2                CH2(IDL1,IP)
      IDOT = IDO/2
      NT = IP*IDL1
      IPP2 = IP+2
      IPPH = (IP+1)/2
      IDP = IP*IDO
C
      IF (IDO .LT. L1) GO TO 106
      DO 103 J=2,IPPH
         JC = IPP2-J
         DO 102 K=1,L1
            DO 101 I=1,IDO
               CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)
               CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)
  101       CONTINUE
  102    CONTINUE
  103 CONTINUE
      DO 105 K=1,L1
         DO 104 I=1,IDO
            CH(I,K,1) = CC(I,1,K)
  104    CONTINUE
  105 CONTINUE
      GO TO 112
  106 DO 109 J=2,IPPH
         JC = IPP2-J
         DO 108 I=1,IDO
            DO 107 K=1,L1
               CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)
               CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)
  107       CONTINUE
  108    CONTINUE
  109 CONTINUE
      DO 111 I=1,IDO
         DO 110 K=1,L1
            CH(I,K,1) = CC(I,1,K)
  110    CONTINUE
  111 CONTINUE
  112 IDL = 2-IDO
      INC = 0
      DO 116 L=2,IPPH
         LC = IPP2-L
         IDL = IDL+IDO
         DO 113 IK=1,IDL1
            C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2)
            C2(IK,LC) = -WA(IDL)*CH2(IK,IP)
  113    CONTINUE
         IDLJ = IDL
         INC = INC+IDO
         DO 115 J=3,IPPH
            JC = IPP2-J
            IDLJ = IDLJ+INC
            IF (IDLJ .GT. IDP) IDLJ = IDLJ-IDP
            WAR = WA(IDLJ-1)
            WAI = WA(IDLJ)
            DO 114 IK=1,IDL1
               C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J)
               C2(IK,LC) = C2(IK,LC)-WAI*CH2(IK,JC)
  114       CONTINUE
  115    CONTINUE
  116 CONTINUE
      DO 118 J=2,IPPH
         DO 117 IK=1,IDL1
            CH2(IK,1) = CH2(IK,1)+CH2(IK,J)
  117    CONTINUE
  118 CONTINUE
      DO 120 J=2,IPPH
         JC = IPP2-J
         DO 119 IK=2,IDL1,2
            CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC)
            CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC)
            CH2(IK,J) = C2(IK,J)+C2(IK-1,JC)
            CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC)
  119    CONTINUE
  120 CONTINUE
      NAC = 1
      IF (IDO .EQ. 2) RETURN
      NAC = 0
      DO 121 IK=1,IDL1
         C2(IK,1) = CH2(IK,1)
  121 CONTINUE
      DO 123 J=2,IP
         DO 122 K=1,L1
            C1(1,K,J) = CH(1,K,J)
            C1(2,K,J) = CH(2,K,J)
  122    CONTINUE
  123 CONTINUE
      IF (IDOT .GT. L1) GO TO 127
      IDIJ = 0
      DO 126 J=2,IP
         IDIJ = IDIJ+2
         DO 125 I=4,IDO,2
            IDIJ = IDIJ+2
            DO 124 K=1,L1
               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J)
               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J)
  124       CONTINUE
  125    CONTINUE
  126 CONTINUE
      RETURN
  127 IDJ = 2-IDO
      DO 130 J=2,IP
         IDJ = IDJ+IDO
         DO 129 K=1,L1
            IDIJ = IDJ
            DO 128 I=4,IDO,2
               IDIJ = IDIJ+2
               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J)
               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J)
  128       CONTINUE
  129    CONTINUE
  130 CONTINUE
      RETURN
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE DPASF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4)
C
C  From Paul Swarztrauber's FFTPACK
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       CC(IDO,5,L1)           ,CH(IDO,L1,5)           ,
     1                WA1(*)     ,WA2(*)     ,WA3(*)     ,WA4(*)
      DATA TR11,TI11,TR12,TI12 /.309016994374947D0,-.951056516295154D0,
     1-.809016994374947D0,-.587785252292473D0/
      IF (IDO .NE. 2) GO TO 102
      DO 101 K=1,L1
         TI5 = CC(2,2,K)-CC(2,5,K)
         TI2 = CC(2,2,K)+CC(2,5,K)
         TI4 = CC(2,3,K)-CC(2,4,K)
         TI3 = CC(2,3,K)+CC(2,4,K)
         TR5 = CC(1,2,K)-CC(1,5,K)
         TR2 = CC(1,2,K)+CC(1,5,K)
         TR4 = CC(1,3,K)-CC(1,4,K)
         TR3 = CC(1,3,K)+CC(1,4,K)
         CH(1,K,1) = CC(1,1,K)+TR2+TR3
         CH(2,K,1) = CC(2,1,K)+TI2+TI3
         CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3
         CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3
         CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3
         CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3
         CR5 = TI11*TR5+TI12*TR4
         CI5 = TI11*TI5+TI12*TI4
         CR4 = TI12*TR5-TI11*TR4
         CI4 = TI12*TI5-TI11*TI4
         CH(1,K,2) = CR2-CI5
         CH(1,K,5) = CR2+CI5
         CH(2,K,2) = CI2+CR5
         CH(2,K,3) = CI3+CR4
         CH(1,K,3) = CR3-CI4
         CH(1,K,4) = CR3+CI4
         CH(2,K,4) = CI3-CR4
         CH(2,K,5) = CI2-CR5
  101 CONTINUE
      RETURN
  102 DO 104 K=1,L1
         DO 103 I=2,IDO,2
            TI5 = CC(I,2,K)-CC(I,5,K)
            TI2 = CC(I,2,K)+CC(I,5,K)
            TI4 = CC(I,3,K)-CC(I,4,K)
            TI3 = CC(I,3,K)+CC(I,4,K)
            TR5 = CC(I-1,2,K)-CC(I-1,5,K)
            TR2 = CC(I-1,2,K)+CC(I-1,5,K)
            TR4 = CC(I-1,3,K)-CC(I-1,4,K)
            TR3 = CC(I-1,3,K)+CC(I-1,4,K)
            CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3
            CH(I,K,1) = CC(I,1,K)+TI2+TI3
            CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3
            CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3
            CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3
            CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3
            CR5 = TI11*TR5+TI12*TR4
            CI5 = TI11*TI5+TI12*TI4
            CR4 = TI12*TR5-TI11*TR4
            CI4 = TI12*TI5-TI11*TI4
            DR3 = CR3-CI4
            DR4 = CR3+CI4
            DI3 = CI3+CR4
            DI4 = CI3-CR4
            DR5 = CR2+CI5
            DR2 = CR2-CI5
            DI5 = CI2-CR5
            DI2 = CI2+CR5
            CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2
            CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2
            CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3
            CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3
            CH(I-1,K,4) = WA3(I-1)*DR4+WA3(I)*DI4
            CH(I,K,4) = WA3(I-1)*DI4-WA3(I)*DR4
            CH(I-1,K,5) = WA4(I-1)*DR5+WA4(I)*DI5
            CH(I,K,5) = WA4(I-1)*DI5-WA4(I)*DR5
  103    CONTINUE
  104 CONTINUE
      RETURN
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE DPASF3 (IDO,L1,CC,CH,WA1,WA2)
C
C  From Paul Swarztrauber's FFTPACK
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       CC(IDO,3,L1)           ,CH(IDO,L1,3)           ,
     1                WA1(*)     ,WA2(*)
      DATA TAUR,TAUI /-.5D0,-.866025403784439D0/
      IF (IDO .NE. 2) GO TO 102
      DO 101 K=1,L1
         TR2 = CC(1,2,K)+CC(1,3,K)
         CR2 = CC(1,1,K)+TAUR*TR2
         CH(1,K,1) = CC(1,1,K)+TR2
         TI2 = CC(2,2,K)+CC(2,3,K)
         CI2 = CC(2,1,K)+TAUR*TI2
         CH(2,K,1) = CC(2,1,K)+TI2
         CR3 = TAUI*(CC(1,2,K)-CC(1,3,K))
         CI3 = TAUI*(CC(2,2,K)-CC(2,3,K))
         CH(1,K,2) = CR2-CI3
         CH(1,K,3) = CR2+CI3
         CH(2,K,2) = CI2+CR3
         CH(2,K,3) = CI2-CR3
  101 CONTINUE
      RETURN
  102 DO 104 K=1,L1
         DO 103 I=2,IDO,2
            TR2 = CC(I-1,2,K)+CC(I-1,3,K)
            CR2 = CC(I-1,1,K)+TAUR*TR2
            CH(I-1,K,1) = CC(I-1,1,K)+TR2
            TI2 = CC(I,2,K)+CC(I,3,K)
            CI2 = CC(I,1,K)+TAUR*TI2
            CH(I,K,1) = CC(I,1,K)+TI2
            CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K))
            CI3 = TAUI*(CC(I,2,K)-CC(I,3,K))
            DR2 = CR2-CI3
            DR3 = CR2+CI3
            DI2 = CI2+CR3
            DI3 = CI2-CR3
            CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2
            CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2
            CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3
            CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3
  103    CONTINUE
  104 CONTINUE
      RETURN
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE DPASF2 (IDO,L1,CC,CH,WA1)
C
C  From Paul Swarztrauber's FFTPACK
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       CC(IDO,2,L1)           ,CH(IDO,L1,2)           ,
     1                WA1(*)
      IF (IDO .GT. 2) GO TO 102
      DO 101 K=1,L1
         CH(1,K,1) = CC(1,1,K)+CC(1,2,K)
         CH(1,K,2) = CC(1,1,K)-CC(1,2,K)
         CH(2,K,1) = CC(2,1,K)+CC(2,2,K)
         CH(2,K,2) = CC(2,1,K)-CC(2,2,K)
  101 CONTINUE
      RETURN
  102 DO 104 K=1,L1
         DO 103 I=2,IDO,2
            CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K)
            TR2 = CC(I-1,1,K)-CC(I-1,2,K)
            CH(I,K,1) = CC(I,1,K)+CC(I,2,K)
            TI2 = CC(I,1,K)-CC(I,2,K)
            CH(I,K,2) = WA1(I-1)*TI2-WA1(I)*TR2
            CH(I-1,K,2) = WA1(I-1)*TR2+WA1(I)*TI2
  103    CONTINUE
  104 CONTINUE
      RETURN
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE DPASF4 (IDO,L1,CC,CH,WA1,WA2,WA3)
C
C  From Paul Swarztrauber's FFTPACK
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       CC(IDO,4,L1)           ,CH(IDO,L1,4)           ,
     1                WA1(*)     ,WA2(*)     ,WA3(*)
      IF (IDO .NE. 2) GO TO 102
      DO 101 K=1,L1
         TI1 = CC(2,1,K)-CC(2,3,K)
         TI2 = CC(2,1,K)+CC(2,3,K)
         TR4 = CC(2,2,K)-CC(2,4,K)
         TI3 = CC(2,2,K)+CC(2,4,K)
         TR1 = CC(1,1,K)-CC(1,3,K)
         TR2 = CC(1,1,K)+CC(1,3,K)
         TI4 = CC(1,4,K)-CC(1,2,K)
         TR3 = CC(1,2,K)+CC(1,4,K)
         CH(1,K,1) = TR2+TR3
         CH(1,K,3) = TR2-TR3
         CH(2,K,1) = TI2+TI3
         CH(2,K,3) = TI2-TI3
         CH(1,K,2) = TR1+TR4
         CH(1,K,4) = TR1-TR4
         CH(2,K,2) = TI1+TI4
         CH(2,K,4) = TI1-TI4
  101 CONTINUE
      RETURN
  102 DO 104 K=1,L1
         DO 103 I=2,IDO,2
            TI1 = CC(I,1,K)-CC(I,3,K)
            TI2 = CC(I,1,K)+CC(I,3,K)
            TI3 = CC(I,2,K)+CC(I,4,K)
            TR4 = CC(I,2,K)-CC(I,4,K)
            TR1 = CC(I-1,1,K)-CC(I-1,3,K)
            TR2 = CC(I-1,1,K)+CC(I-1,3,K)
            TI4 = CC(I-1,4,K)-CC(I-1,2,K)
            TR3 = CC(I-1,2,K)+CC(I-1,4,K)
            CH(I-1,K,1) = TR2+TR3
            CR3 = TR2-TR3
            CH(I,K,1) = TI2+TI3
            CI3 = TI2-TI3
            CR2 = TR1+TR4
            CR4 = TR1-TR4
            CI2 = TI1+TI4
            CI4 = TI1-TI4
            CH(I-1,K,2) = WA1(I-1)*CR2+WA1(I)*CI2
            CH(I,K,2) = WA1(I-1)*CI2-WA1(I)*CR2
            CH(I-1,K,3) = WA2(I-1)*CR3+WA2(I)*CI3
            CH(I,K,3) = WA2(I-1)*CI3-WA2(I)*CR3
            CH(I-1,K,4) = WA3(I-1)*CR4+WA3(I)*CI4
            CH(I,K,4) = WA3(I-1)*CI4-WA3(I)*CR4
  103    CONTINUE
  104 CONTINUE
      RETURN
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE DFFTCI (N,WSAVE)
C
C  From Paul Swarztrauber's FFTPACK.
C
      DOUBLE PRECISION WSAVE(*)
      IF (N .EQ. 1) RETURN
      IW1 = N+N+1
      IW2 = IW1+N+N
      CALL DCFTI1 (N,WSAVE(IW1),WSAVE(IW2))
      RETURN
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE DCFTI1 (N,WA,IFAC)
C
C  From Paul Swarztrauber's FFTPACK.
C
      DOUBLE PRECISION ARG, ARGH, ARGLD, FI, TPI, WA(*)
      INTEGER IFAC(*), NTRYH(4)
      DATA NTRYH/3,4,2,5/
      NL = N
      NF = 0
      J = 0
  101 J = J+1
      IF (J-4) 102,102,103
  102 NTRY = NTRYH(J)
      GO TO 104
  103 NTRY = NTRY+2
  104 NQ = NL/NTRY
      NR = NL-NTRY*NQ
      IF (NR) 101,105,101
  105 NF = NF+1
      IFAC(NF+2) = NTRY
      NL = NQ
      IF (NTRY .NE. 2) GO TO 107
      IF (NF .EQ. 1) GO TO 107
      DO 106 I=2,NF
         IB = NF-I+2
         IFAC(IB+2) = IFAC(IB+1)
  106 CONTINUE
      IFAC(3) = 2
  107 IF (NL .NE. 1) GO TO 104
      IFAC(1) = N
      IFAC(2) = NF
      TPI = 6.28318530717959D0
      ARGH = TPI/DBLE(N)
      I = 2
      L1 = 1
      DO 110 K1=1,NF
         IP = IFAC(K1+2)
         LD = 0
         L2 = L1*IP
         IDO = N/L2
         IDOT = IDO+IDO+2
         IPM = IP-1
         DO 109 J=1,IPM
            I1 = I
            WA(I-1) = 1.D0
            WA(I) = 0.D0
            LD = LD+L1
            FI = 0.D0
            ARGLD = DBLE(LD)*ARGH
            DO 108 II=4,IDOT,2
               I = I+2
               FI = FI+1.D0
               ARG = FI*ARGLD
               WA(I-1) = DCOS(ARG)
               WA(I) = DSIN(ARG)
  108       CONTINUE
            IF (IP .LE. 5) GO TO 109
            WA(I1-1) = WA(I-1)
            WA(I1) = WA(I)
  109    CONTINUE
         L1 = L2
  110 CONTINUE
      RETURN
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE F2TCF (N, C, YOUT, WSAVE)
C
C  From Paul Swarztrauber's FFTPACK
C
      REAL C(*), YOUT(*), WSAVE(*)
      DO 110 J=1,2*N
         YOUT(J)=C(J)
  110 CONTINUE
      IF (N .EQ. 1) RETURN
      IW1 = N+N+1
      IW2 = IW1+N+N
      CALL CFFTF1 (N,YOUT,WSAVE,WSAVE(IW1),WSAVE(IW2))
      RETURN
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE CFFTF1 (N,C,CH,WA,IFAC)
C
C  From Paul Swarztrauber's FFTPACK
C
      DIMENSION       CH(*)      ,C(*)       ,WA(*)      ,IFAC(*)
      NF = IFAC(2)
      NA = 0
      L1 = 1
      IW = 1
      DO 116 K1=1,NF
         IP = IFAC(K1+2)
         L2 = IP*L1
         IDO = N/L2
         IDOT = IDO+IDO
         IDL1 = IDOT*L1
         IF (IP .NE. 4) GO TO 103
         IX2 = IW+IDOT
         IX3 = IX2+IDOT
         IF (NA .NE. 0) GO TO 101
         CALL PASSF4 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
         GO TO 102
  101    CALL PASSF4 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
  102    NA = 1-NA
         GO TO 115
  103    IF (IP .NE. 2) GO TO 106
         IF (NA .NE. 0) GO TO 104
         CALL PASSF2 (IDOT,L1,C,CH,WA(IW))
         GO TO 105
  104    CALL PASSF2 (IDOT,L1,CH,C,WA(IW))
  105    NA = 1-NA
         GO TO 115
  106    IF (IP .NE. 3) GO TO 109
         IX2 = IW+IDOT
         IF (NA .NE. 0) GO TO 107
         CALL PASSF3 (IDOT,L1,C,CH,WA(IW),WA(IX2))
         GO TO 108
  107    CALL PASSF3 (IDOT,L1,CH,C,WA(IW),WA(IX2))
  108    NA = 1-NA
         GO TO 115
  109    IF (IP .NE. 5) GO TO 112
         IX2 = IW+IDOT
         IX3 = IX2+IDOT
         IX4 = IX3+IDOT
         IF (NA .NE. 0) GO TO 110
         CALL PASSF5 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))
         GO TO 111
  110    CALL PASSF5 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))
  111    NA = 1-NA
         GO TO 115
  112    IF (NA .NE. 0) GO TO 113
         CALL PASSF (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))
         GO TO 114
  113    CALL PASSF (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))
  114    IF (NAC .NE. 0) NA = 1-NA
  115    L1 = L2
         IW = IW+(IP-1)*IDOT
  116 CONTINUE
      IF (NA .EQ. 0) RETURN
      N2 = N+N
      DO 117 I=1,N2
         C(I) = CH(I)
  117 CONTINUE
      RETURN
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE PASSF (NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)
C
C  From Paul Swarztrauber's FFTPACK
C
      DIMENSION       CH(IDO,L1,IP)          ,CC(IDO,IP,L1)          ,
     1                C1(IDO,L1,IP)          ,WA(*)      ,C2(IDL1,IP),
     2                CH2(IDL1,IP)
      IDOT = IDO/2
      NT = IP*IDL1
      IPP2 = IP+2
      IPPH = (IP+1)/2
      IDP = IP*IDO
C
      IF (IDO .LT. L1) GO TO 106
      DO 103 J=2,IPPH
         JC = IPP2-J
         DO 102 K=1,L1
            DO 101 I=1,IDO
               CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)
               CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)
  101       CONTINUE
  102    CONTINUE
  103 CONTINUE
      DO 105 K=1,L1
         DO 104 I=1,IDO
            CH(I,K,1) = CC(I,1,K)
  104    CONTINUE
  105 CONTINUE
      GO TO 112
  106 DO 109 J=2,IPPH
         JC = IPP2-J
         DO 108 I=1,IDO
            DO 107 K=1,L1
               CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)
               CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)
  107       CONTINUE
  108    CONTINUE
  109 CONTINUE
      DO 111 I=1,IDO
         DO 110 K=1,L1
            CH(I,K,1) = CC(I,1,K)
  110    CONTINUE
  111 CONTINUE
  112 IDL = 2-IDO
      INC = 0
      DO 116 L=2,IPPH
         LC = IPP2-L
         IDL = IDL+IDO
         DO 113 IK=1,IDL1
            C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2)
            C2(IK,LC) = -WA(IDL)*CH2(IK,IP)
  113    CONTINUE
         IDLJ = IDL
         INC = INC+IDO
         DO 115 J=3,IPPH
            JC = IPP2-J
            IDLJ = IDLJ+INC
            IF (IDLJ .GT. IDP) IDLJ = IDLJ-IDP
            WAR = WA(IDLJ-1)
            WAI = WA(IDLJ)
            DO 114 IK=1,IDL1
               C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J)
               C2(IK,LC) = C2(IK,LC)-WAI*CH2(IK,JC)
  114       CONTINUE
  115    CONTINUE
  116 CONTINUE
      DO 118 J=2,IPPH
         DO 117 IK=1,IDL1
            CH2(IK,1) = CH2(IK,1)+CH2(IK,J)
  117    CONTINUE
  118 CONTINUE
      DO 120 J=2,IPPH
         JC = IPP2-J
         DO 119 IK=2,IDL1,2
            CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC)
            CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC)
            CH2(IK,J) = C2(IK,J)+C2(IK-1,JC)
            CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC)
  119    CONTINUE
  120 CONTINUE
      NAC = 1
      IF (IDO .EQ. 2) RETURN
      NAC = 0
      DO 121 IK=1,IDL1
         C2(IK,1) = CH2(IK,1)
  121 CONTINUE
      DO 123 J=2,IP
         DO 122 K=1,L1
            C1(1,K,J) = CH(1,K,J)
            C1(2,K,J) = CH(2,K,J)
  122    CONTINUE
  123 CONTINUE
      IF (IDOT .GT. L1) GO TO 127
      IDIJ = 0
      DO 126 J=2,IP
         IDIJ = IDIJ+2
         DO 125 I=4,IDO,2
            IDIJ = IDIJ+2
            DO 124 K=1,L1
               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J)
               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J)
  124       CONTINUE
  125    CONTINUE
  126 CONTINUE
      RETURN
  127 IDJ = 2-IDO
      DO 130 J=2,IP
         IDJ = IDJ+IDO
         DO 129 K=1,L1
            IDIJ = IDJ
            DO 128 I=4,IDO,2
               IDIJ = IDIJ+2
               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J)
               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J)
  128       CONTINUE
  129    CONTINUE
  130 CONTINUE
      RETURN
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE PASSF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4)
C
C  From Paul Swarztrauber's FFTPACK
C
      DIMENSION       CC(IDO,5,L1)           ,CH(IDO,L1,5)           ,
     1                WA1(*)     ,WA2(*)     ,WA3(*)     ,WA4(*)
      DATA TR11,TI11,TR12,TI12 /.309016994374947,-.951056516295154,
     1-.809016994374947,-.587785252292473/
      IF (IDO .NE. 2) GO TO 102
      DO 101 K=1,L1
         TI5 = CC(2,2,K)-CC(2,5,K)
         TI2 = CC(2,2,K)+CC(2,5,K)
         TI4 = CC(2,3,K)-CC(2,4,K)
         TI3 = CC(2,3,K)+CC(2,4,K)
         TR5 = CC(1,2,K)-CC(1,5,K)
         TR2 = CC(1,2,K)+CC(1,5,K)
         TR4 = CC(1,3,K)-CC(1,4,K)
         TR3 = CC(1,3,K)+CC(1,4,K)
         CH(1,K,1) = CC(1,1,K)+TR2+TR3
         CH(2,K,1) = CC(2,1,K)+TI2+TI3
         CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3
         CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3
         CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3
         CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3
         CR5 = TI11*TR5+TI12*TR4
         CI5 = TI11*TI5+TI12*TI4
         CR4 = TI12*TR5-TI11*TR4
         CI4 = TI12*TI5-TI11*TI4
         CH(1,K,2) = CR2-CI5
         CH(1,K,5) = CR2+CI5
         CH(2,K,2) = CI2+CR5
         CH(2,K,3) = CI3+CR4
         CH(1,K,3) = CR3-CI4
         CH(1,K,4) = CR3+CI4
         CH(2,K,4) = CI3-CR4
         CH(2,K,5) = CI2-CR5
  101 CONTINUE
      RETURN
  102 DO 104 K=1,L1
         DO 103 I=2,IDO,2
            TI5 = CC(I,2,K)-CC(I,5,K)
            TI2 = CC(I,2,K)+CC(I,5,K)
            TI4 = CC(I,3,K)-CC(I,4,K)
            TI3 = CC(I,3,K)+CC(I,4,K)
            TR5 = CC(I-1,2,K)-CC(I-1,5,K)
            TR2 = CC(I-1,2,K)+CC(I-1,5,K)
            TR4 = CC(I-1,3,K)-CC(I-1,4,K)
            TR3 = CC(I-1,3,K)+CC(I-1,4,K)
            CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3
            CH(I,K,1) = CC(I,1,K)+TI2+TI3
            CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3
            CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3
            CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3
            CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3
            CR5 = TI11*TR5+TI12*TR4
            CI5 = TI11*TI5+TI12*TI4
            CR4 = TI12*TR5-TI11*TR4
            CI4 = TI12*TI5-TI11*TI4
            DR3 = CR3-CI4
            DR4 = CR3+CI4
            DI3 = CI3+CR4
            DI4 = CI3-CR4
            DR5 = CR2+CI5
            DR2 = CR2-CI5
            DI5 = CI2-CR5
            DI2 = CI2+CR5
            CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2
            CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2
            CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3
            CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3
            CH(I-1,K,4) = WA3(I-1)*DR4+WA3(I)*DI4
            CH(I,K,4) = WA3(I-1)*DI4-WA3(I)*DR4
            CH(I-1,K,5) = WA4(I-1)*DR5+WA4(I)*DI5
            CH(I,K,5) = WA4(I-1)*DI5-WA4(I)*DR5
  103    CONTINUE
  104 CONTINUE
      RETURN
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE PASSF3 (IDO,L1,CC,CH,WA1,WA2)
C
C  From Paul Swarztrauber's FFTPACK
C
      DIMENSION       CC(IDO,3,L1)           ,CH(IDO,L1,3)           ,
     1                WA1(*)     ,WA2(*)
      DATA TAUR,TAUI /-.5,-.866025403784439/
      IF (IDO .NE. 2) GO TO 102
      DO 101 K=1,L1
         TR2 = CC(1,2,K)+CC(1,3,K)
         CR2 = CC(1,1,K)+TAUR*TR2
         CH(1,K,1) = CC(1,1,K)+TR2
         TI2 = CC(2,2,K)+CC(2,3,K)
         CI2 = CC(2,1,K)+TAUR*TI2
         CH(2,K,1) = CC(2,1,K)+TI2
         CR3 = TAUI*(CC(1,2,K)-CC(1,3,K))
         CI3 = TAUI*(CC(2,2,K)-CC(2,3,K))
         CH(1,K,2) = CR2-CI3
         CH(1,K,3) = CR2+CI3
         CH(2,K,2) = CI2+CR3
         CH(2,K,3) = CI2-CR3
  101 CONTINUE
      RETURN
  102 DO 104 K=1,L1
         DO 103 I=2,IDO,2
            TR2 = CC(I-1,2,K)+CC(I-1,3,K)
            CR2 = CC(I-1,1,K)+TAUR*TR2
            CH(I-1,K,1) = CC(I-1,1,K)+TR2
            TI2 = CC(I,2,K)+CC(I,3,K)
            CI2 = CC(I,1,K)+TAUR*TI2
            CH(I,K,1) = CC(I,1,K)+TI2
            CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K))
            CI3 = TAUI*(CC(I,2,K)-CC(I,3,K))
            DR2 = CR2-CI3
            DR3 = CR2+CI3
            DI2 = CI2+CR3
            DI3 = CI2-CR3
            CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2
            CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2
            CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3
            CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3
  103    CONTINUE
  104 CONTINUE
      RETURN
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE PASSF2 (IDO,L1,CC,CH,WA1)
C
C  From Paul Swarztrauber's FFTPACK
C
      DIMENSION       CC(IDO,2,L1)           ,CH(IDO,L1,2)           ,
     1                WA1(*)
      IF (IDO .GT. 2) GO TO 102
      DO 101 K=1,L1
         CH(1,K,1) = CC(1,1,K)+CC(1,2,K)
         CH(1,K,2) = CC(1,1,K)-CC(1,2,K)
         CH(2,K,1) = CC(2,1,K)+CC(2,2,K)
         CH(2,K,2) = CC(2,1,K)-CC(2,2,K)
  101 CONTINUE
      RETURN
  102 DO 104 K=1,L1
         DO 103 I=2,IDO,2
            CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K)
            TR2 = CC(I-1,1,K)-CC(I-1,2,K)
            CH(I,K,1) = CC(I,1,K)+CC(I,2,K)
            TI2 = CC(I,1,K)-CC(I,2,K)
            CH(I,K,2) = WA1(I-1)*TI2-WA1(I)*TR2
            CH(I-1,K,2) = WA1(I-1)*TR2+WA1(I)*TI2
  103    CONTINUE
  104 CONTINUE
      RETURN
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE PASSF4 (IDO,L1,CC,CH,WA1,WA2,WA3)
C
C  From Paul Swarztrauber's FFTPACK
C
      DIMENSION       CC(IDO,4,L1)           ,CH(IDO,L1,4)           ,
     1                WA1(*)     ,WA2(*)     ,WA3(*)
      IF (IDO .NE. 2) GO TO 102
      DO 101 K=1,L1
         TI1 = CC(2,1,K)-CC(2,3,K)
         TI2 = CC(2,1,K)+CC(2,3,K)
         TR4 = CC(2,2,K)-CC(2,4,K)
         TI3 = CC(2,2,K)+CC(2,4,K)
         TR1 = CC(1,1,K)-CC(1,3,K)
         TR2 = CC(1,1,K)+CC(1,3,K)
         TI4 = CC(1,4,K)-CC(1,2,K)
         TR3 = CC(1,2,K)+CC(1,4,K)
         CH(1,K,1) = TR2+TR3
         CH(1,K,3) = TR2-TR3
         CH(2,K,1) = TI2+TI3
         CH(2,K,3) = TI2-TI3
         CH(1,K,2) = TR1+TR4
         CH(1,K,4) = TR1-TR4
         CH(2,K,2) = TI1+TI4
         CH(2,K,4) = TI1-TI4
  101 CONTINUE
      RETURN
  102 DO 104 K=1,L1
         DO 103 I=2,IDO,2
            TI1 = CC(I,1,K)-CC(I,3,K)
            TI2 = CC(I,1,K)+CC(I,3,K)
            TI3 = CC(I,2,K)+CC(I,4,K)
            TR4 = CC(I,2,K)-CC(I,4,K)
            TR1 = CC(I-1,1,K)-CC(I-1,3,K)
            TR2 = CC(I-1,1,K)+CC(I-1,3,K)
            TI4 = CC(I-1,4,K)-CC(I-1,2,K)
            TR3 = CC(I-1,2,K)+CC(I-1,4,K)
            CH(I-1,K,1) = TR2+TR3
            CR3 = TR2-TR3
            CH(I,K,1) = TI2+TI3
            CI3 = TI2-TI3
            CR2 = TR1+TR4
            CR4 = TR1-TR4
            CI2 = TI1+TI4
            CI4 = TI1-TI4
            CH(I-1,K,2) = WA1(I-1)*CR2+WA1(I)*CI2
            CH(I,K,2) = WA1(I-1)*CI2-WA1(I)*CR2
            CH(I-1,K,3) = WA2(I-1)*CR3+WA2(I)*CI3
            CH(I,K,3) = WA2(I-1)*CI3-WA2(I)*CR3
            CH(I-1,K,4) = WA3(I-1)*CR4+WA3(I)*CI4
            CH(I,K,4) = WA3(I-1)*CI4-WA3(I)*CR4
  103    CONTINUE
  104 CONTINUE
      RETURN
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE F2TCB (N, C, YOUT, WSAVE)
C
C  From Paul Swarztrauber's FFTPACK
C
      REAL C(*), YOUT(*), WSAVE(*)
      DO 110 J=1,2*N
         YOUT(J)=C(J)
  110 CONTINUE
      IF (N .LE. 1) RETURN
      IW1 = N+N+1
      IW2 = IW1+N+N
      CALL CFFTB1 (N,YOUT,WSAVE,WSAVE(IW1),WSAVE(IW2))
      RETURN
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE CFFTB1 (N,C,CH,WA,IFAC)
C
C  From Paul Swarztrauber's FFTPACK
C
      DIMENSION       CH(*)      ,C(*)       ,WA(*)      ,IFAC(*)
      NF = IFAC(2)
      NA = 0
      L1 = 1
      IW = 1
      DO 116 K1=1,NF
         IP = IFAC(K1+2)
         L2 = IP*L1
         IDO = N/L2
         IDOT = IDO+IDO
         IDL1 = IDOT*L1
         IF (IP .NE. 4) GO TO 103
         IX2 = IW+IDOT
         IX3 = IX2+IDOT
         IF (NA .NE. 0) GO TO 101
         CALL PASSB4 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
         GO TO 102
  101    CALL PASSB4 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
  102    NA = 1-NA
         GO TO 115
  103    IF (IP .NE. 2) GO TO 106
         IF (NA .NE. 0) GO TO 104
         CALL PASSB2 (IDOT,L1,C,CH,WA(IW))
         GO TO 105
  104    CALL PASSB2 (IDOT,L1,CH,C,WA(IW))
  105    NA = 1-NA
         GO TO 115
  106    IF (IP .NE. 3) GO TO 109
         IX2 = IW+IDOT
         IF (NA .NE. 0) GO TO 107
         CALL PASSB3 (IDOT,L1,C,CH,WA(IW),WA(IX2))
         GO TO 108
  107    CALL PASSB3 (IDOT,L1,CH,C,WA(IW),WA(IX2))
  108    NA = 1-NA
         GO TO 115
  109    IF (IP .NE. 5) GO TO 112
         IX2 = IW+IDOT
         IX3 = IX2+IDOT
         IX4 = IX3+IDOT
         IF (NA .NE. 0) GO TO 110
         CALL PASSB5 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))
         GO TO 111
  110    CALL PASSB5 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))
  111    NA = 1-NA
         GO TO 115
  112    IF (NA .NE. 0) GO TO 113
         CALL PASSB (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))
         GO TO 114
  113    CALL PASSB (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))
  114    IF (NAC .NE. 0) NA = 1-NA
  115    L1 = L2
         IW = IW+(IP-1)*IDOT
  116 CONTINUE
      IF (NA .EQ. 0) RETURN
      N2 = N+N
      DO 117 I=1,N2
         C(I) = CH(I)
  117 CONTINUE
      RETURN
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE PASSB (NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)
C
C  From Paul Swarztrauber's FFTPACK
C
      DIMENSION       CH(IDO,L1,IP)          ,CC(IDO,IP,L1)          ,
     1                C1(IDO,L1,IP)          ,WA(*)      ,C2(IDL1,IP),
     2                CH2(IDL1,IP)
      IDOT = IDO/2
      NT = IP*IDL1
      IPP2 = IP+2
      IPPH = (IP+1)/2
      IDP = IP*IDO
C
      IF (IDO .LT. L1) GO TO 106
      DO 103 J=2,IPPH
         JC = IPP2-J
         DO 102 K=1,L1
            DO 101 I=1,IDO
               CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)
               CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)
  101       CONTINUE
  102    CONTINUE
  103 CONTINUE
      DO 105 K=1,L1
         DO 104 I=1,IDO
            CH(I,K,1) = CC(I,1,K)
  104    CONTINUE
  105 CONTINUE
      GO TO 112
  106 DO 109 J=2,IPPH
         JC = IPP2-J
         DO 108 I=1,IDO
            DO 107 K=1,L1
               CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)
               CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)
  107       CONTINUE
  108    CONTINUE
  109 CONTINUE
      DO 111 I=1,IDO
         DO 110 K=1,L1
            CH(I,K,1) = CC(I,1,K)
  110    CONTINUE
  111 CONTINUE
  112 IDL = 2-IDO
      INC = 0
      DO 116 L=2,IPPH
         LC = IPP2-L
         IDL = IDL+IDO
         DO 113 IK=1,IDL1
            C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2)
            C2(IK,LC) = WA(IDL)*CH2(IK,IP)
  113    CONTINUE
         IDLJ = IDL
         INC = INC+IDO
         DO 115 J=3,IPPH
            JC = IPP2-J
            IDLJ = IDLJ+INC
            IF (IDLJ .GT. IDP) IDLJ = IDLJ-IDP
            WAR = WA(IDLJ-1)
            WAI = WA(IDLJ)
            DO 114 IK=1,IDL1
               C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J)
               C2(IK,LC) = C2(IK,LC)+WAI*CH2(IK,JC)
  114       CONTINUE
  115    CONTINUE
  116 CONTINUE
      DO 118 J=2,IPPH
         DO 117 IK=1,IDL1
            CH2(IK,1) = CH2(IK,1)+CH2(IK,J)
  117    CONTINUE
  118 CONTINUE
      DO 120 J=2,IPPH
         JC = IPP2-J
         DO 119 IK=2,IDL1,2
            CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC)
            CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC)
            CH2(IK,J) = C2(IK,J)+C2(IK-1,JC)
            CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC)
  119    CONTINUE
  120 CONTINUE
      NAC = 1
      IF (IDO .EQ. 2) RETURN
      NAC = 0
      DO 121 IK=1,IDL1
         C2(IK,1) = CH2(IK,1)
  121 CONTINUE
      DO 123 J=2,IP
         DO 122 K=1,L1
            C1(1,K,J) = CH(1,K,J)
            C1(2,K,J) = CH(2,K,J)
  122    CONTINUE
  123 CONTINUE
      IF (IDOT .GT. L1) GO TO 127
      IDIJ = 0
      DO 126 J=2,IP
         IDIJ = IDIJ+2
         DO 125 I=4,IDO,2
            IDIJ = IDIJ+2
            DO 124 K=1,L1
               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)
               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)
  124       CONTINUE
  125    CONTINUE
  126 CONTINUE
      RETURN
  127 IDJ = 2-IDO
      DO 130 J=2,IP
         IDJ = IDJ+IDO
         DO 129 K=1,L1
            IDIJ = IDJ
            DO 128 I=4,IDO,2
               IDIJ = IDIJ+2
               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)
               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)
  128       CONTINUE
  129    CONTINUE
  130 CONTINUE
      RETURN
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE PASSB5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4)
C
C  From Paul Swarztrauber's FFTPACK
C
      DIMENSION       CC(IDO,5,L1)           ,CH(IDO,L1,5)           ,
     1                WA1(*)     ,WA2(*)     ,WA3(*)     ,WA4(*)
      DATA TR11,TI11,TR12,TI12 /.309016994374947,.951056516295154,
     1-.809016994374947,.587785252292473/
      IF (IDO .NE. 2) GO TO 102
      DO 101 K=1,L1
         TI5 = CC(2,2,K)-CC(2,5,K)
         TI2 = CC(2,2,K)+CC(2,5,K)
         TI4 = CC(2,3,K)-CC(2,4,K)
         TI3 = CC(2,3,K)+CC(2,4,K)
         TR5 = CC(1,2,K)-CC(1,5,K)
         TR2 = CC(1,2,K)+CC(1,5,K)
         TR4 = CC(1,3,K)-CC(1,4,K)
         TR3 = CC(1,3,K)+CC(1,4,K)
         CH(1,K,1) = CC(1,1,K)+TR2+TR3
         CH(2,K,1) = CC(2,1,K)+TI2+TI3
         CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3
         CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3
         CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3
         CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3
         CR5 = TI11*TR5+TI12*TR4
         CI5 = TI11*TI5+TI12*TI4
         CR4 = TI12*TR5-TI11*TR4
         CI4 = TI12*TI5-TI11*TI4
         CH(1,K,2) = CR2-CI5
         CH(1,K,5) = CR2+CI5
         CH(2,K,2) = CI2+CR5
         CH(2,K,3) = CI3+CR4
         CH(1,K,3) = CR3-CI4
         CH(1,K,4) = CR3+CI4
         CH(2,K,4) = CI3-CR4
         CH(2,K,5) = CI2-CR5
  101 CONTINUE
      RETURN
  102 DO 104 K=1,L1
         DO 103 I=2,IDO,2
            TI5 = CC(I,2,K)-CC(I,5,K)
            TI2 = CC(I,2,K)+CC(I,5,K)
            TI4 = CC(I,3,K)-CC(I,4,K)
            TI3 = CC(I,3,K)+CC(I,4,K)
            TR5 = CC(I-1,2,K)-CC(I-1,5,K)
            TR2 = CC(I-1,2,K)+CC(I-1,5,K)
            TR4 = CC(I-1,3,K)-CC(I-1,4,K)
            TR3 = CC(I-1,3,K)+CC(I-1,4,K)
            CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3
            CH(I,K,1) = CC(I,1,K)+TI2+TI3
            CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3
            CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3
            CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3
            CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3
            CR5 = TI11*TR5+TI12*TR4
            CI5 = TI11*TI5+TI12*TI4
            CR4 = TI12*TR5-TI11*TR4
            CI4 = TI12*TI5-TI11*TI4
            DR3 = CR3-CI4
            DR4 = CR3+CI4
            DI3 = CI3+CR4
            DI4 = CI3-CR4
            DR5 = CR2+CI5
            DR2 = CR2-CI5
            DI5 = CI2-CR5
            DI2 = CI2+CR5
            CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2
            CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2
            CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3
            CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3
            CH(I-1,K,4) = WA3(I-1)*DR4-WA3(I)*DI4
            CH(I,K,4) = WA3(I-1)*DI4+WA3(I)*DR4
            CH(I-1,K,5) = WA4(I-1)*DR5-WA4(I)*DI5
            CH(I,K,5) = WA4(I-1)*DI5+WA4(I)*DR5
  103    CONTINUE
  104 CONTINUE
      RETURN
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE PASSB3 (IDO,L1,CC,CH,WA1,WA2)
C
C  From Paul Swarztrauber's FFTPACK
C
      DIMENSION       CC(IDO,3,L1)           ,CH(IDO,L1,3)           ,
     1                WA1(*)     ,WA2(*)
      DATA TAUR,TAUI /-.5,.866025403784439/
      IF (IDO .NE. 2) GO TO 102
      DO 101 K=1,L1
         TR2 = CC(1,2,K)+CC(1,3,K)
         CR2 = CC(1,1,K)+TAUR*TR2
         CH(1,K,1) = CC(1,1,K)+TR2
         TI2 = CC(2,2,K)+CC(2,3,K)
         CI2 = CC(2,1,K)+TAUR*TI2
         CH(2,K,1) = CC(2,1,K)+TI2
         CR3 = TAUI*(CC(1,2,K)-CC(1,3,K))
         CI3 = TAUI*(CC(2,2,K)-CC(2,3,K))
         CH(1,K,2) = CR2-CI3
         CH(1,K,3) = CR2+CI3
         CH(2,K,2) = CI2+CR3
         CH(2,K,3) = CI2-CR3
  101 CONTINUE
      RETURN
  102 DO 104 K=1,L1
         DO 103 I=2,IDO,2
            TR2 = CC(I-1,2,K)+CC(I-1,3,K)
            CR2 = CC(I-1,1,K)+TAUR*TR2
            CH(I-1,K,1) = CC(I-1,1,K)+TR2
            TI2 = CC(I,2,K)+CC(I,3,K)
            CI2 = CC(I,1,K)+TAUR*TI2
            CH(I,K,1) = CC(I,1,K)+TI2
            CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K))
            CI3 = TAUI*(CC(I,2,K)-CC(I,3,K))
            DR2 = CR2-CI3
            DR3 = CR2+CI3
            DI2 = CI2+CR3
            DI3 = CI2-CR3
            CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2
            CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2
            CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3
            CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3
  103    CONTINUE
  104 CONTINUE
      RETURN
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE PASSB2 (IDO,L1,CC,CH,WA1)
C
C  From Paul Swarztrauber's FFTPACK
C
      DIMENSION       CC(IDO,2,L1)           ,CH(IDO,L1,2)           ,
     1                WA1(*)
      IF (IDO .GT. 2) GO TO 102
      DO 101 K=1,L1
         CH(1,K,1) = CC(1,1,K)+CC(1,2,K)
         CH(1,K,2) = CC(1,1,K)-CC(1,2,K)
         CH(2,K,1) = CC(2,1,K)+CC(2,2,K)
         CH(2,K,2) = CC(2,1,K)-CC(2,2,K)
  101 CONTINUE
      RETURN
  102 DO 104 K=1,L1
         DO 103 I=2,IDO,2
            CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K)
            TR2 = CC(I-1,1,K)-CC(I-1,2,K)
            CH(I,K,1) = CC(I,1,K)+CC(I,2,K)
            TI2 = CC(I,1,K)-CC(I,2,K)
            CH(I,K,2) = WA1(I-1)*TI2+WA1(I)*TR2
            CH(I-1,K,2) = WA1(I-1)*TR2-WA1(I)*TI2
  103    CONTINUE
  104 CONTINUE
      RETURN
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE PASSB4 (IDO,L1,CC,CH,WA1,WA2,WA3)
C
C  From Paul Swarztrauber's FFTPACK
C
      DIMENSION       CC(IDO,4,L1)           ,CH(IDO,L1,4)           ,
     1                WA1(*)     ,WA2(*)     ,WA3(*)
      IF (IDO .NE. 2) GO TO 102
      DO 101 K=1,L1
         TI1 = CC(2,1,K)-CC(2,3,K)
         TI2 = CC(2,1,K)+CC(2,3,K)
         TR4 = CC(2,4,K)-CC(2,2,K)
         TI3 = CC(2,2,K)+CC(2,4,K)
         TR1 = CC(1,1,K)-CC(1,3,K)
         TR2 = CC(1,1,K)+CC(1,3,K)
         TI4 = CC(1,2,K)-CC(1,4,K)
         TR3 = CC(1,2,K)+CC(1,4,K)
         CH(1,K,1) = TR2+TR3
         CH(1,K,3) = TR2-TR3
         CH(2,K,1) = TI2+TI3
         CH(2,K,3) = TI2-TI3
         CH(1,K,2) = TR1+TR4
         CH(1,K,4) = TR1-TR4
         CH(2,K,2) = TI1+TI4
         CH(2,K,4) = TI1-TI4
  101 CONTINUE
      RETURN
  102 DO 104 K=1,L1
         DO 103 I=2,IDO,2
            TI1 = CC(I,1,K)-CC(I,3,K)
            TI2 = CC(I,1,K)+CC(I,3,K)
            TI3 = CC(I,2,K)+CC(I,4,K)
            TR4 = CC(I,4,K)-CC(I,2,K)
            TR1 = CC(I-1,1,K)-CC(I-1,3,K)
            TR2 = CC(I-1,1,K)+CC(I-1,3,K)
            TI4 = CC(I-1,2,K)-CC(I-1,4,K)
            TR3 = CC(I-1,2,K)+CC(I-1,4,K)
            CH(I-1,K,1) = TR2+TR3
            CR3 = TR2-TR3
            CH(I,K,1) = TI2+TI3
            CI3 = TI2-TI3
            CR2 = TR1+TR4
            CR4 = TR1-TR4
            CI2 = TI1+TI4
            CI4 = TI1-TI4
            CH(I-1,K,2) = WA1(I-1)*CR2-WA1(I)*CI2
            CH(I,K,2) = WA1(I-1)*CI2+WA1(I)*CR2
            CH(I-1,K,3) = WA2(I-1)*CR3-WA2(I)*CI3
            CH(I,K,3) = WA2(I-1)*CI3+WA2(I)*CR3
            CH(I-1,K,4) = WA3(I-1)*CR4-WA3(I)*CI4
            CH(I,K,4) = WA3(I-1)*CI4+WA3(I)*CR4
  103    CONTINUE
  104 CONTINUE
      RETURN
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE FFTCI (N,WSAVE)
C
C  From Paul Swarztrauber's FFTPACK.
C
      DIMENSION       WSAVE(*)
      IF (N .EQ. 1) RETURN
      IW1 = N+N+1
      IW2 = IW1+N+N
      CALL CFFTI1 (N,WSAVE(IW1),WSAVE(IW2))
      RETURN
      END
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      SUBROUTINE CFFTI1 (N,WA,IFAC)
C
C  From Paul Swarztrauber's FFTPACK.
C
      DIMENSION WA(*), IFAC(*), NTRYH(4)
      DATA NTRYH/3,4,2,5/
      NL = N
      NF = 0
      J = 0
  101 J = J+1
      IF (J-4) 102,102,103
  102 NTRY = NTRYH(J)
      GO TO 104
  103 NTRY = NTRY+2
  104 NQ = NL/NTRY
      NR = NL-NTRY*NQ
      IF (NR) 101,105,101
  105 NF = NF+1
      IFAC(NF+2) = NTRY
      NL = NQ
      IF (NTRY .NE. 2) GO TO 107
      IF (NF .EQ. 1) GO TO 107
      DO 106 I=2,NF
         IB = NF-I+2
         IFAC(IB+2) = IFAC(IB+1)
  106 CONTINUE
      IFAC(3) = 2
  107 IF (NL .NE. 1) GO TO 104
      IFAC(1) = N
      IFAC(2) = NF
      TPI = 6.28318530717959D0
      ARGH = TPI/FLOAT(N)
      I = 2
      L1 = 1
      DO 110 K1=1,NF
         IP = IFAC(K1+2)
         LD = 0
         L2 = L1*IP
         IDO = N/L2
         IDOT = IDO+IDO+2
         IPM = IP-1
         DO 109 J=1,IPM
            I1 = I
            WA(I-1) = 1.
            WA(I) = 0.
            LD = LD+L1
            FI = 0.
            ARGLD = FLOAT(LD)*ARGH
            DO 108 II=4,IDOT,2
               I = I+2
               FI = FI+1.
               ARG = FI*ARGLD
               WA(I-1) = COS(ARG)
               WA(I) = SIN(ARG)
  108       CONTINUE
            IF (IP .LE. 5) GO TO 109
            WA(I1-1) = WA(I-1)
            WA(I1) = WA(I)
  109    CONTINUE
         L1 = L2
  110 CONTINUE
      RETURN
      END
C++++++++++++++++ DOUBLE PRECISION VERSION 2DP (MAR 1984) ++++++++++++++    4222
C  FUNCTION RANDOM.  PRODUCES A PSEUDORANDOM REAL ON THE OPEN INTERVAL      4223
C      (0.,1.).                                                             4224
C  DIX (IN DOUBLE PRECISION) MUST BE INITIALIZED TO A WHOLE NUMBER          4225
C      BETWEEN 1.D0 AND 2147483646.D0 BEFORE THE FIRST CALL TO RANDOM       4226
C      AND NOT CHANGED BETWEEN SUCCESSIVE CALLS TO RANDOM.                  4227
C  BASED ON L. SCHRAGE, ACM TRANS. ON MATH. SOFTWARE 5, 132 (1979).         4228
C-----------------------------------------------------------------------    4229
      FUNCTION RANDOM(DIX)                                                  4230
C                                                                           4231
C  PORTABLE RANDOM NUMBER GENERATOR                                         4232
C   USING THE RECURSION                                                     4233
C    DIX = DIX*A MOD P                                                      4234
C                                                                           4235
      DOUBLE PRECISION A,P,DIX,B15,B16,XHI,XALO,LEFTLO,FHI,K                4236
C                                                                           4237
C  7**5, 2**15, 2**16, 2**31-1                                              4238
      DATA A/16807.D0/,B15/32768.D0/,B16/65536.D0/,P/2147483647.D0/         4239
C                                                                           4240
C  GET 15 HI ORDER BITS OF DIX                                              4241
      XHI = DIX / B16                                                       4242
      XHI = XHI - DMOD(XHI,1.D0)                                            4243
C  GET 16 LO BITS IF DIX AND FORM LO PRODUCT                                4244
      XALO=(DIX-XHI*B16)*A                                                  4245
C  GET 15 HI ORDER BITS OF LO PRODUCT                                       4246
      LEFTLO = XALO/B16                                                     4247
      LEFTLO = LEFTLO - DMOD(LEFTLO,1.D0)                                   4248
C  FORM THE 31 HIGHEST BITS OF FULL PRODUCT                                 4249
      FHI = XHI*A + LEFTLO                                                  4250
C  GET OVERFLO PAST 31ST BIT OF FULL PRODUCT                                4251
      K = FHI/B15                                                           4252
      K = K - DMOD(K,1.D0)                                                  4253
C  ASSEMBLE ALL THE PARTS AND PRESUBTRACT P                                 4254
C   THE PARENTHESES ARE ESSENTIAL                                           4255
      DIX = (((XALO-LEFTLO*B16) - P) + (FHI-K*B15)*B16) + K                 4256
C  ADD P BACK IN IF NECESSARY                                               4257
      IF (DIX .LT. 0.D0) DIX = DIX + P                                      4258
C  MULTIPLY BY 1/(2**31-1)                                                  4259
      RANDOM=DIX*4.656612875D-10                                            4260
      RETURN                                                                4261
      END                                                                   4262
C++++++++++++++++ DOUBLE PRECISION VERSION 2DP (MAR 1984) ++++++++++++++
C  FUNCTION FISHNI.  CALCULATES FISHER F-DISTRIBUTION FOR ARGUMENT F
C      WITH DF1 AND DF2 (NOT NECESSARILY INTEGER) DEGREES OF FREEDOM.
C      (SEE ABRAMOWITZ AND STEGUN, EQS. 26.6.2 AND 26.5.2.)
C-------------------------------------------------------------------------------
C  CALLS SUBPROGRAMS - ERRMES, BETAIN
C  WHICH IN TURN CALL - GAMLN
C-------------------------------------------------------------------------------
      FUNCTION FISHNI (F,DF1,DF2,NOUT)
      CHARACTER CHSUBP*6
      CHSUBP='FISHNI'
      IF (AMIN1(DF1,DF2) .LE. 0.) CALL ERRMES (1, 4, CHSUBP)
      HDF1=.5*DF1
      HDF2=.5*DF2
      DUM=DF1*F
      FISHNI=BETAIN(DUM/(DF2+DUM),HDF1,HDF2,NOUT)
      RETURN
      END
C++++++++++++++++ DOUBLE PRECISION VERSION 2DP (MAR 1984) ++++++++++++++
C  FUNCTION DGAMLN.  COMPUTES LN OF THE GAMMA FUNCTION FOR POSITIVE
C      XARG USING A VERSION OF CACM ALGORITHM NO. 291.
      DOUBLE PRECISION FUNCTION DGAMLN (XARG)
      DOUBLE PRECISION XARG, X, P, Z
      X=XARG
      P=1.D0
      DGAMLN=0.D0
  110 IF (X .GE. 30.D0) GO TO 150
      P=P*X
      X=X+1.D0
      GO TO 110
  150 IF (XARG .LT. 30.D0) DGAMLN=-DLOG(P)
      Z=1.D0/X**2
      DGAMLN=DGAMLN+(X-.5D0)*DLOG(X)-X+.918938533204672742D0-
     1       (((Z/1680.D0 - 1.D0/1260.D0)*Z + 1.D0/360.D0)*Z -
     2        1.D0/12.D0)/X
      RETURN
      END
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C  FUNCTION BETAIN_LCMODL.  APPROXIMATES THE INCOMPLETE BETA FUNCTION RATIO
C      I(SUB X)(A,B) USING ABRAMOWITZ AND STEGUN (26.5.5).
C  Gamma functions evaluated with DGAMLN.
C  TOL made smaller.
C  GOOD TO ABOUT 1 PART IN 1/[max(A,B)*TOL] (TOL SET IN DATA STATEMENT BELOW).
C  FOR VERY LARGE (.GT. 1.E+4) A OR B, OF THE ORDER OF MAX(A,B) TERMS
C      ARE NEEDED, AND AN ASYMPTOTIC FORMULA WOULD BE BETTER.
C      TAKES AN ERROR EXIT IF A OR B .GE. 2.E+4.
C  ERRMES is the LCMODL (not CONTIN) version.
C-------------------------------------------------------------------------------
C  CALLS SUBPROGRAMS - ERRMEs, dGAMLN
C-------------------------------------------------------------------------------
      FUNCTION BETAIN (X,A,B,NOUT)
      CHARACTER CHSUBP*6
      DOUBLE PRECISION DAA, DBB, DGAMLN, DRI
      LOGICAL SWAP
      CHSUBP='BETAIN'
      tol = 1.e-8
      IF (X.LT.0. .OR. X.GT.1. .OR. AMIN1(A,B).LE.0. .OR.
     1    AMAX1(A,B).GE.2.E+4) CALL ERRMES (1, 4, CHSUBP)
      BETAIN=X
      SWAP=X .GT. .5
      IF (SWAP) GO TO 150
      XX=X
      AA=A
      BB=B
      GO TO 200
C-------------------------------------------------------------------------------
C      WHEN SWAP=.TRUE., I(SUB 1-X)(B,A)=1-I(SUB X)(A,B) IS EVALUATED
C      FIRST.
C-------------------------------------------------------------------------------
  150 XX=1.D0-X
      AA=B
      BB=A
  200 CX=1.D0-XX
      IF (AMIN1(XX,X).LE.0. .OR. AMAX1(CX,X).GE.1.) RETURN
      R=XX/CX
C-------------------------------------------------------------------------------
C  TERM IMAX IS APPROXIMATELY THE MAXIMUM TERM IN THE SUM.
C  0 < R < 1 implies IMAX < BB.
C-------------------------------------------------------------------------------
      IMAX=MAX0(0,INT((R*BB-AA-1.)/(R+1.)))
      RI=FLOAT(IMAX)
      SUM=0.
      DAA=AA
      DRI=DBLE(IMAX)
      DBB=BB
      TERMAX=(DAA+DRI)*DLOG(DBLE(XX))+(DBB-DRI-1.D0)*DLOG(DBLE(CX))+
     1 DGAMLN(DAA+DBB)-DGAMLN(DAA+DRI+1.D0)-DGAMLN(DBB-DRI)
      IF (TERMAX .LT. -50.) GO TO 700
      TERMAX=EXP(TERMAX)
      TERM=TERMAX
      SUM=TERM
C-------------------------------------------------------------------------------
C  SUM TERMS FOR I=IMAX+1,IMAX+2,... UNTIL CONVERGENCE.
C-------------------------------------------------------------------------------
      I1=IMAX+1
      DO 250 I=I1,40000
        TNUMER=BB-FLOAT(I)
        TERM=TERM*R*TNUMER/(AA+FLOAT(I))
        SUM=SUM+TERM
C       -----------------------------------------------------------------------
C       TNUMER = 0 implies that the denominators of all following terms contain
C                  beta functions with zero arguments, which make the terms 0.
C                  This occurs when BB is an integer.
C       -----------------------------------------------------------------------
        IF (ABS(TERM).LE.TOL*SUM .OR. ABS(TNUMER).LE.1.E-3) GO TO 300
  250 CONTINUE
      CALL ERRMES (2, 3, CHSUBP)
  300 IF (IMAX .EQ. 0) GO TO 700
C-------------------------------------------------------------------------------
C  SUM TERMS FOR I=IMAX-1,IMAX-2,... UNTIL CONVERGENCE.
C-------------------------------------------------------------------------------
      TERM=TERMAX
      DO 320 I=IMAX,1,-1
        RI=FLOAT(I)
        TERM=TERM*(AA+RI)/(R*(BB-RI))
        SUM=SUM+TERM
        IF (ABS(TERM) .LE. TOL*SUM) GO TO 700
  320 CONTINUE
  700 BETAIN=SUM
      IF (SWAP) BETAIN=1.D0-BETAIN
      RETURN
      END
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C     SUBROUTINE PNNLS  (A,MDA,M,N,B,X,VAR,W,ZZ,INDEX,MODE,RANGE,
C                         NONNEG,DVARAC,NSETP)
C  NSETP = no. of positive solution points
C        = no. of degrees of freedom
C  NONNEG(J) = T if parameter J is to be constrained to be nonnegative
C  DVAR = DVARAC + RNORM**2 is returned rather than RNORM.
C  FACTOR is decreased by a factor of RFACTR up to MFACTR times when there are
C    more than 2*N iterations in the inner loop.  See the DATA statement below.
C     BASED ON C.L.LAWSON AND R.J.HANSON,
C     'SOLVING LEAST SQUARES PROBLEMS', PRENTICE-HALL, 1974
C
C         **********   NONNEGATIVE LEAST SQUARES   **********
C
C     GIVEN AN M BY N MATRIX, A, AND AN M-VECTOR, B,  COMPUTE AN
C     N-VECTOR, X, WHICH SOLVES THE LEAST SQUARES PROBLEM
C
C                      A * X = B  SUBJECT TO X .GE. 0
C
C     A(),MDA,M,N     MDA IS THE FIRST DIMENSIONING PARAMETER FOR THE
C                     ARRAY, A().   ON ENTRY A() CONTAINS THE M BY N
C                     MATRIX, A.           ON EXIT A() CONTAINS
C                     THE PRODUCT MATRIX, Q*A , WHERE Q IS AN
C                     M BY M ORTHOGONAL MATRIX GENERATED IMPLICITLY BY
C                     THIS SUBROUTINE.
C     B()     ON ENTRY B() CONTAINS THE M-VECTOR, B.   ON EXIT B() CON-
C             TAINS Q*B.
C     X()     ON ENTRY X() NEED NOT BE INITIALIZED.  ON EXIT X() WILL
C             CONTAIN THE SOLUTION VECTOR.
C     DVAR    ON EXIT DVAR CONTAINS THE squared EUCLIDEAN NORM OF THE
C             RESIDUAL VECTOR.  DVAR is DOUBLE PRECISION.
C     W()     AN N-ARRAY OF WORKING SPACE.  ON EXIT W() WILL CONTAIN
C             THE DUAL SOLUTION VECTOR.   W WILL SATISFY W(I) = 0.
C             FOR ALL I IN SET P  AND W(I) .LE. 0. FOR ALL I IN SET Z
C     ZZ()     AN M-ARRAY OF WORKING SPACE.
C     INDEX()     AN INTEGER WORKING ARRAY OF LENGTH AT LEAST N.
C                 ON EXIT THE CONTENTS OF THIS ARRAY DEFINE THE SETS
C                 P AND Z AS FOLLOWS..
C
C                 INDEX(1)   THRU INDEX(NSETP) = SET P.
C                 INDEX(IZ1) THRU INDEX(IZ2)   = SET Z.
C                 IZ1 = NSETP + 1 = NPP1
C                 IZ2 = N
C     MODE    THIS IS A SUCCESS-FAILURE FLAG WITH THE FOLLOWING
C             MEANINGS.
C             1     THE SOLUTION HAS BEEN COMPUTED SUCCESSFULLY.
C             2     THE DIMENSIONS OF THE PROBLEM ARE BAD.
C                   EITHER M .LE. 0 OR N .LE. 0.
C             3    ITERATION COUNT EXCEEDED.  MORE THAN 2*N*MFACTR ITERATIONS.
C
C  RANGE IS 2 OR 3 ORDERS OF MAGNITUDE SMALLER THAN BIG, WHERE BIG IS
C      THE LARGEST NUMBER THAT DOES NOT OVERFLOW AND 1/BIG DOES NOT
C      UNDERFLOW.  FOR THE DOUBLE PRECISION VERSION, BIG AND RANGE
C      ARE IN DOUBLE PRECISION.  FOR THE SINGLE PRECISION VERSION,
C      THEY ARE IN SINGLE PRECISION (AND THEREFORE RANGE=SRANGE).
C-------------------------------------------------------------------------------
C  CALLS SUBPROGRAMS - DIFF, H12, G1, G2
C-------------------------------------------------------------------------------
      SUBROUTINE PNNLS (A,MDA,M,N,B,X,DVAR,W,ZZ,INDEX,MODE,RANGE,
     1                   NONNEG,DVARAC,NSETP)
      DOUBLE PRECISION A, ABS, ALPHA, ASAVE, B, CC, DIFF, DUMMY,
     1 DVAR, DVARAC, FACTOR, RANGE, SM, SQRT, SS, T, TWO, UNORM,
     2 UP, W, WMAX, X, ZERO, ZTEST, ZZ
      DIMENSION A(MDA,N), B(*), X(*), W(*), ZZ(*)
      INTEGER INDEX(N)
      CHARACTER CHSUBP*6
      LOGICAL NONNEG(N)
      DATA MFACTR/4/, RFACTR/.01/
      ABS(T)=DABS(T)
      SQRT(T)=DSQRT(T)
      ZERO=0.D0
      TWO=2.D0
      FACTOR=1.D-2
C
      CHSUBP='PNNLS'
      NFACTR=0
      MODE=1
      IF (M.GT.0.AND.N.GT.0) GO TO 10
      MODE=2
      RETURN
   10 ITER=0
      ITMAX=2*N
C
C                    INITIALIZE THE ARRAYS INDEX() AND X().
C
          DO 20 I=1,N
          X(I)=ZERO
   20     INDEX(I)=I
C
      IZ2=N
      IZ1=1
      NSETP=0
      NPP1=1
C                             ******  MAIN LOOP BEGINS HERE  ******
   30 CONTINUE
C                  QUIT IF ALL COEFFICIENTS ARE ALREADY IN THE SOLUTION.
C                        OR IF M COLS OF A HAVE BEEN TRIANGULARIZED.
C
      IF (IZ1.GT.IZ2.OR.NSETP.GE.M) GO TO 350
C
C         COMPUTE COMPONENTS OF THE DUAL (NEGATIVE GRADIENT) VECTOR W().
C
          DO 50 IZ=IZ1,IZ2
          J=INDEX(IZ)
          SM=ZERO
              DO 40 L=NPP1,M
   40         SM=SM+A(L,J)*B(L)
          IF (NONNEG(J)) THEN
             W(J)=SM
          ELSE
             W(J)=ABS(SM)
          END IF
   50     CONTINUE

C                                   FIND LARGEST POSITIVE W(J).
   60 WMAX=ZERO
          DO 70 IZ=IZ1,IZ2
          J=INDEX(IZ)
          IF (W(J).LE.WMAX) GO TO 70
          WMAX=W(J)
          IZMAX=IZ
   70     CONTINUE
C
C             IF WMAX .LE. 0. GO TO TERMINATION.
C             THIS INDICATES SATISFACTION OF THE KUHN-TUCKER CONDITIONS.
C
      IF (WMAX) 350,350,80
   80 IZ=IZMAX
      J=INDEX(IZ)
C
C     THE SIGN OF W(J) IS OK FOR J TO BE MOVED TO SET P.
C     BEGIN THE TRANSFORMATION AND CHECK NEW DIAGONAL ELEMENT TO AVOID
C     NEAR LINEAR DEPENDENCE.
C
      ASAVE=A(NPP1,J)
      CALL H12 (1,NPP1,NPP1+1,M,A(1,J),1,UP,DUMMY,1,1,0,RANGE)
      UNORM=ZERO
      IF (NSETP.EQ.0) GO TO 100
          DO 90 L=1,NSETP
   90     UNORM=UNORM+A(L,J)**2
      UNORM=SQRT(UNORM)
  100 IF (DIFF(UNORM+ABS(A(NPP1,J))*FACTOR,UNORM)) 130,130,110
C
C     COL J IS SUFFICIENTLY INDEPENDENT.  COPY B INTO ZZ, UPDATE ZZ AND
C     SOLVE FOR ZTEST ( = PROPOSED NEW VALUE FOR X(J) ).
C
  110     DO 120 L=1,M
  120     ZZ(L)=B(L)
      CALL H12 (2,NPP1,NPP1+1,M,A(1,J),1,UP,ZZ,1,1,1,RANGE)
      ZTEST=ZZ(NPP1)/A(NPP1,J)
      IF (.NOT.NONNEG(J)) ZTEST=ABS(ZTEST)
C
C                                     SEE IF ZTEST IS POSITIVE
C
      IF (ZTEST) 130,130,140
C
C     REJECT J AS A CANDIDATE TO BE MOVED FROM SET Z TO SET P.
C     RESTORE A(NPP1,J), SET W(J)=0., AND LOOP BACK TO TEST DUAL
C     COEFFS AGAIN.
C
  130 A(NPP1,J)=ASAVE
      W(J)=ZERO
      GO TO 60
C
C     THE INDEX  J=INDEX(IZ)  HAS BEEN SELECTED TO BE MOVED FROM
C     SET Z TO SET P.    UPDATE B,  UPDATE INDICES,  APPLY HOUSEHOLDER
C     TRANSFORMATIONS TO COLS IN NEW SET Z,  ZERO SUBDIAGONAL ELTS IN
C     COL J,  SET W(J)=0.
C
  140     DO 150 L=1,M
  150     B(L)=ZZ(L)
C
      INDEX(IZ)=INDEX(IZ1)
      INDEX(IZ1)=J
      IZ1=IZ1+1
      NSETP=NPP1
      NPP1=NPP1+1
C
      IF (IZ1.GT.IZ2) GO TO 170
          DO 160 JZ=IZ1,IZ2
          JJ=INDEX(JZ)
  160     CALL H12 (2,NSETP,NPP1,M,A(1,J),1,UP,A(1,JJ),1,MDA,1,RANGE)
  170 CONTINUE
C
      IF (NSETP.EQ.M) GO TO 190
          DO 180 L=NPP1,M
  180     A(L,J)=ZERO
  190 CONTINUE
C
      W(J)=ZERO
C                                SOLVE THE TRIANGULAR SYSTEM.
C                                STORE THE SOLUTION TEMPORARILY IN ZZ().
      next = 200
      GO TO 400
  200 CONTINUE
C
C                       ******  SECONDARY LOOP BEGINS HERE ******
C
C                          ITERATION COUNTER.
C
  210 ITER=ITER+1
      IF (ITER .GT. ITMAX) THEN
         IF (NFACTR .GE. MFACTR) THEN
            MODE=3
            GO TO 350
         ELSE
            CALL ERRMES (1, 1, CHSUBP)
            NFACTR=NFACTR+1
            FACTOR=FACTOR*RFACTR
            ITER=0
         END IF
      END IF
C
C                    SEE IF ALL NEW CONSTRAINED COEFFS ARE FEASIBLE.
C                                  IF NOT COMPUTE ALPHA.
C
      ALPHA=TWO
          DO 240 IP=1,NSETP
          L=INDEX(IP)
          IF (NONNEG(L) .AND. ZZ(IP).LE.ZERO) THEN
             T=-X(L)/(ZZ(IP)-X(L))
             IF (ALPHA.LE.T) GO TO 240
             ALPHA=T
             JJ=IP
          END IF
  240     CONTINUE
C
C          IF ALL NEW CONSTRAINED COEFFS ARE FEASIBLE THEN ALPHA WILL
C          STILL = 2.    IF SO EXIT FROM SECONDARY LOOP TO MAIN LOOP.
C
      IF (ALPHA.EQ.TWO) GO TO 330
C
C          OTHERWISE USE ALPHA WHICH WILL BE BETWEEN 0. AND 1. TO
C          INTERPOLATE BETWEEN THE OLD X AND THE NEW ZZ.
C
          DO 250 IP=1,NSETP
          L=INDEX(IP)
  250     X(L)=X(L)+ALPHA*(ZZ(IP)-X(L))
C
C        MODIFY A AND B AND THE INDEX ARRAYS TO MOVE COEFFICIENT I
C        FROM SET P TO SET Z.
C
      I=INDEX(JJ)
  260 X(I)=ZERO
C
      IF (JJ.EQ.NSETP) GO TO 290
      JJ=JJ+1
          DO 280 J=JJ,NSETP
          II=INDEX(J)
          INDEX(J-1)=II
          CALL G1 (A(J-1,II),A(J,II),CC,SS,A(J-1,II))
          A(J,II)=ZERO
              DO 270 L=1,N
              IF (L.NE.II) CALL G2 (CC,SS,A(J-1,L),A(J,L))
  270         CONTINUE
  280     CALL G2 (CC,SS,B(J-1),B(J))
  290 NPP1=NSETP
      NSETP=NSETP-1
      IZ1=IZ1-1
      INDEX(IZ1)=I
C
C        SEE IF THE REMAINING COEFFS IN SET P ARE FEASIBLE.  THEY SHOULD
C        BE BECAUSE OF THE WAY ALPHA WAS DETERMINED.
C        IF ANY ARE INFEASIBLE IT IS DUE TO ROUND-OFF ERROR.  ANY
C        THAT ARE NONPOSITIVE WILL BE SET TO ZERO
C        AND MOVED FROM SET P TO SET Z.
C
          DO 300 JJ=1,NSETP
          I=INDEX(JJ)
          IF (NONNEG(I) .AND. X(I).LE.ZERO) GO TO 260
  300     CONTINUE
C
C         COPY B( ) INTO ZZ( ).  THEN SOLVE AGAIN AND LOOP BACK.
C
          DO 310 I=1,M
  310     ZZ(I)=B(I)
      next = 320
      GO TO 400
  320 CONTINUE
      GO TO 210
C                      ******  END OF SECONDARY LOOP  ******
C
  330     DO 340 IP=1,NSETP
          I=INDEX(IP)
  340     X(I)=ZZ(IP)
C        ALL NEW COEFFS ARE POSITIVE.  LOOP BACK TO BEGINNING.
      GO TO 30
C
C                        ******  END OF MAIN LOOP  ******
C
C                        COME TO HERE FOR TERMINATION.
C                     COMPUTE THE NORM OF THE FINAL RESIDUAL VECTOR.
C
  350 SM=ZERO
      IF (NPP1.GT.M) GO TO 370
          DO 360 I=NPP1,M
  360     SM=SM+B(I)**2
      GO TO 390
  370     DO 380 J=1,N
  380     W(J)=ZERO
  390 DVAR=SM+DVARAC
      RETURN
C
C     THE FOLLOWING BLOCK OF CODE IS USED AS AN INTERNAL SUBROUTINE
C     TO SOLVE THE TRIANGULAR SYSTEM, PUTTING THE SOLUTION IN ZZ().
C
  400     DO 430 L=1,NSETP
          IP=NSETP+1-L
          IF (L.EQ.1) GO TO 420
              DO 410 II=1,IP
  410         ZZ(II)=ZZ(II)-A(II,JJ)*ZZ(IP+1)
  420     JJ=INDEX(IP)
  430     ZZ(IP)=ZZ(IP)/A(IP,JJ)
      if (next .eq. 200) go to 200
      if (next .eq. 320) go to 320
      END
C++++++++++++++++ DOUBLE PRECISION VERSION 2DP (MAR 1984) ++++++++++++++
C  FUNCTION DIFF.
C     BASED ON C.L.LAWSON AND R.J.HANSON,
C     'SOLVING LEAST SQUARES PROBLEMS', PRENTICE-HALL, 1974
C     FUNCTION DIFF(X,Y)!SP
      DOUBLE PRECISION FUNCTION DIFF(X,Y)
      DOUBLE PRECISION X, Y
      DIFF=X-Y
      RETURN
      END
C++++++++++++++++ DOUBLE PRECISION VERSION 2DP (MAR 1984) ++++++++++++++
C  SUBROUTINE G1.
      SUBROUTINE G1 (A,B,COS,SIN,SIG)
C     BASED ON C.L.LAWSON AND R.J.HANSON,
C     'SOLVING LEAST SQUARES PROBLEMS', PRENTICE-HALL, 1974
C
C
C     COMPUTE ORTHOGONAL ROTATION MATRIX..
C     COMPUTE.. MATRIX   (C, S) SO THAT (C, S)(A) = (SQRT(A**2+B**2))
C                        (-S,C)         (-S,C)(B)   (   0          )
C     COMPUTE SIG = SQRT(A**2+B**2)
C        SIG IS COMPUTED LAST TO ALLOW FOR THE POSSIBILITY THAT
C        SIG MAY BE IN THE SAME LOCATION AS A OR B .
C
      DOUBLE PRECISION A, ABS, B, COS, ONE, SIG, SIGN, SIN, SQRT,
     1 XR, YR, ZERO
      ABS(A)=DABS(A)
      SQRT(A)=DSQRT(A)
      SIGN(A,B)=DSIGN(A,B)
C     ZERO=0.E0!SP
      ZERO=0.D0
C     ONE=1.E0!SP
      ONE=1.D0
      IF (ABS(A).LE.ABS(B)) GO TO 10
      XR=B/A
      YR=SQRT(ONE+XR**2)
      COS=SIGN(ONE/YR,A)
      SIN=COS*XR
      SIG=ABS(A)*YR
      RETURN
   10 IF (B) 20,30,20
   20 XR=A/B
      YR=SQRT(ONE+XR**2)
      SIN=SIGN(ONE/YR,B)
      COS=SIN*XR
      SIG=ABS(B)*YR
      RETURN
   30 SIG=ZERO
      COS=ZERO
      SIN=ONE
      RETURN
      END
C++++++++++++++++ DOUBLE PRECISION VERSION 2DP (MAR 1984) ++++++++++++++
C  SUBROUTINE G2.
      SUBROUTINE G2    (COS,SIN,X,Y)
C     BASED ON C.L.LAWSON AND R.J.HANSON,
C     'SOLVING LEAST SQUARES PROBLEMS', PRENTICE-HALL, 1974
C          APPLY THE ROTATION COMPUTED BY G1 TO (X,Y).
      DOUBLE PRECISION COS, SIN, X, XR, Y
      XR=COS*X+SIN*Y
      Y=-SIN*X+COS*Y
      X=XR
      RETURN
      END
C++++++++++++++++ DOUBLE PRECISION VERSION 2DP (MAR 1984) ++++++++++++++
C     SUBROUTINE H12 (MODE,LPIVOT,L1,M,U,IUE,UP,C,ICE,ICV,NCV,RANGE)
C     BASED ON C.L.LAWSON AND R.J.HANSON,
C     'SOLVING LEAST SQUARES PROBLEMS', PRENTICE-HALL, 1974
C
C     CONSTRUCTION AND/OR APPLICATION OF A SINGLE
C     HOUSEHOLDER TRANSFORMATION..     Q = I + U*(U**T)/B
C
C     MODE    = 1 OR 2   TO SELECT ALGORITHM  H1  OR  H2 .
C     LPIVOT IS THE INDEX OF THE PIVOT ELEMENT.
C     L1,M   IF L1 .LE. M   THE TRANSFORMATION WILL BE CONSTRUCTED TO
C            ZERO ELEMENTS INDEXED FROM L1 THROUGH M.   IF L1 GT. M
C            THE SUBROUTINE DOES AN IDENTITY TRANSFORMATION.
C     U(),IUE,UP    ON ENTRY TO H1 U() CONTAINS THE PIVOT VECTOR.
C                   IUE IS THE STORAGE INCREMENT BETWEEN ELEMENTS.
C                                       ON EXIT FROM H1 U() AND UP
C                   CONTAIN QUANTITIES DEFINING THE VECTOR U OF THE
C                   HOUSEHOLDER TRANSFORMATION.   ON ENTRY TO H2 U()
C                   AND UP SHOULD CONTAIN QUANTITIES PREVIOUSLY COMPUTED
C                   BY H1.  THESE WILL NOT BE MODIFIED BY H2.
C     C()    ON ENTRY TO H1 OR H2 C() CONTAINS A MATRIX WHICH WILL BE
C            REGARDED AS A SET OF VECTORS TO WHICH THE HOUSEHOLDER
C            TRANSFORMATION IS TO BE APPLIED.  ON EXIT C() CONTAINS THE
C            SET OF TRANSFORMED VECTORS.
C     ICE    STORAGE INCREMENT BETWEEN ELEMENTS OF VECTORS IN C().
C     ICV    STORAGE INCREMENT BETWEEN VECTORS IN C().
C     NCV    NUMBER OF VECTORS IN C() TO BE TRANSFORMED. IF NCV .LE. 0
C            NO OPERATIONS WILL BE DONE ON C().
C  RANGE IS 2 OR 3 ORDERS OF MAGNITUDE SMALLER THAN BIG, WHERE BIG IS
C      THE LARGEST NUMBER THAT DOES NOT OVERFLOW AND 1/BIG DOES NOT
C      UNDERFLOW.  FOR THE DOUBLE PRECISION VERSION, BIG AND RANGE
C      ARE IN DOUBLE PRECISION.  FOR THE SINGLE PRECISION VERSION,
C      THEY ARE IN SINGLE PRECISION (AND THEREFORE RANGE=SRANGE).
C
      SUBROUTINE H12 (MODE,LPIVOT,L1,M,U,IUE,UP,C,ICE,ICV,NCV,RANGE)
      DIMENSION U(IUE,*), C(*)
      DOUBLE PRECISION SM,B
      DOUBLE PRECISION ABS, AMAX1, C, CL, CLINV, DOUBLE, ONE, RANGE,
     1 RANGIN, SIGN, SM1, SQRT, U, UP
      ABS(SM)=DABS(SM)
      AMAX1(SM,ONE)=DMAX1(SM,ONE)
C     DOUBLE(ONE)=DBLE(ONE)!SP
      DOUBLE(SM)=SM
      SQRT(SM)=DSQRT(SM)
      SIGN(SM,ONE)=DSIGN(SM,ONE)
C     ONE=1.E0!SP
      ONE=1.D0
C
      IF (0.GE.LPIVOT.OR.LPIVOT.GE.L1.OR.L1.GT.M) RETURN
      RANGIN=ONE/RANGE
      CL=ABS(U(1,LPIVOT))
      IF (MODE.EQ.2) GO TO 60
C                            ****** CONSTRUCT THE TRANSFORMATION. ******
          DO 10 J=L1,M
   10     CL=AMAX1(ABS(U(1,J)),CL)
      IF (CL .LE. RANGIN) GO TO 130
      CLINV=ONE/CL
      SM=(DOUBLE(U(1,LPIVOT))*CLINV)**2
          DO 30 J=L1,M
   30     SM=SM+(DOUBLE(U(1,J))*CLINV)**2
C                          CONVERT DOUBLE PREC. SM TO SNGL. PREC. SM1
      SM1=SM
      CL=-SIGN(CL*SQRT(SM1),U(1,LPIVOT))
      UP=U(1,LPIVOT)-CL
      U(1,LPIVOT)=CL
      GO TO 70
C            ****** APPLY THE TRANSFORMATION  I+U*(U**T)/B  TO C. ******
C
   60 IF (CL .LE. RANGIN) GO TO 130
   70 IF (NCV.LE.0) RETURN
      B=DOUBLE(UP)*U(1,LPIVOT)
C                       B  MUST BE NONPOSITIVE HERE.  IF B = 0., RETURN.
C
      IF (B .GE. -RANGIN) GO TO 130
      B=ONE/B
      I2=1-ICV+ICE*(LPIVOT-1)
      INCR=ICE*(L1-LPIVOT)
          DO 120 J=1,NCV
          I2=I2+ICV
          I3=I2+INCR
          I4=I3
          SM=C(I2)*DOUBLE(UP)
              DO 90 I=L1,M
              SM=SM+C(I3)*DOUBLE(U(1,I))
   90         I3=I3+ICE
          IF (SM) 100,120,100
  100     SM=SM*B
          C(I2)=C(I2)+SM*DOUBLE(UP)
              DO 110 I=L1,M
              C(I4)=C(I4)+SM*DOUBLE(U(1,I))
  110         I4=I4+ICE
  120     CONTINUE
  130 RETURN
      END
C++++++++++++++++ DOUBLE PRECISION VERSION 2DP (MAR 1984) ++++++++++++++
C  SUBROUTINE PLPRIN.  PLOTS Y1 (AND Y2, IF ONLY1=.FALSE.) VS. X ON
C      LINE PRINTER, AND PRINTS Y1 AND X.
C  IF PLTERR=T, AN ERROR BAND IS ALSO PLOTTED USING THE ERRORS
C      SUPPLIED IN YERR.
C  IF NLINF.GT.0, THEN THE NLINF LINEAR COEFFICIENTS Y(J), J=NG+1,MY1
C      ARE PRINTED OUT.  IN THIS CASE MY1=NGL NORMALLY.
      SUBROUTINE PLPRIN (X,Y1,Y2,N,ONLY1,NOUT,SRANGE,NLINF,NG,MY1,
     1 YERR, PLTERR)
      character*1 char(5), ih(109)
      DOUBLE PRECISION YERR, DUB
      LOGICAL ONLY1, PLTERR
      DIMENSION X(*), Y1(*), Y2(*), YERR(*)
      DATA CHAR/' ', 'X', 'O', '*', '.'/
C     SINGLE(DUB)=DUB!SP
      SINGLE(DUB)=SNGL(DUB)
      DUB=1.D0
      YMIN=SRANGE
      YMAX=-SRANGE
      DO 120 J=1,N
        YMIN=AMIN1(YMIN,Y1(J))
        YMAX=AMAX1(YMAX,Y1(J))
        IF (ONLY1) GO TO 120
        YMIN=AMIN1(YMIN,Y2(J))
        YMAX=AMAX1(YMAX,Y2(J))
  120 CONTINUE
      DUM=YMAX-YMIN
      NCHAR=109
      IF (DUM .LE. FLOAT(NCHAR)/SRANGE) DUM=1.
      IF (PLTERR) GO TO 130
      WRITE (NOUT,5120)
 5120 FORMAT (/4X,8HORDINATE,2X,8HABSCISSA)
      GO TO 140
  130 NCHAR=100
 5130 FORMAT (/4X,8HORDINATE,4X,5HERROR,2X,8HABSCISSA)
      WRITE (NOUT,5130)
  140 R=(FLOAT(NCHAR)-.001)/DUM
      DO 150 J=1,N
        DO 155 L1=1,NCHAR
          IH(L1)=CHAR(1)
  155   CONTINUE
        IF (.NOT.PLTERR) GO TO 158
        LMIN=INT((AMAX1(YMIN,Y1(J)-ABS(SINGLE(YERR(J))))-YMIN)*R)+1
        LMAX=INT((AMIN1(YMAX,Y1(J)+ABS(SINGLE(YERR(J))))-YMIN)*R)+1
        IF (LMIN .GE. LMAX) GO TO 158
        DO 156 L1=LMIN,LMAX
          IH(L1)=CHAR(5)
  156   CONTINUE
  158   L1=INT((Y1(J)-YMIN)*R)+1
        IH(L1)=CHAR(2)
        IF (ONLY1) GO TO 160
        L2=INT((Y2(J)-YMIN)*R)+1
        IH(L2)=CHAR(3)
        IF (L1 .EQ. L2) IH(L2)=CHAR(4)
  160   IF (.NOT.PLTERR) WRITE (NOUT,5160) Y1(J),X(J),IH
 5160   FORMAT (1X,1PE11.3,E10.2,109A1)
        IF (PLTERR) WRITE (NOUT,5161) Y1(J),YERR(J),X(J),
     1  (IH(L1),L1=1,NCHAR)
C5161   FORMAT (1X,1PE11.3,E9.1,E10.2,100A1)!SP
 5161   FORMAT (1X,1PE11.3,D9.1,E10.2,100A1)
  150 CONTINUE
      IF (NLINF .LE. 0) GO TO 800
      L2=NG+1
 5200 FORMAT (22H0LINEAR COEFFICIENTS =,1P8E13.4/(22X,8E13.4))
      IF (.NOT.PLTERR) WRITE (NOUT,5200) (Y1(J),J=L2,MY1)
      IF (PLTERR) WRITE(NOUT,5201) (Y1(J),YERR(J),J=L2,MY1)
C5201 FORMAT (22H0LINEAR COEFFICIENTS =,!SP
C    1 1PE13.4,3H +-,E9.1,E20.4,3H +-,E9.1,E20.4,3H +-,E9.1/!SP
C    2 (22X,1PE13.4,3H +-,E9.1,E20.4,3H +-,E9.1,E20.4,3H +-,E9.1))!SP
 5201 FORMAT (22H0LINEAR COEFFICIENTS =,
     1 1PE13.4,3H +-,D9.1,E20.4,3H +-,D9.1,E20.4,3H +-,D9.1/
     2 (22X,1PE13.4,3H +-,D9.1,E20.4,3H +-,D9.1,E20.4,3H +-,D9.1))
  800 RETURN
      END
      subroutine EIGVrs(nm,n,a,w,z,fv1,fv2,ierr)
c
      integer n,nm,ierr
      real a(nm,n),w(n),z(nm,n),fv1(n),fv2(n)
c
c     this subroutine calls the recommended sequence of
c     subroutines from the eigensystem subroutine package (eispack)
c     to find the eigenvalues and eigenvectors
c     of a real symmetric matrix.
c
c     on input
c
c        nm  must be set to the row dimension of the two-dimensional
c        array parameters as declared in the calling program
c        dimension statement.
c
c        n  is the order of the matrix  a.
c
c        a  contains the real symmetric matrix.
c
c     on output
c
c        w  contains the eigenvalues in ascending order.
c
c        z  contains the eigenvectors.
c
c        ierr  is an integer output variable set equal to an error
c           completion code described in the documentation for tqlrat
c           and tql2.  the normal completion code is zero.
c
c        fv1  and  fv2  are temporary storage arrays.
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated august 1983.
c
c     ------------------------------------------------------------------
c
      if (n .le. nm) go to 10
      ierr = 10 * n
      go to 50
c
c     .......... find both eigenvalues and eigenvectors ..........
   10 call  tred2(nm,n,a,w,fv1,z)
      call  tql2(nm,n,w,fv1,z,ierr)
   50 return
      end
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      subroutine tql2(nm,n,d,e,z,ierr)
c
      integer i,j,k,l,m,n,ii,l1,l2,nm,mml,ierr
      real d(n),e(n),z(nm,n)
      real c,c2,c3,dl1,el1,f,g,h,p,r,s,s2,tst1,tst2,pythag
c
c     this subroutine is a translation of the algol procedure tql2,
c     num. math. 11, 293-306(1968) by bowdler, martin, reinsch, and
c     wilkinson.
c     handbook for auto. comp., vol.ii-linear algebra, 227-240(1971).
c
c     this subroutine finds the eigenvalues and eigenvectors
c     of a symmetric tridiagonal matrix by the ql method.
c     the eigenvectors of a full symmetric matrix can also
c     be found if  tred2  has been used to reduce this
c     full matrix to tridiagonal form.
c
c     on input
c
c        nm must be set to the row dimension of two-dimensional
c          array parameters as declared in the calling program
c          dimension statement.
c
c        n is the order of the matrix.
c
c        d contains the diagonal elements of the input matrix.
c
c        e contains the subdiagonal elements of the input matrix
c          in its last n-1 positions.  e(1) is arbitrary.
c
c        z contains the transformation matrix produced in the
c          reduction by  tred2, if performed.  if the eigenvectors
c          of the tridiagonal matrix are desired, z must contain
c          the identity matrix.
c
c      on output
c
c        d contains the eigenvalues in ascending order.  if an
c          error exit is made, the eigenvalues are correct but
c          unordered for indices 1,2,...,ierr-1.
c
c        e has been destroyed.
c
c        z contains orthonormal eigenvectors of the symmetric
c          tridiagonal (or full) matrix.  if an error exit is made,
c          z contains the eigenvectors associated with the stored
c          eigenvalues.
c
c        ierr is set to
c          zero       for normal return,
c          j          if the j-th eigenvalue has not been
c                     determined after 30 iterations.
c
c     calls pythag for  sqrt(a*a + b*b) .
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated august 1983.
c
c     ------------------------------------------------------------------
c
      ierr = 0
      if (n .eq. 1) go to 1001
c
      do 100 i = 2, n
  100 e(i-1) = e(i)
c
      f = 0.0e0
      tst1 = 0.0e0
      e(n) = 0.0e0
c
      do 240 l = 1, n
         j = 0
         h = abs(d(l)) + abs(e(l))
         if (tst1 .lt. h) tst1 = h
c     .......... look for small sub-diagonal element ..........
         do 110 m = l, n
            tst2 = tst1 + abs(e(m))
            if (tst2 .eq. tst1) go to 120
c     .......... e(n) is always zero, so there is no exit
c                through the bottom of the loop ..........
  110    continue
c
  120    if (m .eq. l) go to 220
  130    if (j .eq. 30) go to 1000
         j = j + 1
c     .......... form shift ..........
         l1 = l + 1
         l2 = l1 + 1
         g = d(l)
         p = (d(l1) - g) / (2.0e0 * e(l))
         r = pythag(p,1.0e0)
         d(l) = e(l) / (p + sign(r,p))
         d(l1) = e(l) * (p + sign(r,p))
         dl1 = d(l1)
         h = g - d(l)
         if (l2 .gt. n) go to 145
c
         do 140 i = l2, n
  140    d(i) = d(i) - h
c
  145    f = f + h
c     .......... ql transformation ..........
         p = d(m)
         c = 1.0e0
         c2 = c
         el1 = e(l1)
         s = 0.0e0
         mml = m - l
c     .......... for i=m-1 step -1 until l do -- ..........
         do 200 ii = 1, mml
            c3 = c2
            c2 = c
            s2 = s
            i = m - ii
            g = c * e(i)
            h = c * p
            r = pythag(p,e(i))
            e(i+1) = s * r
            s = e(i) / r
            c = p / r
            p = c * d(i) - s * g
            d(i+1) = h + s * (c * g + s * d(i))
c     .......... form vector ..........
            do 180 k = 1, n
               h = z(k,i+1)
               z(k,i+1) = s * z(k,i) + c * h
               z(k,i) = c * z(k,i) - s * h
  180       continue
c
  200    continue
c
         p = -s * s2 * c3 * el1 * e(l) / dl1
         e(l) = s * p
         d(l) = c * p
         tst2 = tst1 + abs(e(l))
         if (tst2 .gt. tst1) go to 130
  220    d(l) = d(l) + f
  240 continue
c     .......... order eigenvalues and eigenvectors ..........
      do 300 ii = 2, n
         i = ii - 1
         k = i
         p = d(i)
c
         do 260 j = ii, n
            if (d(j) .ge. p) go to 260
            k = j
            p = d(j)
  260    continue
c
         if (k .eq. i) go to 300
         d(k) = d(i)
         d(i) = p
c
         do 280 j = 1, n
            p = z(j,i)
            z(j,i) = z(j,k)
            z(j,k) = p
  280    continue
c
  300 continue
c
      go to 1001
c     .......... set error -- no convergence to an
c                eigenvalue after 30 iterations ..........
 1000 ierr = l
 1001 return
      end
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      subroutine tred2(nm,n,a,d,e,z)
c
      integer i,j,k,l,n,ii,nm,jp1
      real a(nm,n),d(n),e(n),z(nm,n)
      real f,g,h,hh,scale
c
c     this subroutine is a translation of the algol procedure tred2,
c     num. math. 11, 181-195(1968) by martin, reinsch, and wilkinson.
c     handbook for auto. comp., vol.ii-linear algebra, 212-226(1971).
c
c     this subroutine reduces a real symmetric matrix to a
c     symmetric tridiagonal matrix using and accumulating
c     orthogonal similarity transformations.
c
c     on input
c
c        nm must be set to the row dimension of two-dimensional
c          array parameters as declared in the calling program
c          dimension statement.
c
c        n is the order of the matrix.
c
c        a contains the real symmetric input matrix.  only the
c          lower triangle of the matrix need be supplied.
c
c     on output
c
c        d contains the diagonal elements of the tridiagonal matrix.
c
c        e contains the subdiagonal elements of the tridiagonal
c          matrix in its last n-1 positions.  e(1) is set to zero.
c
c        z contains the orthogonal transformation matrix
c          produced in the reduction.
c
c        a and z may coincide.  if distinct, a is unaltered.
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated august 1983.
c
c     ------------------------------------------------------------------
c
      do 100 i = 1, n
c
         do 80 j = i, n
   80    z(j,i) = a(j,i)
c
         d(i) = a(n,i)
  100 continue
c
      if (n .eq. 1) go to 510
c     .......... for i=n step -1 until 2 do -- ..........
      do 300 ii = 2, n
         i = n + 2 - ii
         l = i - 1
         h = 0.0e0
         scale = 0.0e0
         if (l .lt. 2) go to 130
c     .......... scale row (algol tol then not needed) ..........
         do 120 k = 1, l
  120    scale = scale + abs(d(k))
c
         if (scale .ne. 0.0e0) go to 140
  130    e(i) = d(l)
c
         do 135 j = 1, l
            d(j) = z(l,j)
            z(i,j) = 0.0e0
            z(j,i) = 0.0e0
  135    continue
c
         go to 290
c
  140    do 150 k = 1, l
            d(k) = d(k) / scale
            h = h + d(k) * d(k)
  150    continue
c
         f = d(l)
         g = -sign(sqrt(h),f)
         e(i) = scale * g
         h = h - f * g
         d(l) = f - g
c     .......... form a*u ..........
         do 170 j = 1, l
  170    e(j) = 0.0e0
c
         do 240 j = 1, l
            f = d(j)
            z(j,i) = f
            g = e(j) + z(j,j) * f
            jp1 = j + 1
            if (l .lt. jp1) go to 220
c
            do 200 k = jp1, l
               g = g + z(k,j) * d(k)
               e(k) = e(k) + z(k,j) * f
  200       continue
c
  220       e(j) = g
  240    continue
c     .......... form p ..........
         f = 0.0e0
c
         do 245 j = 1, l
            e(j) = e(j) / h
            f = f + e(j) * d(j)
  245    continue
c
         hh = f / (h + h)
c     .......... form q ..........
         do 250 j = 1, l
  250    e(j) = e(j) - hh * d(j)
c     .......... form reduced a ..........
         do 280 j = 1, l
            f = d(j)
            g = e(j)
c
            do 260 k = j, l
  260       z(k,j) = z(k,j) - f * e(k) - g * d(k)
c
            d(j) = z(l,j)
            z(i,j) = 0.0e0
  280    continue
c
  290    d(i) = h
  300 continue
c     .......... accumulation of transformation matrices ..........
      do 500 i = 2, n
         l = i - 1
         z(n,l) = z(l,l)
         z(l,l) = 1.0e0
         h = d(i)
         if (h .eq. 0.0e0) go to 380
c
         do 330 k = 1, l
  330    d(k) = z(k,i) / h
c
         do 360 j = 1, l
            g = 0.0e0
c
            do 340 k = 1, l
  340       g = g + z(k,i) * z(k,j)
c
            do 360 k = 1, l
               z(k,j) = z(k,j) - g * d(k)
  360    continue
c
  380    do 400 k = 1, l
  400    z(k,i) = 0.0e0
c
  500 continue
c
  510 do 520 i = 1, n
         d(i) = z(n,i)
         z(n,i) = 0.0e0
  520 continue
c
      z(n,n) = 1.0e0
      e(1) = 0.0e0
      return
      end
C
C
C  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      real function pythag(a,b)
      real a,b
c
c     finds sqrt(a**2+b**2) without overflow or destructive underflow
c
      real p,r,s,t,u
      p = amax1(abs(a),abs(b))
      if (p .eq. 0.0e0) go to 20
      r = (amin1(abs(a),abs(b))/p)**2
   10 continue
         t = 4.0e0 + r
         if (t .eq. 4.0e0) go to 20
         s = r/t
         u = 1.0e0 + 2.0e0*s
         p = u*p
         r = (s/u)**2 * r
      go to 10
   20 pythag = p
      return
      end

max_stars_repo_name: schorschinho/LCModel

max_issues_repo_name: schorschinho/LCModel

max_forks_repo_name: schorschinho/LCModel