      PROGRAM MAIN
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INCLUDE 'SIZES'
      COMMON /KEYWRD/ KEYWRD
      COMMON /GEOVAR/ NVAR,LOC(2,MAXPAR), IDUMY, XPARAM(MAXPAR)
      COMMON /GEOSYM/ NDEP,LOCPAR(MAXPAR),IDEPFN(MAXPAR),LOCDEP(MAXPAR)
      COMMON /GEOKST/ NATOMS,LABELS(NUMATM),
     1NA(NUMATM),NB(NUMATM),NC(NUMATM)
      COMMON /GEOM  / GEO(3,NUMATM)
      COMMON /GRADNT/ GRAD(MAXPAR),GNORM
      COMMON /NUMCAL/ NUMCAL
      COMMON /TIME  / TIME0
      COMMON /PATH  / LATOM,LPARAM,REACT(200)
      CHARACTER*80 KEYWRD
      OPEN(UNIT=5,FILE='FOR005',STATUS='OLD',BLANK='ZERO')
      REWIND 5
      OPEN(UNIT=6,FILE='FOR006',STATUS='NEW')
      REWIND 6
      NUMCAL=1
C
      TIME0=SECOND()
C
C READ AND CHECK INPUT FILE, EXIT IF NECESSARY.
C     WRITE INPUT FILE TO UNIT 6 AS FEEDBACK TO USER
C
   10 CALL READ
      IF(INDEX(KEYWRD,'AUTHOR') .NE. 0) THEN
         WRITE(6,'(10X,'' MOPAC - A GENERAL MOLECULAR ORBITAL PACKAGE'',
     1/         ,10X,''   ORIGINAL VERSION WRITTEN IN 1983'')')
         WRITE(6,'(10X,''     BY JAMES J. P. STEWART AT THE'',/
     1         ,10X,''     UNIVERSITY OF TEXAS AT AUSTIN'',/
     2         ,10X,''          AUSTIN, TEXAS, 78712'')')
      ENDIF
C
C INITIALIZE CALCULATION AND WRITE CALCULATION INDEPENDENT INFO
C
      IF(INDEX(KEYWRD,'0SCF') .NE. 0) STOP
      IF(INDEX(KEYWRD,'EXTERNAL') .NE. 0) THEN
         CALL AM1
      ELSE
         CALL MOLDAT
      ENDIF
      IF (INDEX(KEYWRD,'RESTART').EQ.0)THEN
         IF (INDEX(KEYWRD,' XYZ') .NE. 0.AND.NVAR.NE.0) THEN
C
C   SET ALL OPTIMIZATION FLAGS TO 1.  IT IS POSSIBLE TO SPECIFY " XYZ"
C   AND HAVE 3N-6 FLAGS SET AND STILL NOT HAVE EVERY ATOM MARKED FOR
C   OPTIMIZATION.  THIS CAN HAPPEN IF DUMMY ATOMS ARE PRESENT
C   TO PREVENT THIS, WE EXPLICITELY SET ALL FLAGS.
C
            NVAR=0
            DO 30 I=1,NATOMS
C
C  I DON'T THINK THE FOLLOWING LOGICAL WILL EVER BE TRUE, BUT I'M NOT
C  TAKING IT OUT IN THIS VERSION, JUST IN CASE.
C
               IF(LABELS(I).EQ.99) GOTO 30
               DO 20 J=1,3
                  NVAR=NVAR+1
                  LOC(1,NVAR)=I
                  LOC(2,NVAR)=J
   20          XPARAM(NVAR)=GEO(J,I)
   30       CONTINUE
         ENDIF
         IF (INDEX(KEYWRD,'1SCF') .NE. 0) THEN
         IF(LATOM.NE.0)THEN
         WRITE(6,'(//,10X,A)')'1SCF SPECIFIED WITH PATH.  THIS PAIR OF'
         WRITE(6,'(   10X,A)')'OPTIONS IS NOT ALLOWED'
         STOP
         ENDIF
            NVAR=0
            IF(INDEX(KEYWRD,'GRAD').NE.0) THEN
               NVAR=0
               DO 50 I=2,NATOMS
                  IF(LABELS(I).EQ.99) GOTO 50
                  IF(I.EQ.2)ILIM=1
                  IF(I.EQ.3)ILIM=2
                  IF(I.GT.3)ILIM=3
                  DO 40 J=1,ILIM
                     NVAR=NVAR+1
                     LOC(1,NVAR)=I
                     LOC(2,NVAR)=J
   40             XPARAM(NVAR)=GEO(J,I)
   50          CONTINUE
            ENDIF
         ENDIF
      ENDIF
C
C CALCULATE DYNAMIC REACTION COORDINATE.
C
C
      IF(INDEX(KEYWRD,'SADDLE') .NE. 0) THEN
         CALL REACT1(ESCF)
         GOTO 60
      ENDIF
      CLOSE (5)
      IF(INDEX(KEYWRD,'STEP1') .NE. 0) THEN
         CALL GRID
         STOP
      ENDIF
      IF (LATOM .NE. 0) THEN
C
C       DO PATH
C
         CALL PATHS
         STOP
      ENDIF
      IF (INDEX(KEYWRD,'FORCE') + INDEX(KEYWRD,'IRC=') .NE. 0 ) THEN
C
C FORCE CALCULATION IF DESIRED
C
         CALL FORCE
         STOP
      ENDIF
      IF(INDEX(KEYWRD,' DRC') + INDEX(KEYWRD,' IRC') .NE. 0) THEN
C
C   REACT IS USED AS A DUMMY ARGUMENT - NOT USED BY DRC.
C
         CALL DRC(REACT,REACT)
         STOP
      ENDIF
C
      IF(INDEX(KEYWRD,'NLLSQ') .NE. 0) THEN
         CALL NLLSQ(XPARAM, NVAR )
         CALL COMPFG(XPARAM,.TRUE.,ESCF,.TRUE.,GRAD,.TRUE.)
         GOTO 60
      ENDIF
C
      IF(INDEX(KEYWRD,'SIGMA') .NE. 0) THEN
         CALL POWSQ(XPARAM, NVAR, ESCF)
         GOTO 60
      ENDIF
C
C ORDINARY GEOMETRY OPTIMISATION
C
      CALL FLEPO(XPARAM, NVAR, ESCF)
   60 CALL WRITE(TIME0, ESCF)
      IF(INDEX(KEYWRD,'POLAR') .NE. 0) THEN
         CALL POLAR
      ENDIF
      END


      subroutine gensdp3
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
C***********************************************************************
CD1
CD1  PURPOSE
CD1
CD1  This subroutine solves the non-isothermal air-water equations with
CD1  full jacobian (unsymmetric, 3n by 3).
CD1
C***********************************************************************
CD2
CD2  REVISION HISTORY
CD2
CD2 $Log:   /pvcs.config/fehm90/src/gensdp3.f_a  $
!D2
!D2    Rev 2.5   06 Jan 2004 10:43:06   pvcs
!D2 FEHM Version 2.21, STN 10086-2.21-00, Qualified October 2003
!D2
!D2    Rev 2.4   29 Jan 2003 09:06:32   pvcs
!D2 FEHM Version 2.20, STN 10086-2.20-00
!D2
!D2    Rev 2.3   14 Nov 2001 13:09:26   pvcs
!D2 FEHM Version 2.12, STN 10086-2.12-00
!D2
!D2    Rev 2.2   06 Jun 2001 13:24:08   pvcs
!D2 FEHM Version 2.11, STN 10086-2.11-00
!D2
!D2    Rev 2.1   30 Nov 2000 12:02:32   pvcs
!D2 FEHM Version 2.10, STN 10086-2.10-00
!D2
!D2    Rev 2.0   Fri May 07 14:41:44 1999   pvcs
!D2 FEHM Version 2.0, SC-194 (Fortran 90)
CD2
CD2    Rev 1.14   Fri May 31 15:08:34 1996   gaz
CD2 correction to call to rdof_new
CD2
CD2    Rev 1.13   Wed May 29 08:21:06 1996   gaz
CD2 corrected call to switch and setting of nmatb
CD2
CD2    Rev 1.12   Tue May 21 13:52:24 1996   gaz
CD2 added call md_nodes
CD2
CD2    Rev 1.11   Wed Feb 07 11:09:18 1996   gaz
CD2 corrections to make dpdp air/water/heat work better
CD2
CD2    Rev 1.10   Tue Jan 16 14:31:06 1996   hend
CD2 Added capability for 5,6, and n degrees of freedom
CD2
CD2    Rev 1.9   Fri Jan 12 17:48:46 1996   llt
CD2 changed mmgetblk agruments
CD2
CD2    Rev 1.8   Wed Jan 10 11:49:50 1996   hend
CD2 Corrected ECD Number
CD2
CD2    Rev 1.7   Wed Jan 10 10:32:32 1996   hend
CD2 Added Prolog
CD2
CD2    Rev 1.6   Tue Jan 09 14:30:08 1996   llt
CD2 gaz changes
CD2
CD2    Rev 1.5   03/23/95 23:59:52   gaz
CD2 gaz replaced bp with abs(bp
CD2
CD2    Rev 1.4   11/28/94 14:21:58   llt
CD2 Took out extra comma in argurment list, so would run on ibm.
CD2
CD2    Rev 1.3   06/20/94 11:07:32   zvd
CD2
CD2
CD2    Rev 1.2   03/23/94 14:41:08   robinson
CD2 Additional cleanup of memory management
CD2
CD2    Rev 1.1   03/18/94 15:47:32   gaz
CD2 Added solve_new and cleaned up memory management.
CD2
CD2    Rev 1.0   01/20/94 10:24:20   pvcs
CD2 original version in process of being certified
CD2
C***********************************************************************
CD3
CD3  REQUIREMENTS TRACEABILITY
CD3
CD3  2.3.2 Heat- and mass-transfer equations
CD3  2.5.2 Solve nonlinear equation set at each time step
CD3
C***********************************************************************
CD4
CD4  SPECIAL COMMENTS AND REFERENCES
CD4
CD4 Requirements from SDN: 10086-RD-2.20-00
CD4   SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
CD4   FEHM Application Version 2.20
CD4
C***********************************************************************

      use comai
      use comgi
      use comfi
      use comei
      use comdi
      use comci
      use combi
      use comhi
      use davidi
      use comdti
      implicit none

      integer nmatd, ndex(6)
      integer i, icoupl_iter, id, idl
      integer neqp1, nrhs1, nrhs2, nrhs3, nsizea, nsizea1
      real*8, allocatable :: dumz(:)
      real*8, allocatable :: dumn(:)
      real*8, allocatable :: sto5(:)
      real*8  facr, fdum2, tollr, tolls

c     call thermo for next level (i+neq)
c
      call dpdp(2)
c
c     adjust storage
c
      neqp1=neq+1
      nmatd=nelm(neqp1)-neqp1
      nsizea=36*nmatd
      do i=1,nsizea
         a(i)=0.0
      enddo

      do i=1,neq
         bp(i+nrhs(1))=0.0
         bp(i+nrhs(2))=0.0
         bp(i+nrhs(3))=0.0
         bp(i+nrhs(4))=0.0
         bp(i+nrhs(5))=0.0
         bp(i+nrhs(6))=0.0
      enddo
      nrhs1=nrhs(1)
      nrhs2=nrhs(2)
      nrhs3=nrhs(3)

      do id=1,neq
         nmat(1)=0
         nmat(2)=nmatd
         nmat(3)=nmatd*2
         nmat(4)=nmatd*(7-1)
         nmat(5)=nmatd*(8-1)
         nmat(6)=nmatd*(9-1)
         nmat(7)=nmatd*(13-1)
         nmat(8)=nmatd*(14-1)
         nmat(9)=nmatd*(15-1)
         nrhs(1)=nrhs1
         nrhs(2)=nrhs2
         nrhs(3)=nrhs3
c
c     decide on equation type
c
         if(ico2.gt.0) then
            if(ieos(id).ne.4) then
               call geneqc( id)
            else
               call geneq3( id)
               a(nelmdg(id)+nmat(1))=sx1(id)
               a(nelmdg(id)+nmat(9))=sx1(idl)
               bp(id+nrhs(1))=0.0
               bp(id+nrhs(3))=0.0
            endif
         else if (ico2.eq.0) then
            if(ieos(id).ne.4) then
               call geneq1( id)
            else
               call geneq3( id)
               a(nelmdg(id)+nmat(1))=sx1(id)
               a(nelmdg(id)+nmat(9))=sx1(idl)
               bp(id+nrhs(1))=0.0
               bp(id+nrhs(3))=0.0
            endif
         endif
         idl=id+neq

         nmat(1)=nmatd*(22-1)
         nmat(2)=nmatd*(23-1)
         nmat(3)=nmatd*(24-1)
         nmat(4)=nmatd*(28-1)
         nmat(5)=nmatd*(29-1)
         nmat(6)=nmatd*(30-1)
         nmat(7)=nmatd*(34-1)
         nmat(8)=nmatd*(35-1)
         nmat(9)=nmatd*(36-1)
         nrhs(1)=nrhs(4)
         nrhs(2)=nrhs(5)
         nrhs(3)=nrhs(6)
c
c     decide on equation type(for node idl=id+neq)
c
         if(ico2.gt.0) then
            if(ieos(idl).ne.4) then
               call geneqc(idl)
            else
               call geneq3(idl)
               a(nelmdg(id)+nmat(1))=sx1(id)
               a(nelmdg(id)+nmat(9))=sx1(idl)
               bp(id+nrhs(1))=0.0
               bp(id+nrhs(3))=0.0
            endif
         else if (ico2.eq.0) then
            if(ieos(idl).ne.4) then
               call geneq1(idl)
            else
               call geneq3(idl)
               a(nelmdg(id)+nmat(1))=sx1(idl)
               a(nelmdg(id)+nmat(9))=sx1(idl)
               bp(id+nrhs(1))=0.0
               bp(id+nrhs(3))=0.0
            endif
         endif
      enddo
      do i=1,36
         nmat(i)=nmatd*(i-1)
      enddo

      nrhs(1)=nrhs1
      nrhs(2)=nrhs2
      nrhs(3)=nrhs3

c     call md_modes to complete equations for multiply defined nodes
c
c      if(imdnode.ne.0) call md_nodes(3,0,0)
c
c     now get coupling for influence terms
c
      call dpdp3

      if(islord.ne.0) call switch(nmat,nmatb,islord,6,1,nsizea1)
      if(islord.ne.0) call switchb(bp,nrhs,nrhsb,islord,6,1,neq)

c     normalize the equations
c
c     call mmgetblk ("dumn", "dpdp", ipdumn, 108  , 2, icode)
      allocate(dumn(108))

      call normal_dof(neq,a,bp,nelm,nmat,nrhs,nelmdg
     $     ,ndex,6,dumn(1),dumn(37),dumn(73),0,fdum2)

c     call mmrelblk ("dumn", "dpdp", ipdumn, icode)
      deallocate(dumn)
c
c     return and stop if singular
c
      if(ndex(1).lt.0 ) then
         if (iout .ne. 0) then
            write(iout,*) '   '
            write(iout, 100)
            write(iout,*) '   '
            write(iout,'(i8,3g12.3)')
     &           abs(nmatb(1)),(cord(abs(nmatb(1)),i),i=1,3)
         end if
         if(iptty.gt.0)then
            write(iptty,*) '   '
            write(iptty, 100)
            write(iptty,*) '   '
            write(iptty,'(i8,3g12.3)')
     &           abs(nmatb(1)),(cord(abs(nmatb(1)),i),i=1,3)
         endif
         iad=maxit
         return
      endif
 100  format ('* singular matrix found during normalization *')

c     find residual
c
      fdum=sqrt(fdum2)
      if(fdum.eq.0.0) go to 999
      mink=n
      if(iad.eq.0) then
         f0=max(fdum*epe,tmch)
      endif
      if(fdum1.lt.0.0.and.iad.ne.0) then
         do i=1,neq
            if(abs(bp(i+nrhs(1))).gt.tmch) go to 99
            if(abs(bp(i+nrhs(2))).gt.tmch) go to 99
            if(abs(bp(i+nrhs(3))).gt.tmch) go to 99
            if(abs(bp(i+nrhs(4))).gt.tmch) go to 99
            if(abs(bp(i+nrhs(5))).gt.tmch) go to 99
            if(abs(bp(i+nrhs(6))).gt.tmch) go to 99
         enddo
         fdum=-1.0
         go to 999
 99      continue
         f0=-1.0
      endif
      if(f0.gt.0.0) then
         if(fdum.le.f0.and.iad.ne.0) goto 999
         facr=1.0
         tolls=max(facr*f0,min(g1*fdum,g2*fdum2))
         tollr=tolls*g3
         if(g3*tmch.gt.tollr) tollr=g3*tmch
       else if(f0.le.0.0) then
         tollr=tmch *g3
       endif

c
c     set maximum iterations in solve_new
c
      iter=maxsolve
      call storage_derivatives(1,1)
      allocate(dumz(neq*5*6))
c
c     set maximum recoupling iterations if necesary
c
      if(icoupl.gt.0) then
        icoupl_iter = icoupl
      else if(icoupl.lt.0) then
        icoupl_iter =
     &   max(float(abs(icoupl)),
     &   (float(iad)/float(abs(maxit)))*float(abs(2*icoupl)))
      endif
      if(irdof.eq.0) then
c
c     full solution
c
         if (igauss .gt. 1) then
            call solve_new(neq,a,b,bp,nmat,nb,nrhs,nelm,nop,north,tollr
     *           ,irb,iirb,npvt,gmres,dumz,piv
     *           ,h,c,ss,g,y,iter,iback,6,iptty,maxor,accm)
         else
            call solve_new(neq,a,b,bp,nmat,nmat,nrhs,nelm,nelm,north
     *           ,tollr,irb,iirb,npvt,gmres,dumz,piv
     *           ,h,c,ss,g,y,iter,iback,6,iptty,maxor,accm)
         end if
      else if(irdof.eq.-6) then
c     reduced degree of freedom with full gmres
         if (igauss .gt. 1) then
            call solve_rdof(neq,a,b,bp,nmat,nb,nrhs,nelm,nop,north
     *           ,tollr,irb,iirb,npvt,gmres,dumz,piv
     *           ,h,c,ss,g,y,iter,iback,-6,iptty
     *           ,maxor,icoupl_iter,tollr,overf,accm)
         else
            call solve_rdof(neq,a,b,bp,nmat,nmat,nrhs,nelm,nelm,north
     *           ,tollr,irb,iirb,npvt,gmres,dumz,piv
     *           ,h,c,ss,g,y,iter,iback,-6,iptty
     *           ,maxor,icoupl_iter,tollr,overf,accm)
         end if
      else
c
c     approximate solution
c
         allocate(sto5(neq*6))
         if (igauss .gt. 1) then
            call rdof_new(neq,a,b,bp,nmat,nb,nrhs,nelm,nop,north
     *           ,tollr,irb,iirb,npvt,gmres,dumz,piv
     *           ,h,c,ss,g,y,iter,iback,6,iptty,maxor
     *           ,overf,irdof,icoupl_iter,0,sto5,accm)
         else
            call rdof_new(neq,a,b,bp,nmat,nmat,nrhs,nelm,nelm,north
     *           ,tollr,irb,iirb,npvt,gmres,dumz,piv
     *           ,h,c,ss,g,y,iter,iback,6,iptty,maxor
     *           ,overf,irdof,icoupl_iter,0,sto5,accm)
         end if
         deallocate(sto5)
      endif
      itert=itert+iter
      itotals=itotals+iter
      minkt=minkt+mink
      deallocate(dumz)
      call storage_derivatives(0,1)

 999  continue

      if(islord.ne.0) call switch(nmat,nmatb,islord,6,2,nsizea1)
      if(islord.ne.0) call switchb(bp,nrhs,nrhsb,islord,6,2,neq)

c     extract dpdp solution
c
      call dpdp(4)

      return
      end


program sbcalibrand

  use globals
  use gdal
  use mapio
  use slezanbear
  use geo

  implicit none

  type dataentry
    real(dp) :: lat, lng
    real(dp) :: sky, err
    real(dp) :: model
  end type

  real(dp) :: llatsrc, llngsrc, ulatsrc, ulngsrc
  type(modelpar) :: par
  type(dataentry), dimension(1024), target :: dat_all
  type(dataentry), dimension(:), pointer :: dat
  integer :: ndata, i, j

  character(128), dimension(9) :: fndem

  real(sp), dimension(:,:), allocatable :: mapi, maph
  type(geotransform) :: gti, gth
  integer :: errno
  real(dp) :: sky(4), hobs

  character(*), parameter :: fni = 'SVDNB_npp_20150101-20151231_75N060W_vcm-orm-ntl_v10_c201701311200.avg_rade9.tif'
  character(*), parameter :: datafmt = '(F9.4,1X,F9.4,3X,F5.2,1X,F4.2,3X,F5.2)'

  terrain_attenuation = .false.

  ndata = 0
  open(33, file = 'data.txt', action = 'read')
  do i = 1,size(dat_all)
    read(33, *, iostat = errno) dat_all(i) % lat, dat_all(i) % lng, &
      & dat_all(i) % sky, dat_all(i) % err
    if (errno .ne. 0) exit
    ndata = ndata + 1
  end do
  close(33)

  dat => dat_all(1:ndata)

  llat = minval(dat % lat)
  ulat = maxval(dat % lat)
  llng = minval(dat % lng)
  ulng = maxval(dat % lng)

  fndem(1) = "eudem_dem_5deg_n45e010.tif"
  fndem(2) = "eudem_dem_5deg_n45e015.tif"
  fndem(3) = "eudem_dem_5deg_n45e020.tif"
  fndem(4) = "eudem_dem_5deg_n50e010.tif"
  fndem(5) = "eudem_dem_5deg_n50e015.tif"
  fndem(6) = "eudem_dem_5deg_n50e020.tif"
  fndem(7) = "eudem_dem_5deg_n55e010.tif"
  fndem(8) = "eudem_dem_5deg_n55e015.tif"
  fndem(9) = "eudem_dem_5deg_n55e020.tif"

  write (0,'("dmax = ",F0.2," km")') dmax / 1e3
  call estimate_data_limits(llat, llng, ulat, ulng, dmax * 1.05, &
  &       llatsrc, llngsrc, ulatsrc, ulngsrc)
  print '("data limits = ",F6.2,1X,F7.2)', llatsrc, llngsrc, ulatsrc, ulngsrc

  call GDALAllRegister

  call map_read_section(fni, llatsrc, llngsrc, ulatsrc, ulngsrc, mapi, gti)
  write (0, '("satellite raster size = ", 2I6)') size(mapi,1), size(mapi,2)

  read_dem: block
    integer nox, noy

    call map_gen_size(llatsrc, llngsrc, ulatsrc, ulngsrc, elev_grid_meters, &
    &              nox, noy, gth)

    allocate( maph(nox,noy) )
    write (0,'("dem raster size = ",2I6)') size(maph,1), size(maph,2)

    call map_read_tiles(fndem, maph, gth)
  end block read_dem

  call random_seed()

  printcalib: block
    type(source), dimension(:,:), allocatable :: src
    real :: a(5)
    real(dp) :: err(ndata)

    allocate( src(size(mapi,1), size(mapi,2)) )
    call mksources(mapi, gti, maph, gth, src)

    open(34, file = 'calib.txt', action = 'write')
    write (34,'(A8,A7,A8,A6,A7,A10,A10,A7)') 'SCTR', 'ABS', 'HSCAL', 'SIDE', &
    & 'BG', 'CHISQ', 'DEVITY', 'DEVMAG'

    iterate_parameters: do j = 1,16807
      call random_number(a)

      par % alpha =  M(a(1), 3.0, 24.0) * 1e-6
      par % relabs = M(a(2), 0.00, 12.00)
      par % hscale = M(a(3), 2.0, 12.0) * 1e3
      par % beta =   M(a(4), 0.0, 0.4)
      par % skybg =  mag2ity(M(a(5), 22.1, 21.6))

      !$omp parallel do private(sky,hobs)
      iterate_datpoints: do i = 1, ndata
        call onepoint(par, dat(i) % lat, dat(i) % lng, &
        &       src, maph, gth, sky, hobs)
        dat(i) % model = sky(4)
      end do iterate_datpoints
      !$omp end parallel do

      write (34,'(F8.3,F7.3,F8.1,F6.3,F7.3,ES10.3,ES10.3,F7.4)') &
        & par % alpha * 1e6, par % relabs, &
        & par % hscale, par % beta, (par % skybg) * 1e7, &
        &      sum((mag2ity(dat % sky) - dat % model)**2  / dat % model), &
        & sqrt(sum((mag2ity(dat % sky) - dat % model)**2) / ndata), &
        & sqrt(sum((dat % sky - ity2mag(dat % model))**2) / ndata)
      flush(34)
    end do iterate_parameters

    close(34)

    deallocate(src)
  end block printcalib

  deallocate(mapi, maph)

contains

  elemental real(dp) function m(a, l, u) result(b)
    real, intent(in) :: a
    real, intent(in) :: l, u
    b = l + a * (u - l)
  end function

end program sbcalibrand


      SUBROUTINE COMBIN (PG,ILIST,NLIST)
C
      INTEGER         SYSBUF,PG,NAME(2),HCFLDS,HCFLD,HCCENS,HCCEN,OTPE,
     1                REMFLS,REMFL,MCB(7)
      DIMENSION       ARY(1),ILIST(1),ALPHA(360),LOADN(360),LOADNN(360),
     1                IARY(1),ALPHA1(360),LODC1(7),HEAD(2)
      CHARACTER       UFM*23
      COMMON /XMSSG / UFM
      COMMON /LOADX / LC,N(13),LODC,MASS
      COMMON /BLANK / NROWSP
      COMMON /SYSTEM/ SYSBUF,OTPE,DUM52(52),IPREC
      COMMON /ZZZZZZ/ CORE(1)
      COMMON /LOADS / NLOAD,IPTR
      COMMON /ZNTPKX/ A(4),LL,IEOL,IEOR
      COMMON /PACKX / ITA,ITB,II,JJ,INCUR
      EQUIVALENCE     (CORE(1),IARY(1),ARY(1))
C
C     ALSO COMBINE HCFLD AND REMFL IN MAGNETOSTATIC PROBLEMS
C
      DATA    HCFLDS, HCFLD /304,202/
      DATA    REMFLS, REMFL /305,203/
      DATA    HCCENS, HCCEN /307,204/
      DATA    NAME  / 4HCOMB,4HIN   /
C
C
      ITA = 1
      ITB = IPREC
      II  = 1
C
C     PERFORM CHECKS IN E AND M PROBLEM
C     IN E AND M PROBLEM, REMFLS AND HCFLDS MUST HAVE THE SAME NUMBER
C     OF COLUMNS AS PG
C
      MCB(1) = REMFLS
      CALL RDTRL (MCB)
      NPERMS = 0
      IF (MCB(1) .LE. 0) GO TO 1
      NPERMS = MCB(2)
    1 MCB(1) = HCFLDS
      CALL RDTRL (MCB)
      NHC = 0
      IF (MCB(1) .LE. 0) GO TO 2
      NHC = MCB(2)
    2 IF (NHC .NE. NPERMS) GO TO 300
      IF (NHC .EQ. 0) GO TO 5
      MCB(1) = PG
      CALL RDTRL (MCB)
      IF (NHC .NE. MCB(2)) GO TO 300
    5 CONTINUE
      MCB(1) = HCCENS
      CALL RDTRL (MCB)
      NS = 0
      IF (MCB(1) .LE. 0) GO TO 6
      NS = MCB(2)
    6 IF (NS .NE. NHC) GO TO 300
      JJ    = NROWSP
      INCUR = 1
      LCORE = LC
      IBUF1 = LCORE
      LCORE = LCORE - SYSBUF
      CALL OPEN (*200,LODC,CORE(LCORE+1),1)
      CALL FNAME (LODC,HEAD)
      CALL WRITE (LODC,HEAD,2,1)
      LCORE = LCORE - SYSBUF
      CALL OPEN (*190,PG,CORE(LCORE+1),0)
      CALL MAKMCB (LODC1,LODC,NROWSP,2,IPREC)
      NLJ = IPTR
      NL1 = 0
      DO 160 I = 1,NLOAD
      DO 10  J = 1,NROWSP
   10 CORE(J) = 0.0
      NLJ = NLJ + NL1*2 + 1
      NL1 = IARY(NLJ)
      DO 20 K = 1,NL1
      KK  = NLJ + (K-1)*2 + 1
      LOADN(K) = IARY(KK)
      IF (LOADN(K) .LT. 0) GO TO 150
   20 ALPHA(K) = ARY(KK+1)
      KK = 1
      KL = 0
      DO 60 K = 1,NLIST
      IF (ILIST(K)) 30,60,30
   30 KL = KL + 1
      DO 40 J = 1,NL1
      IF (LOADN(J)-ILIST(K)) 40,50,40
   40 CONTINUE
      GO TO 60
   50 LOADNN(KK) = KL
      ALPHA1(KK) = ALPHA(J)
      KK = KK + 1
   60 CONTINUE
      KK = 1
      DO 140 J = 1,NL1
      INULL = 0
      IF (J .NE. 1) GO TO 70
      CALL SKPREC (PG,1)
   70 CALL INTPK (*120,PG,0,1,0)
   80 IF (LOADNN(J)-KK) 90,100,90
   90 IF (INULL .EQ. 1) GO TO 91
      IF (IEOR  .EQ. 0) CALL SKPREC (PG,1)
   91 CONTINUE
      KK = KK + 1
      INULL = 0
      GO TO 70
  100 IF (INULL .EQ. 1) GO TO 130
      IF (IEOL) 130,110,130
  110 CALL ZNTPKI
      CORE(LL) = CORE(LL) + A(1)*ALPHA1(J)
      GO TO 100
  120 INULL = 1
      GO TO 80
  130 KK = KK + 1
  140 CONTINUE
  150 CALL PACK (CORE,LODC1(1),LODC1)
      CALL REWIND (PG)
  160 CONTINUE
      CALL WRTTRL (LODC1(1))
      CALL CLOSE  (LODC1(1),1)
      CALL CLOSE  (PG,1)
      IF (PG .EQ. HCFLDS) GO TO 170
      IF (PG .EQ. REMFLS) GO TO 180
      IF (PG .EQ. HCCENS) RETURN
C
C     DO MAGNETOSTATIC FIELDS FOR USE IN EMFLD
C
      LODC1(1) = HCFLDS
      CALL RDTRL (LODC1)
C
C     IF HCFLD IS PURGED, SO MUST REMFLS
C
      IF (LODC1(2) .LE. 0) RETURN
      PG   = HCFLDS
      LODC = HCFLD
      NROWSP = 3*NROWSP
      GO TO 5
C
C     DO REMFLS
C
  170 LODC1(1) = REMFLS
      CALL RDTRL (LODC1)
      IF (LODC1(2) .LE. 0) RETURN
      PG   = REMFLS
      LODC = REMFL
      NROWSP = LODC1(3)
      GO TO 5
C
C     HCCENS
C
  180 LODC1(1) = HCCENS
      CALL RDTRL (LODC1)
      IF (LODC1(2).LE.0) RETURN
      PG   = HCCENS
      LODC = HCCEN
      NROWSP = LODC1(3)
      GO TO 5
  190 IP1 = PG
  195 CALL MESAGE (-1,IP1,NAME)
  200 IF (LODC .EQ. HCFLD) RETURN
      IP1 = LODC
      GO TO 195
  300 WRITE  (OTPE,350) UFM
  350 FORMAT (A23,', IN AN E AND M PROBLEM, SCRATCH DATA BLOCKS HCFLDS',
     1       ' AND REMFLS HAVE DIFFERENT NUMBERS OF COLUMNS.', /10X,
     2       ' THIS MAY RESULT FROM SPCFLD AND REMFLU CARDS HAVING THE',
     3       ' SAME LOAD SET ID')
      CALL MESAGE (-61,0,0)
      RETURN
      END


!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
! File  dnopt_wrapper.f90 --- C/C++ wrapper for DNOPT
!
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

module dnopt_wrapper
  use  iso_c_binding
  implicit none

  public

  external :: dnBegin, dnSpec, dnopt, dnoptKernel, dnMem, &
              dnSet, dnSetInt, dnSetReal, &
              dnGet, dnGetInt, dnGetReal, dnGetChar, &
              dnEnd, &
              dnFileOpenRead, dnFileOpenAppend

  public  :: f_dnbegin, f_dnsetprint,       &
             f_dnspec,  f_dnopt,  f_dnker,  f_dnmem, &
             f_dnset,   f_dnseti, f_dnsetr, &
             f_dngetc,  f_dngeti, f_dngetr, &
             f_dnend
  private :: newunit

  !-----------------------------------------------------------------------------

  interface
     ! Interface for user-defined subroutines.

     subroutine ifuncon &
          (modeC, mNCon, nnJac, x, fCon, JCon, ldJ, statusUser, &
           cu, lencu, iu, leniu, ru, lenru)

       integer,          intent(in)    :: mNCon, nnJac, ldJ, statusUser, &
                                          lencu, leniu, lenru
       double precision, intent(in)    :: x(nnJac)
       integer,          intent(inout) :: modeC, iu(leniu)
       double precision, intent(inout) :: ru(lenru)
       character,        intent(inout) :: cu(lencu)*8

       double precision, intent(out)   :: fCon(mNCon), jCon(mNCon,nnJac)
     end subroutine ifuncon

     !--------------------------------------------------------------------------

     subroutine ifunobj &
          (modeF, nnObj, x, fObj, gObj, statusUser, &
           cu, lencu, iu, leniu, ru, lenru)
       integer,          intent(in)    :: nnObj, statusUser, lencu, leniu, lenru
       double precision, intent(in)    :: x(nnObj)
       integer,          intent(inout) :: modeF, iu(leniu)
       double precision, intent(inout) :: ru(lenru)
       character,        intent(inout) :: cu(lencu)*8

       double precision, intent(out)   :: fObj, gObj(nnObj)
     end subroutine ifunobj

     !--------------------------------------------------------------------------

     subroutine ifunhes &
          (modeH, nnH, mNCon, x, fMul, H, ldH, statusUser, &
           cu, lencu, iu, leniu, ru, lenru)

       integer,          intent(in)    :: nnH, mNCon, ldH, statusUser, &
                                          lencu, leniu, lenru
       double precision, intent(in)    :: x(nnH), fMul
       integer,          intent(inout) :: modeH, iu(leniu)
       double precision, intent(inout) :: ru(lenru)
       character,        intent(inout) :: cu(lencu)*8

       double precision, intent(out)   :: H(ldH,*)
     end subroutine ifunhes

     !--------------------------------------------------------------------------

     subroutine dnLog(iAbort, Tags, KTcond,                             &
                      minimize, n, nb, mNCon0, nZ, itn, nMajor, nMinor, &
                      condHz, objAdd, fMerit, penParm, step,            &
                      primalInf, dualInf, maxVi, maxViRel, state,       &
                      scales, bl, bu, fCon, fmul,                       &
                      JQP, ldJQP, x,                                    &
                      cu, lencu, iu, leniu, ru, lenru,                  &
                      cw, lencw, iw, leniw, rw, lenrw)

       logical, intent(in) :: KTcond(2)
       integer, intent(in) :: Tags(7), ldJQP,                                     &
                              lencu, lencw, leniu, leniw, lenru, lenrw,           &
                              minimize, n, nb, mNCon0,                            &
                              nZ, itn, nMajor, nMinor, state(nb),                 &
                              iu(leniu), iw(leniw)
       double precision, intent(in) :: condHz, objAdd, fMerit, penParm(4),        &
                                       maxViRel, maxVi, step, primalInf, dualInf, &
                                       scales(nb), bl(nb), bu(nb), x(nb),         &
                                       fCon(mNCon0), JQP(ldJQP,*), fmul(mNCon0)

       double precision, intent(inout) :: ru(lenru), rw(lenrw)
       character,        intent(inout) :: cu(lencu)*8, cw(lencw)*8

       integer,          intent(out)   :: iAbort

     end subroutine dnLog

     !--------------------------------------------------------------------------

     subroutine dnLogQP &
          (qpProblemType, phase, runInfo, qpProblemTag,         &
           Elastic, GotR, Named, Optimal, nName, Names,         &
           stateDel, jAdd, jDel, printDel, minimize,            &
           n, nactiv, nb, mLCon, nfree, nnH, nonOpt, nZ, nZr,   &
           nlinesP, nlinesS, itn, itQP, jObj, scaleObj, objAdd, &
           objc, objH, nInf, sInf, nInfE, sInfE, wtInf,         &
           condHz, yDel, normgZr, step,                         &
           state, kx, R, ldR, T, ldT, x, wrk1,                  &
           iw, leniw, rw, lenrw)

       logical,   intent(in) :: Elastic, GotR, Named, Optimal
       integer,   intent(in) :: jObj, jAdd, jDel, ldR, ldT, leniw, lenrw,      &
                                minimize, n, nactiv, nb, mLCon, nfree, nnH,    &
                                nInf, nInfE, nlinesP, nlinesS, nName, nonOpt,  &
                                nZ, nZr, itn, itQP,                            &
                                qpProblemType, printDel, stateDel, phase,      &
                                kx(n), state(nb)
       character, intent(in) :: runInfo*6, qpProblemTag*20, Names(nName)*8
       double precision, intent(in) :: condHz, normgZr, sInf, sInfE, wtInf,    &
                                       objAdd, objc, objH, scaleObj, step,     &
                                       yDel, R(ldR,*), T(ldT,*), x(nb)
       integer,          intent(inout) :: iw(leniw)
       double precision, intent(inout) :: wrk1(nb), rw(lenrw)

     end subroutine dnLogQP

     !--------------------------------------------------------------------------

     subroutine dnSTOP &
          (iAbort,                                        &
           KTcond, minimize, mCon0, mCon,                 &
           maxZ, n, nb, mNCon0, mNCon, nnObj0, nnObj, nZ, &
           itn, nMajor, nMinor,                           &
           condHz, ObjAdd, fMerit, penParm, step,         &
           primalInf, dualInf, maxVi, maxViRel, state,    &
           scales, bl, bu, fObj, gObj, fCon, fmul,        &
           JQP, ldJQP, gQ, x, yCon,                       &
           cu, lencu, iu, leniu, ru, lenru,               &
           cw, lencw, iw, leniw, rw, lenrw)

       logical, intent(in) :: KTcond(2)
       integer, intent(in) :: itn, ldJQP,                                   &
                              lencu, lencw, leniu, leniw, lenru, lenrw,     &
                              minimize, mCon0, mCon, maxZ, n, nb,        &
                              mNCon0, mNCon, nnObj0, nnObj, nMajor, nMinor, &
                              nZ, state(nb)
       double precision, intent(in) :: condHz, ObjAdd, fMerit, fObj, penParm(4), &
                                       maxVIRel, maxVi, primalInf, dualInf,      &
                                       step, scales(nb), bl(nb), bu(nb),         &
                                       fCon(mNCon0), fmul(mNCon0), gObj(nnObj0), &
                                       gQ(n), JQP(ldJQP,*), x(nb), yCon(mCon0)

       integer,          intent(inout) :: iu(leniu), iw(leniw)
       double precision, intent(inout) :: ru(lenru), rw(lenrw)
       character,        intent(inout) :: cu(lencu)*8, cw(lencw)*8

       integer,          intent(out)   :: iAbort
     end subroutine dnSTOP

     !--------------------------------------------------------------------------

  end interface

  !-----------------------------------------------------------------------------

  ! Character arrays don't work well with Fortran/C/C++ so have a dummy one here.
  integer, parameter :: lencw = 500
  character*8        :: cw(lencw)

contains

  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  subroutine f_dnbegin(name, len, summOn, iw, leniw, rw, lenrw) &
       bind(C,name="f_dnbegin")

    integer(c_int),    intent(in), value :: len, summOn, leniw, lenrw
    character(c_char), intent(in)        :: name(len)
    integer(c_int),    intent(inout)     :: iw(leniw)
    real(c_double),    intent(inout)     :: rw(lenrw)

    !===========================================================================
    ! Allocate(basic 500) workspace.
    ! Call dnBegin.  If a name is provided, use it as the print file name.
    ! Else assume no print file required(for now).
    !
    ! 07 Jul 2014: First version.
    !===========================================================================
    character(len) :: file
    integer        :: j, iPrt, iSum

    if (len == 0) then
       iPrt = 0
    else
       if (name(1) == c_null_char) then
          iPrt = 0
       else
          file  = ''
          do j = 1, len
             if (name(j) == c_null_char) exit
             file(j:j) = name(j)
          end do
          iPrt = newunit()
          call dnFileOpenAppend(iPrt, trim(file))
       end if
    end if

    if (summOn == 0) then
       iSum = 0
    else
       iSum = 6
    end if

    call dnBegin(iPrt, iSum, cw, lencw, iw, leniw, rw, lenrw)

  end subroutine f_dnbegin

  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  subroutine f_dnsetprint(name, len, iw, leniw, rw, lenrw) &
       bind(C,name="f_dnsetprint")

    integer(c_int),    intent(in), value :: len, leniw, lenrw
    character(c_char), intent(in)        :: name(len)
    integer(c_int),    intent(inout)     :: iw(leniw)
    real(c_double),    intent(inout)     :: rw(lenrw)

    !===========================================================================
    integer        :: Errors, j, iPrt
    character(len) :: prtfile

    prtfile = ''
    do j = 1, len
       if(name(j) == c_null_char) exit
       prtfile(j:j) = name(j)
    end do

    if(prtfile /= '') then
       iPrt = newunit()
       call dnFileOpenAppend(iPrt,trim(prtfile))
       call dnSetInt('Print file', iPrt, 0, 0, Errors, &
                        cw, lencw, iw, leniw, rw, lenrw)
    end if

  end subroutine f_dnsetprint

  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  subroutine f_dnspec(name, len, inform, iw, leniw, rw, lenrw) &
       bind(C,name="f_dnspec")

    integer(c_int),    intent(in), value :: len, leniw, lenrw
    character(c_char), intent(in)        :: name(len)
    integer(c_int),    intent(inout)     :: iw(leniw)
    real(c_double),    intent(inout)     :: rw(lenrw)
    integer(c_int),    intent(out)       :: inform

    !===========================================================================
    integer        :: iSpec, j
    character(len) :: spcfile

    inform  = 0
    iSpec   = 4

    ! Get specs file name.
    spcfile = ''
    do j = 1, len
       if(name(j) == c_null_char) exit
       spcfile(j:j) = name(j)
    end do

    ! If we have a file, try to read it.
    if(spcfile /= '') then
       call dnFileOpenRead(iSpec,trim(spcfile))
       call dnSpec(iSpec, inform, cw, lencw, iw, leniw, rw, lenrw)
       close(iSpec)
    end if

  end subroutine f_dnspec

  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  subroutine f_dnmem(iExit, mLCon, mNCon, n, nnJac, nnObj, iObj, &
                      miniw, minrw, iw, leniw, rw, lenrw) &
                      bind(C,name="f_dnmem")

    integer(c_int), intent(in), value :: mLCon, mNCon, n, nnJac, nnObj, iObj, &
                                         leniw, lenrw
    integer(c_int), intent(inout)     :: iw(leniw)
    real(c_double), intent(inout)     :: rw(lenrw)
    integer(c_int), intent(out)       :: iExit, miniw, minrw

    !===========================================================================
    integer :: mincw

    call dnMem(iExit, mLCon, mnCon, n, nnJac, nnObj, iObj, &
                mincw, miniw, minrw, cw, lencw, iw, leniw, rw, lenrw)

  end subroutine f_dnmem

  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  subroutine f_dnopt(Start, n, nb, mLCon, mNcon,          &
                     nnJac, nnObj, Prob,                  &
                     iObj, ObjAdd, c_funcon, c_funobj,    &
                     state, A, ldA, bl, bu,               &
                     fObj, gObj, fCon, Jcon, ldJ, H, ldH, &
                     objNP, nInf, sInf, x, y,             &
                     INFO, miniw, minrw,                  &
                     iu, leniu, ru, lenru,                &
                     iw, leniw, rw, lenrw)                &
                     bind(C,name="f_dnopt")

    integer(c_int), intent(in), value :: Start, n, nb, mLCon, mNcon, &
                                         nnJac, nnObj,  &
                                         iObj, ldA, ldJ, ldH, &
                                         leniu, lenru, leniw, lenrw
    real(c_double), intent(in), value :: ObjAdd

    real(c_double),    intent(in) :: bl(nb), bu(nb)
    character(c_char), intent(in) :: Prob(*)

    integer(c_int), intent(inout) :: nInf, state(nb)
    real(c_double), intent(inout) :: sInf, A(ldA,*), Jcon(ldJ,*), H(ldH,*), &
                                     x(nb), y(nb)
    integer(c_int), intent(inout) :: iw(leniw), iu(leniu)
    real(c_double), intent(inout) :: rw(lenrw), ru(lenru)

    integer(c_int), intent(out)   :: INFO, miniw, minrw
    real(c_double), intent(out)   :: fObj, gObj(n), fCon(ldJ), ObjNP
    type(c_funptr), value         :: c_funcon, c_funobj

    !===========================================================================
    integer      :: j, mincw, nName
    character(8) :: pname, Names(1)

    procedure(ifuncon), pointer :: funcon
    procedure(ifunobj), pointer :: funobj

    nName = 1

    call c_f_procpointer(c_funcon, funcon)
    call c_f_procpointer(c_funobj, funobj)

    pname  = ''
    do j = 1, 8
       if(Prob(j) == c_null_char) exit
       pname(j:j) = Prob(j)
    end do

    call dnopt(Start, n, mLCon, mNCon, nnJac, nnObj, &
               pname, Names, nName, iObj, ObjAdd,    &
               funcon, funobj,                       &
               state, A, ldA, bl, bu,                &
               fObj, gObj, fCon, Jcon, ldJ, H, ldH,  &
               ObjNP, nInf, sInf, x, y,              &
               INFO, mincw, miniw, minrw,            &
               cw, lencw, iu, leniu, ru, lenru,      &
               cw, lencw, iw, leniw, rw, lenrw)

  end subroutine f_dnopt

  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  subroutine f_dnopth(Start, n, nb, mLCon, mNcon,          &
                      nnJac, nnObj, Prob,                  &
                      iObj, ObjAdd,                        &
                      c_funcon, c_funobj, c_funhes,        &
                      state, A, ldA, bl, bu,               &
                      fObj, gObj, fCon, Jcon, ldJ, H, ldH, &
                      objNP, nInf, sInf, x, y,             &
                      INFO, miniw, minrw,                  &
                      iu, leniu, ru, lenru,                &
                      iw, leniw, rw, lenrw)                &
                      bind(C,name="f_dnopth")

    integer(c_int), intent(in), value :: Start, n, nb, mLCon, mNcon, &
                                         nnJac, nnObj,  &
                                         iObj, ldA, ldJ, ldH, &
                                         leniu, lenru, leniw, lenrw
    real(c_double), intent(in), value :: ObjAdd

    real(c_double),    intent(in) :: bl(nb), bu(nb)
    character(c_char), intent(in) :: Prob(*)

    integer(c_int), intent(inout) :: nInf, state(nb)
    real(c_double), intent(inout) :: sInf, A(ldA,*), Jcon(ldJ,*), H(ldH,*), &
                                     x(nb), y(nb)
    integer(c_int), intent(inout) :: iw(leniw), iu(leniu)
    real(c_double), intent(inout) :: rw(lenrw), ru(lenru)

    integer(c_int), intent(out)   :: INFO, miniw, minrw
    real(c_double), intent(out)   :: fObj, gObj(n), fCon(ldJ), ObjNP
    type(c_funptr), value         :: c_funcon, c_funobj, c_funhes

    !===========================================================================
    integer      :: j, mincw, nName
    character(8) :: pname, Names(1)

    procedure(ifuncon), pointer :: funcon
    procedure(ifunobj), pointer :: funobj
    procedure(ifunhes), pointer :: funhes

    nName = 1

    call c_f_procpointer(c_funcon, funcon)
    call c_f_procpointer(c_funobj, funobj)
    call c_f_procpointer(c_funhes, funhes)

    pname  = ''
    do j = 1, 8
       if(Prob(j) == c_null_char) exit
       pname(j:j) = Prob(j)
    end do

    call dnopth(Start, n, mLCon, mNCon, nnJac, nnObj, &
                pname, Names, nName, iObj, ObjAdd,    &
                funcon, funobj, funhes,               &
                state, A, ldA, bl, bu,                &
                fObj, gObj, fCon, Jcon, ldJ, H, ldH,  &
                ObjNP, nInf, sInf, x, y,              &
                INFO, mincw, miniw, minrw,            &
                cw, lencw, iu, leniu, ru, lenru,      &
                cw, lencw, iw, leniw, rw, lenrw)

  end subroutine f_dnopth

  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  subroutine f_dnker(Start, n, nb, mLCon, mNcon, nnJac, nnObj, &
                     Prob, iObj, ObjAdd,                       &
                     c_funcon, c_funobj, c_funhes,             &
                     c_dnLog, c_dnLogQP, c_dnSTOP,             &
                     state, A, ldA, bl, bu,                    &
                     Jcon, ldJ, H, ldH,                        &
                     objNP, nInf, sInf, x, y,                  &
                     INFO, miniw, minrw,                       &
                     iu, leniu, ru, lenru,                     &
                     iw, leniw, rw, lenrw)                     &
                     bind(C,name="f_dnker")

    integer(c_int), intent(in), value :: Start, n, nb, &
                                         mLCon, mNcon, nnJac, nnObj, &
                                         iObj, ldA, ldJ, ldH, &
                                         leniu, lenru, leniw, lenrw
    real(c_double), intent(in), value :: ObjAdd
    real(c_double),    intent(in) :: bl(nb), bu(nb)
    character(c_char), intent(in) :: Prob(*)

    integer(c_int), intent(inout) :: nInf, state(nb)
    real(c_double), intent(inout) :: sInf, A(ldA,n), Jcon(ldJ,n), H(ldH,*), &
                                     x(nb), y(nb)
    integer(c_int), intent(inout) :: iw(leniw), iu(leniu)
    real(c_double), intent(inout) :: rw(lenrw), ru(lenru)

    integer(c_int), intent(out)   :: INFO, miniw, minrw
    real(c_double), intent(out)   :: ObjNP
    type(c_funptr), value         :: c_funcon, c_funobj, c_funhes, &
                                     c_dnLog, c_dnLogQP, c_dnSTOP

    !===========================================================================
    integer           :: j, mincw, nName
    double precision  :: fObj
    double precision, allocatable :: gObj(:), fCon(:)
    character(8) :: pname, Names(1)

    procedure(ifuncon),  pointer :: funcon
    procedure(ifunobj),  pointer :: funobj
    procedure(ifunhes),  pointer :: funhes

    procedure(dnSTOP),   pointer :: mySTOP
    procedure(dnLog),    pointer :: myLog
    procedure(dnLogQP),  pointer :: myLogQP

    external :: dnoptInterfaceB, dnfunHxNull

    nName = 1

    funcon  => null()
    funobj  => null()
    funhes  => null()
    mySTOP  => null()
    myLog   => null()
    myLogQP => null()

    call c_f_procpointer(c_funcon,  funcon)
    call c_f_procpointer(c_funobj,  funobj)
    call c_f_procpointer(c_funhes,  funhes)
    call c_f_procpointer(c_dnLog,   myLog )
    call c_f_procpointer(c_dnLogQP, myLogQP)
    call c_f_procpointer(c_dnSTOP,  mySTOP)

    if(.not. associated(funhes))  funhes  => dnfunHess
    if(.not. associated(myLog) )  myLog   => dnLog
    if(.not. associated(myLogQP)) myLogQP => dnLogQP
    if(.not. associated(mySTOP))  mySTOP  => dnSTOP

    pname  = ''
    do j = 1, 8
       if(Prob(j) == c_null_char) exit
       pname(j:j) = Prob(j)
    end do

    allocate(gObj(n), fCon(ldJ))
    gObj(1:n)   = 0.0
    fCon(1:ldJ) = 0.0
    fObj        = 0.0

    call dnoptKernel &
         (Start, 'DNOPT   ',                   &
          n, nb, mLCon, mNCon, nnJac, nnObj,   &
          pname, Names, nName,                 &
          funcon, funobj, funhes, dnfunHxNull, &
          dnoptInterfaceB,                     &
          myLog, myLogQP, mySTOP,              &
          state, A, ldA, bl, bu, iObj, ObjAdd, &
          fObj, gObj, fCon, Jcon, ldJ, H, ldH, &
          ObjNP, nInf, sInf, x, y,             &
          INFO, mincw, miniw, minrw,           &
          cw, lencw, iu, leniu, ru, lenru,     &
          cw, lencw, iw, leniw, rw, lenrw)

    deallocate(gObj, fCon)

  end subroutine f_dnker

  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  subroutine f_dnset(option, len, Errors, iw, leniw, rw, lenrw) &
       bind(C,name="f_dnset")
    integer(c_int),    intent(in), value :: len, leniw, lenrw
    character(c_char), intent(in)        :: option(len)
    integer(c_int),    intent(inout)     :: iw(leniw)
    real(c_double),    intent(inout)     :: rw(lenrw)
    integer(c_int),    intent(out)       :: Errors

    !===========================================================================
    character(len) :: buffer
    integer        :: j

    errors = 0
    buffer = ''
    do j = 1, len
       if(option(j) == c_null_char) exit
       buffer(j:j) = option(j)
    end do

    call dnSet(buffer, 0, 0, Errors, cw, lencw, iw, leniw, rw, lenrw)

  end subroutine f_dnset

  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  subroutine f_dnseti(option, len, ivalue, Errors, iw, leniw, rw, lenrw) &
       bind(C,name="f_dnseti")
    integer(c_int),    intent(in), value :: len, ivalue, leniw, lenrw
    character(c_char), intent(in)        :: option(len)
    integer(c_int),    intent(inout)     :: iw(leniw)
    real(c_double),    intent(inout)     :: rw(lenrw)
    integer(c_int),    intent(out)       :: Errors

    !===========================================================================
    character(len) :: buffer
    integer        :: j

    errors = 0
    buffer = ''
    do j = 1, len
       if(option(j) == c_null_char) exit
       buffer(j:j) = option(j)
    end do

    call dnSetInt(buffer, ivalue, 0, 0, Errors, &
                    cw, lencw, iw, leniw, rw, lenrw)

  end subroutine f_dnseti

  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  subroutine f_dnsetr(option, len, rvalue, Errors, iw, leniw, rw, lenrw) &
       bind(C,name="f_dnsetr")
    integer(c_int),    intent(in), value :: len, leniw, lenrw
    real(c_double),    intent(in), value :: rvalue
    character(c_char), intent(in)        :: option(len)
    integer(c_int),    intent(inout)     :: iw(leniw)
    real(c_double),    intent(inout)     :: rw(lenrw)
    integer(c_int),    intent(out)       :: Errors

    !===========================================================================
    character(len) :: buffer
    integer        :: j

    errors = 0
    buffer = ''

    do j = 1, len
       if(option(j) == c_null_char) exit
       buffer(j:j) = option(j)
    end do

    call dnSetReal(buffer, rvalue, 0, 0, Errors, &
                    cw, lencw, iw, leniw, rw, lenrw)

  end subroutine f_dnsetr

  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  subroutine f_dngetc(option, lin, cvalue, lout, Errors, &
                       iw, leniw, rw, lenrw) bind(C,name="f_dngetc")
    integer(c_int),    intent(in), value :: lin, lout, leniw, lenrw
    character(c_char), intent(in)        :: option(lin)
    character(c_char), intent(inout)     :: cvalue(lout)
    integer(c_int),    intent(inout)     :: iw(leniw)
    real(c_double),    intent(inout)     :: rw(lenrw)
    integer(c_int),    intent(out)       :: Errors

    !===========================================================================
    character(lin)  :: buffer
    character(lout) :: buffout
    integer         :: j

    errors = 0
    buffer = ''
    do j = 1, lin
       if(option(j) == c_null_char) exit
       buffer(j:j) = option(j)
    end do

    call dnGetChar(buffer, buffout, Errors, cw, lencw, iw, leniw, rw, lenrw)

    do j = 1, lout-1
       cvalue(j) = buffout(j:j)
    end do
    cvalue(lout) = c_null_char

  end subroutine f_dngetc

  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  subroutine f_dngeti(option, len, ivalue, Errors, iw, leniw, rw, lenrw) &
       bind(C,name="f_dngeti")
    integer(c_int),    intent(in), value :: len, leniw, lenrw
    character(c_char), intent(in)        :: option(len)
    integer(c_int),    intent(inout)     :: iw(leniw)
    real(c_double),    intent(inout)     :: rw(lenrw)
    integer(c_int),    intent(out)       :: ivalue, Errors

    !===========================================================================
    character(len) :: buffer
    integer        :: j

    errors = 0
    buffer = ''
    do j = 1, len
       if(option(j) == c_null_char) exit
       buffer(j:j) = option(j)
    end do

    call dnGetInt(buffer, ivalue, Errors, cw, lencw, iw, leniw, rw, lenrw)

  end subroutine f_dngeti

  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  subroutine f_dngetr(option, len, rvalue, Errors, iw, leniw, rw, lenrw) &
       bind(C,name="f_dngetr")
    integer(c_int),    intent(in), value :: len, leniw, lenrw
    character(c_char), intent(in)        :: option(len)
    integer(c_int),    intent(inout)     :: iw(leniw)
    real(c_double),    intent(inout)     :: rw(lenrw)
    integer(c_int),    intent(out)       :: Errors
    real(c_double),    intent(out)       :: rvalue

    !===========================================================================
    character(len) :: buffer
    integer        :: j

    errors = 0
    buffer = ''
    do j = 1, len
       if(option(j) == c_null_char) exit
       buffer(j:j) = option(j)
    end do

    call dnGetReal(buffer, rvalue, Errors, cw, lencw, iw, leniw, rw, lenrw)

  end subroutine f_dngetr

  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  subroutine f_dnend(iw, leniw, rw, lenrw) bind(C,name="f_dnend")
    integer(c_int),    intent(in), value :: leniw, lenrw
    integer(c_int),    intent(inout)     :: iw(leniw)
    real(c_double),    intent(inout)     :: rw(lenrw)

    !===========================================================================
    integer :: iPrint, iSumm

    iPrint = iw(12)
    iSumm  = iw(13)

    close(iPrint)   ! print file
    if (iSumm /= 6) close(iSumm)   ! summary file

    call dnEnd(iPrint, iSumm, cw, lencw, iw, leniw, rw, lenrw)

  end subroutine f_dnend

  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  integer function newunit()
    !===========================================================================
    ! Return a new unit number.
    ! The new F2008 feature is not backwards compatible because it can return
    ! units outside of the range (0,99).
    !
    ! 21 Feb 2017: Current version
    !===========================================================================
    integer, parameter :: unit_min = 10, unit_max = 1000
    logical :: opened
    integer :: j

    newunit = -1
    do j = unit_min, unit_max
       inquire(unit=j,opened=opened)
       if (.not. opened) then
          newunit = j
          exit
       end if
    end do

  end function newunit

  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  subroutine dnfunHess &
       (modeH, nnH, mNCon, x, fMul, H, ldH, statusUser, &
        cu, lencu, iu, leniu, ru, lenru)
    !===========================================================================
    ! Dummy funhes routine for DNOPT.
    !===========================================================================
    integer,          intent(in)    :: nnH, mNCon, ldH, statusUser, &
                                       lencu, leniu, lenru
    double precision, intent(in)    :: x(nnH), fMul
    integer,          intent(inout) :: modeH, iu(leniu)
    double precision, intent(inout) :: ru(lenru)
    character,        intent(inout) :: cu(lencu)*8

    double precision, intent(out)   :: H(ldH,*)

    ! Dummy funhes routine

  end subroutine dnfunHess

  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

end module dnopt_wrapper


*----------------------------------------------------------------------*
      subroutine contr_blk1blk2_wmaps_c(xfac,            !prefactor
     &     xop1op2,xop1,xop2,                     !buffers: res,op1,op2
     &     tra_op1,tra_op2,tra_op1op2,
     &     ncblk_op1,nablk_op1,ncblk_ex1,nablk_ex1,
     &     ncblk_op2,nablk_op2,ncblk_ex2,nablk_ex2,
     &     ncblk_cnt,nablk_cnt,ncblk_op1op2,nablk_op1op2,
     &     hpvxop1c, hpvxop1a,
     &     hpvxop2c, hpvxop2a,
     &     hpvxop1op2c, hpvxop1op2a,
     &     lstrop1, lstrop2, lstrop1op2,
     &     lstr_ex1, lstr_ex2, lstr_cnt,
     &     map_info_12c, map_info_12a,
     &     map_info_1c, map_info_1a,
     &     map_info_2c, map_info_2a,
     &     map_ex1ex2c, map_ex1ex2a,
     &     map_ex1cntc, map_ex1cnta,
     &     map_ex2cntc, map_ex2cnta
     &     )
*----------------------------------------------------------------------*
*     inner contraction routine, generation 2
*     - testing maps
*     - version c: interfaced to more general intermediates
*                  ("ngastp" can be larger than 4)
*----------------------------------------------------------------------*

      implicit none

      include 'opdim.h'
      include 'stdunit.h'
      include 'def_orbinf.h'
      include 'def_graph.h'
      include 'def_strinf.h'
      include 'hpvxseq.h'

      integer, parameter ::
     &     ntest = 000

      ! ngastp_op1op2a: number of non-zero entries in A occ of Op1Op2
      ! etc. for op1, op2
      ! lstrop1op2a(ngastp_op1op2a): # of strings
      ! etc.
      ! iocc_op1op2: occupation
      ! nstr_ex1/ex2/cnt,a/c: # strings
      ! map_ex1ex2a/c  mapping ex1*ex2->op1op2
      ! etc. for ex1cnt ex2cnt
      logical, intent(in) ::
     &     tra_op1, tra_op2, tra_op1op2
      integer, intent(in) ::
     &     ncblk_op1,nablk_op1,ncblk_ex1,nablk_ex1,
     &     ncblk_op2,nablk_op2,ncblk_ex2,nablk_ex2,
     &     ncblk_cnt,nablk_cnt,ncblk_op1op2,nablk_op1op2,
     &     lstrop1(*), lstrop2(*), lstrop1op2(*),
     &     hpvxop1a(*), hpvxop2a(*), hpvxop1op2a(*),
     &     hpvxop1c(*), hpvxop2c(*), hpvxop1op2c(*),
     &     lstr_ex1(*), lstr_ex2(*), lstr_cnt(*),
     &     map_info_12c(*), map_info_12a(*),
     &     map_info_1c(*), map_info_1a(*),
     &     map_info_2c(*), map_info_2a(*),
     &     map_ex1ex2a(*), map_ex1ex2c(*),
     &     map_ex1cnta(*), map_ex1cntc(*),
     &     map_ex2cnta(*), map_ex2cntc(*)
      real(8), intent(in) ::
     &     xop1(*), xop2(*), xfac
      real(8), intent(inout) ::
     &     xop1op2(*)

      integer ::
     &     ielmap, ielmap2,
     &     idxop1op2a(nablk_op1op2), idxop1op2c(ncblk_op1op2)
      integer ::
     &     ireo_ex1a1(nablk_ex1),   ireo_ex1c1(ncblk_ex1),
     &     ireo_ex1a12(nablk_ex1),  ireo_ex1c12(ncblk_ex1),
     &     ireo_ex2a2(nablk_ex2),   ireo_ex2c2(ncblk_ex2),
     &     ireo_ex2a12(nablk_ex2),  ireo_ex2c12(ncblk_ex2),
     &     ireo_cnta1(nablk_cnt),   ireo_cntc1(ncblk_cnt),
     &     ireo_cnta2(nablk_cnt),   ireo_cntc2(ncblk_cnt)
      integer ::
     &     istr_ex1a1(nablk_op1),   istr_ex1c1(ncblk_op1),
     &     istr_ex1a12(nablk_op1op2),  istr_ex1c12(ncblk_op1op2),
     &     istr_ex2a2(nablk_op2),   istr_ex2c2(ncblk_op2),
     &     istr_ex2a12(nablk_op1op2),  istr_ex2c12(ncblk_op1op2),
     &     istr_cnta1(nablk_op1),   istr_cntc1(ncblk_op1),
     &     istr_cnta2(ncblk_op2),   istr_cntc2(nablk_op2)
      integer ::
     &     nstr_ex1a1(nablk_op1),   nstr_ex1c1(ncblk_op1),
     &     nstr_ex1a12(nablk_op1op2),  nstr_ex1c12(ncblk_op1op2),
     &     nstr_ex2a2(nablk_op2),   nstr_ex2c2(ncblk_op2),
     &     nstr_ex2a12(nablk_op1op2),  nstr_ex2c12(ncblk_op1op2),
     &     nstr_cnta1(nablk_op1),   nstr_cntc1(ncblk_op1),
     &     nstr_cnta2(ncblk_op2),   nstr_cntc2(nablk_op2),
     &     nstr_ex1ex2a(nablk_op1op2), nstr_ex1ex2c(ncblk_op1op2),
     &     nstr_ex1cnta(nablk_op1), nstr_ex1cntc(ncblk_op1),
     &     nstr_ex2cnta(nablk_op2), nstr_ex2cntc(ncblk_op2)
      integer ::
     &     ldim_op1a(nablk_op1), ldim_op1c(ncblk_op1),
     &     ldim_op2a(nablk_op2), ldim_op2c(ncblk_op2),
     &     ldim_op1op2a(nablk_op1op2), ldim_op1op2c(ncblk_op1op2)
      integer ::
     &     ioff, istr1, istr2, idx1, idx2, idx,
     &     ngastp_op1op2a, ngastp_op1op2c,
     &     ngastp_op1a,    ngastp_op1c,
     &     ngastp_op2a,    ngastp_op2c,
     &     nstr_ex1a_tot, nstr_ex1c_tot,
     &     nstr_ex2a_tot, nstr_ex2c_tot,
     &     nstr_cnta_tot, nstr_cntc_tot,
     &     isgnra, isgnrc, isgnr, isgnop1a, isgnop1c,
     &     isgnop2a, isgnop2c, isgn0, idxop1, idxop2, idxop1op2,
     &     idx0op1,idx0op2,
     &     istr_ex1a, istr_ex1c, istr_ex2a, istr_ex2c,
     &     istr_cnta, istr_cntc, icmp
      real(8) ::
     &     sgn

      integer, external ::
     &     idx_str_blk3, ielprd
c dbg
c      integer lenop1, lenop2, lenop12
c
c      lenop1  = ielprd(lstrop1,ncblk_op1+nablk_op1)
c      lenop2  = ielprd(lstrop2,ncblk_op2+nablk_op2)
c      lenop12 = ielprd(lstrop1op2,ncblk_op1op2+nablk_op1op2)
c      print *,'lenop12: ',lenop12
c dbg

      nstr_ex1c_tot = ielprd(lstr_ex1,ncblk_ex1)
      nstr_ex1a_tot = ielprd(lstr_ex1(ncblk_ex1+1),nablk_ex1)
      nstr_ex2c_tot = ielprd(lstr_ex2,ncblk_ex2)
      nstr_ex2a_tot = ielprd(lstr_ex2(ncblk_ex2+1),nablk_ex2)
      nstr_cntc_tot = ielprd(lstr_cnt,ncblk_cnt)
      nstr_cnta_tot = ielprd(lstr_cnt(ncblk_cnt+1),nablk_cnt)

      ngastp_op1c = ncblk_op1
      ngastp_op1a = nablk_op1
      ngastp_op2c = ncblk_op2
      ngastp_op2a = nablk_op2
      ngastp_op1op2c = ncblk_op1op2
      ngastp_op1op2a = nablk_op1op2

      ! C: ex1,ex2
      call set_strmapdim_c2(nstr_ex1ex2c,nstr_ex1c12,nstr_ex2c12,
     &                   ireo_ex1c12,ireo_ex2c12,
     &                   ngastp_op1op2c,
     &                   lstr_ex1,lstr_ex2,map_info_12c)
      ! A: ex2,ex1
      call set_strmapdim_c2(nstr_ex1ex2a,nstr_ex2a12,nstr_ex1a12,
     &                   ireo_ex2a12,ireo_ex1a12,
     &                   ngastp_op1op2a,
     &                   lstr_ex2(ncblk_ex2+1),
     &                    lstr_ex1(ncblk_ex1+1),map_info_12a)
      call set_strmapdim_c2(nstr_ex1cntc,nstr_cntc1,nstr_ex1c1,
     &                   ireo_cntc1,ireo_ex1c1,
     &                   ngastp_op1c,
     &                   lstr_cnt,lstr_ex1,map_info_1c)
      call set_strmapdim_c2(nstr_ex1cnta,nstr_cnta1,nstr_ex1a1,
     &                   ireo_cnta1,ireo_ex1a1,
     &                   ngastp_op1a,
     &                   lstr_cnt(ncblk_cnt+1),
     &                     lstr_ex1(ncblk_ex1+1),map_info_1a)
      call set_strmapdim_c2(nstr_ex2cntc,nstr_cnta2,nstr_ex2c2,
     &                   ireo_cnta2,ireo_ex2c2,
     &                   ngastp_op2c,
     &                   lstr_cnt(ncblk_cnt+1),lstr_ex2,map_info_2c)
      call set_strmapdim_c2(nstr_ex2cnta,nstr_cntc2,nstr_ex2a2,
     &                   ireo_cntc2,ireo_ex2a2,
     &                   ngastp_op2a,
     &                   lstr_cnt,lstr_ex2(ncblk_ex2+1),map_info_2a)

      call set_op_ldim_c(ldim_op1c,ldim_op1a,
     &                   hpvxop1c,hpvxop1a,
     &                   lstrop1,ncblk_op1,nablk_op1,tra_op1)
      call set_op_ldim_c(ldim_op2c,ldim_op2a,
     &                   hpvxop2c,hpvxop2a,
     &                   lstrop2,ncblk_op2,nablk_op2,tra_op2)
      call set_op_ldim_c(ldim_op1op2c,ldim_op1op2a,
     &                   hpvxop1op2c,hpvxop1op2a,
     &                   lstrop1op2,ncblk_op1op2,nablk_op1op2,
     &                                                 tra_op1op2)

      if (ntest.ge.100) then
        call write_title(lulog,wst_dbg_subr,
     &       'News from contr_op1op2_wmaps_c')
      end if

      ! loop over external A strings of operator 1
      ex1a: do istr_ex1a = 1, nstr_ex1a_tot

        ! break down into components
        istr_ex1a12(1:nablk_op1op2) = 1
        istr_ex1a1 (1:nablk_op1   ) = 1
        istr1 = istr_ex1a-1
        do icmp = 1, nablk_ex1
          idx1 = mod(istr1,lstr_ex1(ncblk_ex1+icmp))+1
          istr_ex1a12(ireo_ex1a12(icmp)) = idx1
          istr_ex1a1 (ireo_ex1a1 (icmp)) = idx1
          istr1 = istr1/lstr_ex1(ncblk_ex1+icmp)
        end do

        ! loop over external A strings of operator 2
        ex2a: do istr_ex2a = 1, nstr_ex2a_tot

          ! break down into components
          istr_ex2a12(1:nablk_op1op2) = 1
          istr_ex2a2 (1:nablk_op2   ) = 1
          istr1 = istr_ex2a-1
          do icmp = 1, nablk_ex2
            idx1 = mod(istr1,lstr_ex2(ncblk_ex2+icmp))+1
            istr_ex2a12(ireo_ex2a12(icmp)) = idx1
            istr_ex2a2 (ireo_ex2a2 (icmp)) = idx1
            istr1 = istr1/lstr_ex2(ncblk_ex2+icmp)
          end do

          ioff = 0
          isgnra = 1
          ! get sign and idxop1op2a
          do icmp = 1, ngastp_op1op2a
            idx1 = istr_ex1a12(icmp)
            idx2 = istr_ex2a12(icmp)
            idx  = (idx1-1)*nstr_ex2a12(icmp)+idx2
            ielmap = map_ex1ex2a(ioff+idx)
            if (ielmap.eq.0) cycle ex2a
            isgnra = isgnra*sign(1,ielmap)
            idxop1op2a(icmp) = abs(ielmap)-1
            ioff = ioff + nstr_ex1ex2a(icmp)
          end do

          ! loop over external C strings of operator 1
          ex1c: do istr_ex1c = 1, nstr_ex1c_tot

            ! break down into components
            istr_ex1c12(1:ncblk_op1op2) = 1
            istr_ex1c1 (1:ncblk_op1   ) = 1
            istr1 = istr_ex1c-1
            do icmp = 1, ncblk_ex1
              idx1 = mod(istr1,lstr_ex1(icmp))+1
              istr_ex1c12(ireo_ex1c12(icmp)) = idx1
              istr_ex1c1 (ireo_ex1c1 (icmp)) = idx1
              istr1 = istr1/lstr_ex1(icmp)
            end do

            ! loop over external C strings of operator 2
            ex2c: do istr_ex2c = 1, nstr_ex2c_tot

              ! break down into components
              istr_ex2c12(1:ncblk_op1op2) = 1
              istr_ex2c2 (1:ncblk_op2   ) = 1
              istr1 = istr_ex2c-1
              do icmp = 1, ncblk_ex2
                idx1 = mod(istr1,lstr_ex2(icmp))+1
                istr_ex2c12(ireo_ex2c12(icmp)) = idx1
                istr_ex2c2 (ireo_ex2c2 (icmp)) = idx1
                istr1 = istr1/lstr_ex2(icmp)
              end do

              ioff = 0
              isgnrc = 1
              ! get sign and idxop1op2c
              do icmp = 1, ngastp_op1op2c
                idx1 = istr_ex2c12(icmp)
                idx2 = istr_ex1c12(icmp)
                idx  = (idx1-1)*nstr_ex1c12(icmp)+idx2
                ielmap = map_ex1ex2c(ioff+idx)
                if (ielmap.eq.0) cycle ex2c
                isgnrc = isgnrc*sign(1,ielmap)
                idxop1op2c(icmp) = abs(ielmap)-1
                ioff = ioff + nstr_ex1ex2c(icmp)
              end do

              isgnr = isgnrc*isgnra

              idxop1op2 = idx_str_blk3(idxop1op2c,idxop1op2a,
     &                                 ldim_op1op2c,ldim_op1op2a,
     &                                 ngastp_op1op2c,ngastp_op1op2a)
c dbg
c                  if (idxop1op2.lt.1) stop 'range12-l'
c                  if (idxop1op2.gt.lenop12) then
c                  if (lenop12.eq.2) then
c                    print *,'-->',idxop1op2
c                    print *,'ngastp:',ngastp_op1op2c,ngastp_op1op2a
c                    print *,idxop1op2a
c                    print *,ldim_op1op2a
c                    print *,idxop1op2c
c                    print *,ldim_op1op2c
c                    stop 'range12-h'
c                  end if
c dbg

              ! loop over contraction A string
              cnta: do istr_cnta = 1, nstr_cnta_tot

                ! break down into components
                istr_cnta1 (1:nablk_op1) = 1
                istr_cnta2 (1:ncblk_op2) = 1
                istr1 = istr_cnta-1
                do icmp = 1, nablk_cnt
                  idx1 = mod(istr1,lstr_cnt(ncblk_cnt+icmp))+1
                  istr_cnta1(ireo_cnta1(icmp)) = idx1
                  istr_cnta2(ireo_cnta2(icmp)) = idx1
                  istr1 = istr1/lstr_cnt(ncblk_cnt+icmp)
                end do

                ioff = 0
                isgnop1a = 1
                idx0op1 = 1
                ! get sign and idxop1a
                do icmp = 1, ngastp_op1a
                  idx1 = istr_ex1a1(icmp)
                  idx2 = istr_cnta1(icmp)
                  idx  = (idx1-1)*nstr_cnta1(icmp)+idx2
                  ielmap = map_ex1cnta(ioff+idx)
                  if (ielmap.eq.0) cycle cnta
                  isgnop1a = isgnop1a*sign(1,ielmap)
                  idx0op1 = idx0op1+(abs(ielmap)-1)*ldim_op1a(icmp)
                  ioff = ioff + nstr_ex1cnta(icmp)
                end do

                ioff = 0
                isgnop2c = 1
                idx0op2 = 1
                ! get sign and idxop2c
                do icmp = 1, ngastp_op2c
                  idx1 = istr_ex2c2(icmp)
                  idx2 = istr_cnta2(icmp)
                  idx  = (idx1-1)*nstr_cnta2(icmp)+idx2
                  ielmap = map_ex2cntc(ioff+idx)
                  if (ielmap.eq.0) cycle cnta
                  isgnop2c = isgnop2c*sign(1,ielmap)
                  idx0op2 = idx0op2+(abs(ielmap)-1)*ldim_op2c(icmp)
                  ioff = ioff + nstr_ex2cntc(icmp)
                end do

                isgn0 = isgnr*isgnop1a*isgnop2c

                ! loop over contraction C string
                cntc: do istr_cntc = 1, nstr_cntc_tot

                  ! break down into components
                  istr_cntc1 (1:ncblk_op1) = 1
                  istr_cntc2 (1:nablk_op2) = 1
                  istr1 = istr_cntc-1
                  do icmp = 1, ncblk_cnt
                    idx1 = mod(istr1,lstr_cnt(icmp))+1
                    istr_cntc1(ireo_cntc1(icmp)) = idx1
                    istr_cntc2(ireo_cntc2(icmp)) = idx1
                    istr1 = istr1/lstr_cnt(icmp)
                  end do

                  ioff = 0
                  isgnop1c = 1
                  idxop1 = idx0op1
                  ! get sign and idxop1c
                  do icmp = 1, ngastp_op1c
                    idx1 = istr_ex1c1(icmp)
                    idx2 = istr_cntc1(icmp)
                    idx  = (idx1-1)*nstr_cntc1(icmp)+idx2
                    ielmap = map_ex1cntc(ioff+idx)
                    if (ielmap.eq.0) cycle cntc
                    isgnop1c = isgnop1c*sign(1,ielmap)
                    idxop1 = idxop1+(abs(ielmap)-1)*ldim_op1c(icmp)
                    ioff = ioff + nstr_ex1cntc(icmp)
                  end do

                  ioff = 0
                  isgnop2a = 1
                  idxop2 = idx0op2
                  ! get sign and idxop2a
                  do icmp = 1, ngastp_op2a
                    idx1 = istr_ex2a2(icmp)
                    idx2 = istr_cntc2(icmp)
                    idx  = (idx1-1)*nstr_cntc2(icmp)+idx2
                    ielmap = map_ex2cnta(ioff+idx)
                    if (ielmap.eq.0) cycle cntc
                    isgnop2a = isgnop2a*sign(1,ielmap)
                    idxop2 = idxop2+(abs(ielmap)-1)*ldim_op2a(icmp)
                    ioff = ioff + nstr_ex2cnta(icmp)
                  end do

                  sgn = xfac*dble(isgn0*isgnop1c*isgnop2a)

                  ! xfac contained in sgn
c dbg
c                  if (idxop1.lt.1) stop 'range1'
c                  if (idxop2.lt.1) stop 'range2'
c                  if (idxop1.gt.lenop1) stop 'range1'
c                  if (idxop2.gt.lenop2) stop 'range2'
c dbg
                  xop1op2(idxop1op2) = xop1op2(idxop1op2)
     &                          + sgn * xop1(idxop1)
     &                                * xop2(idxop2)
c dbg
c                  if (lenop12.eq.2) then
c                  print *,' sng ',isgnop1c,isgnop1a,
c     &                 isgnop2c,isgnop2a,isgnr
c                  print *,' +++ ',sgn,xop1(idxop1),xop2(idxop2),
c     &                                ' -> ',idxop1op2
c                  end if
c dbg

                end do cntc
              end do cnta

            end do ex2c
          end do ex1c

        end do ex2a
      end do ex1a

c dbg
c      print *,'updated iop1op2: '
c      write(6,'(x,": ",4g20.12)') xop1op2(1:lenop12)
c dbg
      return
      end

*----------------------------------------------------------------------*
      pure integer function idx_str_blk3(idxc,idxa,ldimc,ldima,
     &                                   ngastp_c,ngastp_a)
*----------------------------------------------------------------------*
*
*     version for compressed lists on idxc/a, lenc/a
*
*----------------------------------------------------------------------*

      implicit none

      include 'opdim.h'

      integer, intent(in) ::
     &     ngastp_c, ngastp_a,
     &     idxc(*), idxa(*),
     &     ldimc(*), ldima(*)

      integer ::
     &     idx

      ! we have to add a one to get the index
      idx_str_blk3 = 1

      if (ngastp_c.gt.0) idx_str_blk3 = idx_str_blk3 + idxc(1)*ldimc(1)
      if (ngastp_a.gt.0) idx_str_blk3 = idx_str_blk3 + idxa(1)*ldima(1)

c      idx_str_blk3 = idxc(1)*ldimc(1)+idxa(1)*ldima(1) + 1
cmh      if ((ngastp_c*ngastp_a).le.1) return

      do idx = 2, ngastp_c
        idx_str_blk3 = idx_str_blk3+idxc(idx)*ldimc(idx)
      end do
      do idx = 2, ngastp_a
        idx_str_blk3 = idx_str_blk3+idxa(idx)*ldima(idx)
      end do

      return
      end


        SUBROUTINE MA_SC2D  ( marrpt, iret )
C************************************************************************
C* MA_SC2D							        *
C*								        *
C* This subroutine calls the routines which decode the groups in        *
C* section 2 of the drifting buoy report.  This section contains surface*
C* marine data.                                                         *
C*                                                                      *
C* MA_SC2D  ( MARRPT, IRET )                                            *
C*                                                                      *
C* Input parameters:						        *
C*      MARRPT          CHAR*           Report array                    *
C*	LSEC2           INTEGER         Length of section 2             *
C*      ISEC2           INTEGER         Pointer to start of section 2   *
C*								        *
C* Output parameters:						        *
C*	RIVALS(IRQDS2) 	REAL		Quality control indicator for   *
C*	                                section 2. WMO Code table 3334. *
C*	RIVALS(IRQXS2) 	REAL		Indicator of position of group  *
C*	IRET	 	INTEGER	    	Return code		        *
C*				   	  0 = normal return 	        *
C*                                        1 = problems                  *
C**								        *
C* Log:								        *
C* R. Hollern/NCEP       6/96                                           *
C* R. Hollern/NCEP      12/96   Replaced ST_C2R with ST_INTG            *
C* D. Kidwell/NCEP	 4/97	Changed interface, reorganized header   *
C*				and comments                            *
C* D. Kidwell/NCEP	10/97	Changed interface                       *
C* R. Hollern/NCEP       7/99   Decoded the wave period and height      *
C*                              groups and the quality control data     *
C* R. Hollern/NCEP       9/99   Bug fix if only wave data in section 222*
C************************************************************************
        INCLUDE         'GEMPRM.PRM'
        INCLUDE  	'macmn.cmn'
C*
        CHARACTER*(*)   marrpt
C*
        CHARACTER       fld1*1
C------------------------------------------------------------------------
        iret = 0
        ip = isec2
        jflg = 0
        ipt = ip
C
C*      Get the quality control indicator for section 2.
C
        fld1 = marrpt (ipt:ipt)
        CALL  ST_INTG ( fld1, ival, ier )
        IF ( ier .eq. 0 ) rivals ( irqds2 ) = FLOAT ( ival )
C
C*      Get the indicator of position of group
C
        ipt = ipt + 1
        fld1 = marrpt (ipt:ipt)
        CALL  ST_INTG ( fld1, ival, ier )
        IF ( ier .eq. 0 ) rivals ( irqxs2 ) = FLOAT ( ival )
C
        iend = isec2 + lsec2 - 1
C
        DO WHILE ( ipt .lt. iend )
C
            ipt = ipt + 1
C
            IF ( marrpt (ipt:ipt+1) .eq. ' 0' .and.
     +           jflg .eq. 0 ) THEN
C
C*              Decode the 0STTT sea surface temperature group.
C
                ipt = ipt + 2
                iparam = 3
                CALL  MA_TEMP ( marrpt, iparam, ipt, jret )
                ipt = ipt + 1
            END IF
C
            IF ( marrpt (ipt:ipt+1) .eq. ' 1' .and.
     +           jflg .eq. 0 ) THEN
C
C*              Decode the wave period and height data groups.
C
                ipt = ipt + 2
                CALL  MA_DWPH ( marrpt, ipt, jret )
                jflg = 1
            END IF
        END DO
C*
	RETURN
        END


Subroutine ro2et2(i1, i2, lbb1, lbb2, ei1, ei2, iblock, iseed)
  Parameter (maxstr=150001)
  Parameter (etam=0.5475, arho=0.77)
  Common /ee/id(maxstr), lb(maxstr)
  Common /ppb1/ene, factr2(6), fsum, ppinnb, s, wtot
  Common /ppmm/pprr, ppee, pppe, rpre, xopoe, rree
  Common /rndf77/nseed
  Save
  If (lb(i1)>=25 .And. lb(i1)<=27 .And. lb(i2)>=25 .And. lb(i2)<=27) Then
    iblock = 1895
    ei1 = etam
    ei2 = etam
    lbb1 = 0
    lbb2 = 0
  Else If (lb(i1)==0 .And. lb(i2)==0) Then
    iblock = 1896
    lbb1 = 25 + int(3*ranart(nseed))
    lbb2 = 25 + int(3*ranart(nseed))
    ei1 = arho
    ei2 = arho
  End If
  Return
End Subroutine ro2et2


      subroutine volq

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    Call subroutines to calculate the current day's CN for the HRU and
!!    to calculate surface runoff

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ievent      |none          |rainfall/runoff code
!!                               |0 daily rainfall/curve number technique
!!                               |1 sub-daily rainfall/Green&Ampt/hourly
!!                               |  routing
!!                               |3 sub-daily rainfall/Green&Ampt/hourly routing
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    SWAT: surq_daycn, surq_breakcn, surq_greenampt, dir_rnff
!!    SWAT: surq_hourly

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use parm

!! Compute surface runoff for day
      select case (ievent)
        case (0)
          call surq_daycn
        case (1)
          call surq_greenampt
        !  call dir_rnff
        !case (3)
        !  call surq_hourly
      end select

      return
      end


        SUBROUTINE ZRCCRB(CCRB,GRAT,APER,ORDER,COEF,ISTAT)
*
*  Module number:
*
*  Module name: ZRCCRB
*
*  Keyphrase:
*  ----------
*       Read table CCRB: scattered light correction coefficients
*
*  Description:
*  ------------
*       This routine reads table CCRB and extracts the scattered
*	light correction factors.
*
*  FORTRAN name: ZRCCRB.FOR
*
*  Keywords of accessed files and tables:
*  --------------------------------------
*  Name                         I/O     Description / Comments
*       CCRB                    I       scattered light coef. table
*
*  Subroutines Called:
*  -------------------
*  SDAS:
*       zmsput, uttopn, utpgti, utcfnd, utrgt*, uttclo
*
*  History:
*  --------
*  Version      Date        Author          Description
*       1       May 91      S. Hulbert      Designed and coded
*-------------------------------------------------------------------------------
*
* Input parameters
*
*       ccrB - table name
*	grating - grating mode
*	aper - aperture
*	order - spectral order
*
* Output parameters
*
*	coef - scattered light coefficients (4)
*       istat - ERROR status (integer)
**************************************************************************
        CHARACTER*64 CCRB
        CHARACTER*5 GRAT
	CHARACTER*3 APER
	DOUBLE PRECISION COEF(4)
        INTEGER ORDER, ISTAT
C
C     FILE I/O ACCESS MODES
C
      INTEGER   RDONLY
      PARAMETER (RDONLY = 1)
C
C     ZMSPUT DESTINATIONS -- CB, DAO, 4-SEP-87
C
      INTEGER STDOUT
      PARAMETER (STDOUT = 1)
      INTEGER STDERR
      PARAMETER (STDERR = 2)
C
C     THIS SECTION IS FOR PARAMETERS RELEVANT TO TABLE I/O.
C
C
C     THESE MAY BE READ BY UTPGTI BUT MAY NOT BE SET:
C
C                                       NUMBER OF ROWS WRITTEN TO
      INTEGER   TBNROW
      PARAMETER (TBNROW = 21)
C     END IRAF77.INC
C
C LOCAL VARIABLES -------------------------------------------
C
        INTEGER IDIN,NROWS,COLIDS(7),ROW,I,ISTATS(7)
        CHARACTER*5 GRAT0
        CHARACTER*3 APER0
	INTEGER ORDER0
        CHARACTER*80 CONTXT
        CHARACTER*8 COLNAM(7)
        LOGICAL NULL
        DATA COLNAM/'GRATING','SPORDER','APERTURE',
     $	'A_SCAT','B_SCAT','C_SCAT','D_SCAT'/
C
C--------------------------------------------------------------------------
C
C Open table
C
        CALL UTTOPN(CCRB,RDONLY,IDIN,ISTAT)
        IF(ISTAT.NE.0)THEN
                CONTXT='ERROR opening CCRB table '//CCRB
                GO TO 998
        ENDIF
C
C get number of rows
C
        CALL UTPGTI(IDIN,TBNROW,NROWS,ISTAT)
        IF(ISTAT.NE.0)THEN
                CONTXT='ERROR reading CCRB table '//CCRB
                GO TO 999
        ENDIF
C
C Get column ids.
C
        CALL UTCFND(IDIN,COLNAM,7,COLIDS,ISTAT)
        IF(ISTAT.NE.0)THEN
                CONTXT='ERROR locating needed columns in CCRB table '//
     *                  CCRB
                GO TO 999
        ENDIF
C
C Locate row with correct grating
C
        DO 10 ROW=1,NROWS
                CALL UTRGTT(IDIN,COLIDS(1),1,ROW,GRAT0,NULL,ISTATS(1))
                CALL UTRGTI(IDIN,COLIDS(2),1,ROW,ORDER0,NULL,ISTATS(2))
                CALL UTRGTT(IDIN,COLIDS(3),1,ROW,APER0,NULL,ISTATS(3))
		DO 100 I = 1, 3
                    IF(ISTATS(I).NE.0)THEN
                        CONTXT='ERROR reading CCRB table '//CCRB
                        GO TO 999
                    ENDIF
100		CONTINUE
                IF ((GRAT0 .EQ. GRAT) .AND. (ORDER0 .EQ. ORDER) .AND.
     $			(APER0 .EQ. APER)) GO TO 20
10      CONTINUE
C
C if we made it here, we did not find a correct row
C
        WRITE(CONTXT,99)GRAT
99      FORMAT('ERROR no row in CCRB table found for grating ',A5,',')
        CALL ZMSPUT(CONTXT,STDOUT+STDERR,0,ISTAT)
        WRITE(CONTXT,98)ORDER,APER
98      FORMAT('             order ',I4,', aperture ',A3)
        GO TO 999
C
C read values
C
20      CALL UTRGTD(IDIN,COLIDS(4),1,ROW,COEF(1),NULL,ISTATS(1))
        CALL UTRGTD(IDIN,COLIDS(5),1,ROW,COEF(2),NULL,ISTATS(2))
        CALL UTRGTD(IDIN,COLIDS(6),1,ROW,COEF(3),NULL,ISTATS(3))
        CALL UTRGTD(IDIN,COLIDS(7),1,ROW,COEF(4),NULL,ISTATS(4))
        DO 30 I=1,4
            IF(ISTATS(I).NE.0)THEN
                CONTXT='ERROR reading CCRB table '//CCRB
                GO TO 999
            ENDIF
30      CONTINUE
        ISTAT=0
        GO TO 1000
999     CALL UTTCLO(IDIN,ISTAT)
998     CALL ZMSPUT(CONTXT,STDOUT+STDERR,0,ISTAT)
        ISTAT=1
1000    RETURN
        END


*------------------------------------------------------------------------
*        S A V E B R
*------------------------------------------------------------------------
*
*     Three matrices are created -- LS (non-relativistic or with
*     relativistic shift), LSJ1 (Breit-Pauli operators other
*     than spin-spin), LSJ2 (spin-spin)
*
*     An LS calculation only uses the first whereas LSJ creates
*     J-dependent matrices from all three.
*
      SUBROUTINE SAVE(ICASE,C,K,I1,I2,I3,I4,JA,JB,IPTR)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
*
      POINTER (qh,h(ncfg,3)),(qjan,jan(ncfg,3))
      COMMON /buffer/qh, qjan, nrow(3),iflag(3)
      COMMON /INFORM/IREAD,IWRITE,IOUT,ISC(8),ISCW
      POINTER(QNOC,NOCCSH(1)),(QNELCSH,NELCSH(8,1)),
     :       (QNOCORB,NOCORB(8,1)),(QJ1,J1QNRD(15,1))
      COMMON /NDIMS/ QNOC,QNELCSH,QNOCORB,QJ1,NCFG
      DOUBLE PRECISION intval
*
*     print *,'Save: icase,c,k,i1,i2,i3,i4,ja,jb,iptr',
*    :        icase,c,k,i1,i2,i3,i4,ja,jb,iptr
      if (icase .le. 4) then
	lcase = 1
      else if (icase .le. 7) then
	lcase = 2
      ELSEIF(ICASE.EQ.9) THEN
	LCASE=1
      else
	lcase = 3
      end if
*
*     .. obtain canonical form
      IF (icase .LE. 2 .or. icase .EQ. 4 .or. icase .eq. 5) THEN
	 IF (I2 .GT. I4) THEN
	    II2 = I4
	    II4 = I2
	 ELSE
	    II2 = I2
	    II4 = I4
	 END IF

      ELSE if (icase .eq. 3) then
*
*     Rk data
*
	 J = 1
	 IMIN = I1
	 IF (I2 .LT. IMIN) THEN
	    IMIN=I2
	    J = 2
	 END IF
	 IF (I3 .LT. IMIN) THEN
	    IMIN = I3
	    J = 3
	 END IF
	 IF (I4 .LT. IMIN) THEN
	    IMIN = I4
	    J = 4
	 END IF
	 GO TO (10,20,30,40) J
10       II1 = I1
         II2 = I2
         II3 = I3
         II4 = I4
         Go to 50

20       II1 = I2
	 II2 = I1
	 II3 = I4
	 II4 = I3
	 GO TO 50

30       II1 = I3
	 II2 = I4
	 II3 = I1
	 II4 = I2
	 GO TO 50

40       II1 = I4
	 II2 = I3
	 II3 = I2
	 II4 = I1

      ELSE
         II1 = I1
         II3 = I3
         IF (I2 .GT. I4) THEN
            II2 = I4
            II4 = I2
         ELSE
            II2 = I2
            II4 = I4
         END IF
         IF (ICASE .NE. 7) THEN
            IF (I1 .GT. I3) THEN
               II1 = I3
               II3 = I1
            END IF
         END IF
      END IF
50    v= intval(ICASE,K,II1,II2,II3,II4)
      if (iflag(lcase) .eq.0) then
*       .. this is the first for this matrix element
	nrow(lcase) = nrow(lcase) + 1
	jan(nrow(lcase),lcase) = ja
        iflag(lcase) = 1
      end if
      h(nrow(lcase),lcase) = h(nrow(lcase),lcase) + c*v
      END