      subroutine contr(inj)
!***********************************************************************
!  Copyright, 1993, 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.
!***********************************************************************
CD1
CD1 PURPOSE
CD1
CD1 Write to contour plot tape.
CD1
C***********************************************************************
CD2
CD2 REVISION HISTORY
CD2
CD2 Revision                    ECD
CD2 Date         Programmer     Number  Comments
CD2
CD2 11-FEB-94    Z. Dash        22      Add prolog.
CD2              G. Zyvoloski           Initial implementation.
CD2
CD2 $Log:   /pvcs.config/fehm90/src/contr.f_a  $
!D2
!D2    Rev 2.5   06 Jan 2004 10:42:44   pvcs
!D2 FEHM Version 2.21, STN 10086-2.21-00, Qualified October 2003
!D2
!D2    Rev 2.4   29 Jan 2003 09:00:20   pvcs
!D2 FEHM Version 2.20, STN 10086-2.20-00
!D2
!D2    Rev 2.3   14 Nov 2001 13:07:56   pvcs
!D2 FEHM Version 2.12, STN 10086-2.12-00
!D2
!D2    Rev 2.2   06 Jun 2001 13:22:54   pvcs
!D2 FEHM Version 2.11, STN 10086-2.11-00
!D2
!D2    Rev 2.1   30 Nov 2000 11:58:58   pvcs
!D2 FEHM Version 2.10, STN 10086-2.10-00
!D2
!D2    Rev 2.0   Fri May 07 14:40:12 1999   pvcs
!D2 FEHM Version 2.0, SC-194 (Fortran 90)
CD2
CD2    Rev 1.8   Mon Jan 29 13:58:00 1996   hend
CD2 Updated Requirements Traceability
CD2
CD2    Rev 1.7   03/10/95 10:31:18   llt
CD2 changed to calculate velocity with 1 call - gaz
CD2
CD2    Rev 1.6   12/01/94 08:45:32   llt
CD2 Changed max functions so would run on ibm.
CD2
CD2    Rev 1.5   08/23/94 08:48:58   llt
CD2 Accidently lost revision 1.3. Added changes back in.
CD2
CD2    Rev 1.4   08/23/94 08:24:12   llt
CD2 gaz changes
CD2
CD2    Rev 1.3   06/20/94 10:55:08   zvd
CD2 Modified to remove contour output files if AVS output is used.
CD2
CD2    Rev 1.2   03/18/94 15:42:54   gaz
CD2 Added solve_new and cleaned up memory management.
CD2
CD2    Rev 1.1   02/14/94 11:43:36   zvd
CD2 Modified so if contour files not present code won't attempt write.
CD2
CD2    Rev 1.0   01/20/94 10:22:30   pvcs
CD2 original version in process of being certified
CD2
C***********************************************************************
CD3
CD3 INTERFACES
CD3
CD3 Formal Calling Parameters
CD3
CD3   Identifier      Type     Use  Description
CD3
CD3   inj             INT      I    Flag to indicate if this is first call to
CD3                                   routine
CD3
CD3 Interface Tables
CD3
CD3   None
CD3
CD3 Files
CD3
CD3   Name                     Use  Description
CD3
CD3   iscon                    O    Contour plot data file
CD3   iscon1                   O    Contour plot data file for dual or dpdp
CD3
C***********************************************************************
CD4
CD4 GLOBAL OBJECTS
CD4
CD4 Global Constants
CD4
CD4   None
CD4
CD4 Global Types
CD4
CD4   None
CD4
CD4 Global Variables
CD4
CD4                            COMMON
CD4   Identifier      Type     Block  Description
CD4
CD4   altc            CHAR     faax   String used for denoting type of output
CD4                                     for contour plots
CD4   cord            REAL*8   fbs    Contains the coordinates of each node
CD4   cpr             REAL*8   fdd    Rock specific heat at each node
CD4   icap            INT      fddi1  Capillary pressure model at each node
CD4   iccen           INT      faai   Parameter which indicates if the tracer
CD4                                     solution is enabled
CD4   ipqz            INT      faai   The number of nodes used for the contour
CD4                                     plot output
CD4   irlp            INT      fddi1  Relative permeability model at each node
CD4   iscon           INT      faai   Unit number for contour data file
CD4   iscon1          INT      faai   Unit number for dual porosity or dpdp
CD4                                     contour data file
CD4   istrs           INT      faai   Parameter indicating if the stress
CD4                                     solution is enabled
CD4   jdate           CHAR     faac1  Contains the date (mm/dd/yr)
CD4   jtime           CHAR     faac1  Contains the time (hr:mn:sc)
CD4   nelm            INT      fbb    Initially information about nodes in each
CD4                                     element, later nodal connectivity
CD4                                     information
CD4   neq             INT      faai   Number of nodes, not including dual
CD4                                     porosity nodes
CD4   nmfil           CHAR ARY faax   I/O file names:
CD4                                   10 - Contour plot output file name
CD4                                   11 - Dual porosity or dpdp contour plot
CD4                                          output file name
CD4   nspeci          INT      fdd1i  Number of species for tracer solution
CD4   pcp             REAL*8   fdd    Capillary pressure at each node
CD4   phi             REAL*8   fdd    Pressure at each node
CD4   pnx             REAL*8   fdd    Permeability in the x-direction, liquid
CD4                                     velocity in the x-direction, vapor
CD4                                     velocity in the x-direction
CD4   pny             REAL*8   fdd    Permeability in the y-direction liquid
CD4                                     velocity in the y direction, vapor
CD4                                     velocity in the y-direction
CD4   pnz             REAL*8   fdd    Permeability in the z-direction, liquid
CD4                                     velocity in the z-direction, vapor
CD4                                     velocity in the z-direction
CD4   ps              REAL*8   fdd    Porosity at each node
CD4   s               REAL*8   fdd    Liquid saturation at each node
CD4   t               REAL*8   fdd    Temperature at each node
CD4   thx             REAL*8   fdd    Thermal conductivity x-direction
CD4   thy             REAL*8   fdd    Thermal conductivity y-direction
CD4   thz             REAL*8   fdd    Thermal conductivity z-direction
CD4   verno           CHAR     faac   Contains version number of FEHMN code
CD4   wdd             CHAR     faac   Problem title
CD4
CD4 Global Subprograms
CD4
CD4   Identifier      Type     Description
CD4
CD4   concen                   Control tracer simulation output
CD4   veloc                    Calculate fluid velocities
CD4
C***********************************************************************
CD5
CD5 LOCAL IDENTIFIERS
CD5
CD5 Local Constants
CD5
CD5   Identifier      Type     Description
CD5
CD5 Local Types
CD5
CD5   None
CD5
CD5 Local variables
CD5
CD5   Identifier      Type     Description
CD5
CD5   i               INT      Loop index
CD5   j               INT      Loop index
CD5   neq1            INT      Loop index for dual/dpdp
CD5   neq2            INT      Loop index for dual/dpdp
CD5
CD5 Local Subprograms
CD5
CD5   None
CD5
C***********************************************************************
CD6
CD6 FUNCTIONAL DESCRIPTION
CD6
C***********************************************************************
CD7
CD7 ASSUMPTIONS AND LIMITATIONS
CD7
CD7 None
CD7
C***********************************************************************
CD8
CD8 SPECIAL COMMENTS
CD8
CD8  Requirements from SDN: 10086-RD-2.20-00
CD8    SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
CD8    FEHM Application Version 2.20
CD8
C***********************************************************************
CD9
CD9 REQUIREMENTS TRACEABILITY
CD9
CD9 2.6 Provide Input/Output Data Files
CD9 3.0 INPUT AND OUTPUT REQUIREMENTS
CD9
C***********************************************************************
CDA
CDA REFERENCES
CDA
CDA None
CDA
C***********************************************************************
CPS
CPS PSEUDOCODE
CPS
CPS BEGIN contr
CPS
CPS   call subroutine veloc for phase velocities
CPS
CPS   IF avs output is required
CPS      IF this is the first call
CPS         IF contour file exists
CPS            close contour file
CPS         END IF
CPS         IF dual/dpdp contour file exists
CPS            close dual/dpdp contour file
CPS         END IF
CPS      END IF
CPS      call avs_io to write output
CPS   ELSE IF ment output is required
CPS      [doesn't do anything]
CPS   ELSE IF ptrn output is required
CPS
CPS      IF this is a liquid phase problem and the contour file exists
CPS         call contrj to write output
CPS      END IF
CPS
CPS   ELSE IF fehm binary or free format output is wanted
CPS
CPS      IF contour file exists
CPS         IF this is initial call
CPS            IF file is binary format
CPS               close and reopen contour file in unformatted mode
CPS               ****** unformatted writes ******
CPS               write program version, date, time, and problem title
CPS               IF tracer problem
CPS                  write 'trac' to file
CPS               ELSE
CPS                  write blank line
CPS               END IF
CPS
CPS               IF stress problem
CPS                  write 'strs' to file
CPS               ELSE
CPS                  write blank line
CPS               END IF
CPS
CPS               write node coordinates and connectivity data
CPS               write permeabilities, conductivities, porosities, . . .
CPS               . . . specific heats, capillary pressures, relative . . .
CPS               . . . permeability model, and capillary pressure model
CPS               IF tracers are being used
CPS                  write number of species being used
CPS               END IF
CPS            ELSE
CPS               ****** free format writes ******
CPS               same as for unformatted writes (see above) except . . .
CPS               . . . program version, date, time, and problem title . . .
CPS               . . . have already been written to file
CPS            END IF
CPS         ELSE
CPS
CPS            call veloc to compute velocities
CPS
CPS            IF file is binary format
CPS               ****** unformatted writes ******
CPS               write simulation time and problem phase
CPS               IF all liquid
CPS                  write velocities, pressures, and temperatures
CPS               ELSE
CPS                  write velocities, pressures, and saturations
CPS               END IF
CPS            ELSE
CPS               ****** free format writes ******
CPS               same as unformatted writes (see above)
CPS            END IF
CPS
CPS         END IF
CPS
CPS      END IF
CPS
CPS      IF dual/dpdp contour file exists
CPS         same as for contour file (see above), except for . . .
CPS         . . . dual posorsity / dual permeabilty nodes
CPS      END IF
CPS
CPS      IF this isn't the initial call
CPS         call concen to write contour information for tracers
CPS      END IF
CPS
CPS   END IF
CPS
CPS END contr
CPS
C***********************************************************************

      use avsio
      use comai
      use combi
      use comci
      use comdi
      use comdti
      use comflow, only : flag_heat_out
      use comhi
      use comii
      use compart
      use comwt
      use comxi
      use comsi
      use davidi

      implicit none

      real*8 px, py, pz
      real*8 anld,anvd
      real*8 phihd, sdum, hddum, phipcp
      real*8 dumconv, dumconv1, pdum, tdum, rolconv

      integer i,inj,j,neq1,neq2, dummyint,k,jp,kk,ll,length
      integer ialiq, iavap, ihead_sv

      if(icont.eq.0) return
c check for contour file output form
c call veloc calculations here
c both vapor and liquid velocities calculated with one call
      if(inj.gt.0.and.compute_flow) call veloc

c add call to heatloc to calculate heat fluxes for output
      if (inj.gt.0.and.flag_heat_out) call heatloc

c if head data requested call airctr(8,0)
c
      if(ichead.ne.0) then
c gaz 083119 don't turn head on exept to printout
         ihead_sv = 1
         if(ihead.eq.0) then
          ihead_sv = 0
          ihead = 1
         endif
         dumconv = crl(1,1)
         dumconv1 = crl(4,1)
         pdum = pres0+rol0*head0*(-grav)
         tdum = temp0
         call water_density(tdum,pdum,rolconv)
         crl(1,1)=rolconv
         crl(4,1)=pres0
         call headctr(2,0,0.,0.)
         crl(1,1)= dumconv
         crl(4,1)= dumconv1
         if(ihead_sv.eq.0) then
          ihead = 0
         endif
      else if(ihead.ne.0) then
         if (inj.ne.0) then
            rolconv = crl(1,1)
c
c convert from pressure to head
c
            call headctr(2,0,0.0,0.0)
	    if(ifree.ne.0) then
               do i = 1,n
                  if(rlxyf(i).lt.sattol+rlptol) head(i) = head_id
               enddo
	    endif
         else
	    head = pho
         endif
      else
         iohead=0
      endif
      if (altc(1:3) .eq. 'avs' .or. altc(1:3) .eq. 'sur'.or.
     &     altc(1:3) .eq. 'tec') then
c use avs form
         if (inj .eq. 0) then
            inquire (file = nmfil(10), exist = ex)
            if (ex) then
               close (iscon, status = 'delete')
            end if
            inquire (file = nmfil(11), exist = ex)
            if (ex) then
               close (iscon1, status = 'delete')
            end if
         end if
         call avs_io(inj)
!      else if (altc(1:3) .eq. 'sur'.or. altc(1:3) .eq. 'tec') then
!         call surf_tec(inj)
      else if (altc .eq. 'ment') then
c     use mentat form
      else if (altc .eq. 'ptrn') then
c     use patran form
c     call only if liquid phase and contour plot file wanted
         if (inj .lt. 0 .and. iscon .gt. 0) call contrj(inj)
      else
c use fehm binary or free format output
c**** 2-d, 3-d output ****
         if (iscon .gt. 0) then
            if (inj .eq. 0) then
               if(altc .eq. 'fehm') then
c for unformatted file close contour file and open again as an
c unformatted file
                  close (iscon,status='delete')
                  open(iscon, file = nmfil(10), status='unknown',
     *                 form = 'unformatted')
                  write(iscon) verno, jdate, jtime
                  write(iscon) wdd
                  ipqz = neq_primary
                  if (iccen .ne. 0) then
                     write(iscon)  'trac'
                  else
                     write(iscon)  '    '
                  end if
                  if (istrs .ne. 0)  then
                     write(iscon)  'strs'
                  else
                     write(iscon)  '    '
                  end if
                  write(iscon) neq_primary
                  write(iscon)  (corz(i, 1), corz(i, 2), corz(i,3),
     *                 i = 1, neq_primary)
                  write(iscon)  ns , nei
                  write(iscon) ((nelm((j-1)*ns+i), i =1, ns),
     *                 j = 1, nei)
c**** selected input quantities ****
                  write(iscon)  (pnx(i)*1.0e-06,
     *                 pny(i)*1.0e-06, pnz(i)*1.0e-06, i=1,neq_primary)
                  if(ico2.ge.0) then
                     write(iscon )
     *                    ( thx(i) , thy(i) , thz(i) , i=1,neq_primary)
                  else
                     write(iscon )
     *                    ( 0.0d00 , 0.0d00 , 0.0d00 , i=1,neq_primary)
                  endif
                  if(ico2.ge.0 .and. irdof .ne. 13) then
                     write(iscon )
     *                    ( ps(i) , cpr(i) , pcp(i) , i=1,neq_primary )
                  else
                     write(iscon )
     *                    ( ps(i) , cpr(i) , 0.0d00 , i=1,neq_primary )
                  endif
                  write(iscon ) idof,igrav,grav
                  if ( iccen .ne. 0 )  then
                     write(iscon )  nspeci
                  end if
               else
                  ipqz   =  neq_primary
                  if (iccen .ne. 0)  then
                     write(iscon, *)  'trac'
                  else
                     write(iscon, *)  '    '
                  end if
                  if (istrs .ne. 0)  then
                     write(iscon, *)  'strs'
                  else
                     write(iscon, *)  '    '
                  end if
                  write(iscon, *)  neq_primary
                  write(iscon, 10) (corz(i, 1), corz(i, 2), corz(i, 3),
     *                 i = 1, neq_primary)
 10               format(1x,3g20.8)
                  write(iscon, *)  ns , nei
                  write(iscon, *)  ((nelm((j-1)*ns+i), i = 1, ns),
     *                 j = 1, nei)

c**** selected input quantities ****

                  write(iscon, 10)  (pnx(i)*1.0e-06, pny(i)*1.0e-06,
     *                 pnz(i)*1.0e-06, i = 1, neq_primary)
                  if(ico2.ge.0) then
                     write(iscon,10)
     *                    ( thx(i) , thy(i) , thz(i) , i=1,neq_primary)
                  else
                     write(iscon,10)
     *                    ( 0.0d00 , 0.0d00 , 0.0d00 , i=1,neq_primary)
                  endif
                  if(ico2.ge.0 .and. irdof .ne. 13) then
                     write(iscon ,10)
     *                    (ps(i), cpr(i), pcp(i), i = 1, neq_primary)
                  else
                     write(iscon ,10)
     *                    (ps(i), cpr(i), 0.0d00, i = 1, neq_primary)
                  endif
                  write(iscon ,*) idof,igrav,grav
                  if (iccen .ne. 0)  then
                     write(iscon, *)  nspeci
                  end if
               end if
            else
               if (altc .eq. 'fehm') then
                  write(iscon )  days , inj
                  if (inj .gt. 0)  then
                     npn = n
                     write(iscon) (dil(i)/
     *                    max(rolf(i),0.000000001d+1),
     *                    rolf(i),  phi(i)-pcp(i),
     *                    t(i), i = 1, neq_primary)
                  else
                     npn = n + n
                     write(iscon) (div(i)/
     *                    max(rovf(i),0.000000001d+1),
     *                    rovf(i),  phi(i),
     *                    t(i), i = 1, neq_primary)
                  end if
               else
                  write(iscon, *)  days, inj
                  if (inj .gt. 0)  then
                     npn = n
                     write(iscon, 10) (dil(i)/
     *                    max(rolf(i),0.000000001d+1),
     *                    rolf(i),  phi(i)-pcp(i),
     *                    t(i), i = 1, neq_primary)
                  else
                     npn    =  n+n
                     write(iscon, 10) (div(i)/
     *                    max(rovf(i),0.000000001d+1),
     *                    rovf(i),  phi(i),
     *                    t(i), i = 1, neq_primary)
                  end if
               end if
            end if
         end if

c write out info for dp solution
         if((idualp .ne. 0 .or. idpdp .ne. 0)
     *        .and. iscon1 .gt. 0) then

            neq1 = neq_primary + 1
            neq2 = neq_primary + neq_primary
            if (inj .eq. 0) then
               if(altc .eq. 'fehm') then
c for unformatted file close contour file and open again as an
c unformatted file
                  close (iscon1, status = 'delete')
                  open(iscon1, file = nmfil(11), status='unknown',
     *                 form = 'unformatted')
                  write(iscon1) verno, jdate, jtime
                  write(iscon1) wdd

                  if (iccen .ne. 0) then
                     write(iscon1)  'trac'
                  else
                     write(iscon1)  '    '
                  end if

                  if (istrs .ne. 0) then
                     write(iscon1)  'strs'
                  else
                     write(iscon1)  '    '
                  end if
                  write(iscon1) neq
                  write(iscon1) (corz(i,1), corz(i,2),
     *                 corz(i,3), i = 1, neq_primary)
                  write(iscon1) ns, nei
                  write(iscon1) ((nelm((j-1)*ns+i), i = 1, ns),
     *                 j = 1, nei)

c**** selected input quantities ****
                  write(iscon1)  (pnx(i)*1.0e-06, pny(i)*1.0e-06,
     *                 pnz(i)*1.0e-06, i = neq1, neq2)
                  if(ico2.ge.0) then
                     write(iscon1)  (thx(i), thy(i), thz(i),
     *                    i = neq1, neq2)
                  else
                     write(iscon1)  (0.0d00, 0.0d00, 0.0d00,
     *                    i = neq1, neq2)
                  endif
                  if(ico2.ge.0 .and. irdof .ne. 13) then
                     write(iscon1)  (ps(i), cpr(i), pcp(i),
     &                    i = neq1, neq2)
                  else
                     write(iscon1)  (ps(i), cpr(i), 0.d0,
     &                    i = neq1, neq2)
                  end if
                  write(iscon ) idof,igrav,grav
                  if (iccen .ne. 0) then
                     write(iscon1)  nspeci
                  end if
               else
                  if (iccen .ne. 0) then
                     write(iscon1, *) 'trac'
                  else
                     write(iscon1, *) '    '
                  end if
                  if (istrs .ne. 0) then
                     write(iscon1, *) 'strs'
                  else
                     write(iscon1, *) '    '
                  end if
                  write(iscon1, *) neq_primary
                  write(iscon1, 10) (corz(i,1), corz(i,2),
     *                 corz(i,3), i = 1, neq_primary)
                  write(iscon1, *) ns, nei
                  write(iscon1, *) ((nelm((j-1)*ns+i), i = 1, ns),
     *                 j = 1, nei)

c**** selected input quantities ****
                  write(iscon1, 10) (pnx(i)*1.0e-06, pny(i)*1.0e-06,
     *                 pnz(i)*1.0e-06, i = neq1, neq2 )
                  if(ico2.ge.0) then
                     write(iscon1,10)  (thx(i), thy(i), thz(i),
     *                    i = neq1, neq2)
                  else
                     write(iscon1,10)  (0.0d00, 0.0d00, 0.0d00,
     *                    i = neq1, neq2)
                  endif
                  if(ico2.ge.0 .and. irdof .ne. 13) then
                     write(iscon1, 10) (ps(i), cpr(i), pcp(i),
     *                    i = neq1, neq2)
                  else
                     write(iscon1, 10) (ps(i), cpr(i), 0.d0,
     *                    i = neq1, neq2)
                  end if
                  write(iscon ) idof,igrav,grav
                  if (iccen .ne. 0) then
                     write(iscon1, *) nspeci
                  end if
               end if
            else
               if(altc .eq. 'fehm') then
                  write(iscon1) days, inj
                  if (inj .gt. 0) then
                     npn    =  n
                     if (irdof .ne. 13) then
                        write(iscon1) (dil(i)/
     *                       max(rolf(i),0.000000001d+1),
     *                       rolf(i),  phi(i)-pcp(i),
     *                       t(i), i = neq1, neq2)
                     else
                        write(iscon1) (dil(i)/
     *                       max(rolf(i),0.000000001d+1),
     *                       rolf(i),  phi(i),
     *                       t(i), i = neq1, neq2)
                     end if
                  else
                     npn = n + n
                     write(iscon1) (div(i)/
     *                    max(rovf(i),0.000000001d+1),
     *                    rovf(i),  phi(i),
     *                    t(i), i = neq1, neq2)
                  end if
               else
                  write(iscon1, *) days, inj
                  if (inj .gt. 0) then
                     npn = n
                     if (irdof .ne. 13) then
                        write(iscon1, *) (dil(i)/
     *                       max(rolf(i),0.000000001d+1),
     *                       rolf(i),  phi(i)-pcp(i),
     *                       t(i), i = neq1, neq2)
                     else
                        write(iscon1, *) (dil(i)/
     *                       max(rolf(i),0.000000001d+1),
     *                       rolf(i),  phi(i),
     *                       t(i), i = neq1, neq2)
                     end if
                  else
                     npn = n + n
                     write(iscon1, *) (div(i)/
     *                    max(rovf(i),0.000000001d+1),
     *                    rovf(i),  phi(i),
     *                    t(i), i = neq1, neq2)
                  end if
               end if
            end if
         end if

         if (inj .ne. 0) then
            call  concen (5,0)
         end if
         if(ichead.ne.0) then
            ihead = 0
         endif

      endif
      end


!*******************************************************************************
!   Copyright(C) 2004-2015 Intel Corporation. All Rights Reserved.
!
!   The source code, information  and  material ("Material") contained herein is
!   owned  by Intel Corporation or its suppliers or licensors, and title to such
!   Material remains  with Intel Corporation  or its suppliers or licensors. The
!   Material  contains proprietary information  of  Intel or  its  suppliers and
!   licensors. The  Material is protected by worldwide copyright laws and treaty
!   provisions. No  part  of  the  Material  may  be  used,  copied, reproduced,
!   modified, published, uploaded, posted, transmitted, distributed or disclosed
!   in any way  without Intel's  prior  express written  permission. No  license
!   under  any patent, copyright  or  other intellectual property rights  in the
!   Material  is  granted  to  or  conferred  upon  you,  either  expressly,  by
!   implication, inducement,  estoppel or  otherwise.  Any  license  under  such
!   intellectual  property  rights must  be express  and  approved  by  Intel in
!   writing.
!
!   *Third Party trademarks are the property of their respective owners.
!
!   Unless otherwise  agreed  by Intel  in writing, you may not remove  or alter
!   this  notice or  any other notice embedded  in Materials by Intel or Intel's
!   suppliers or licensors in any way.
!
!*******************************************************************************
!   Content : MKL DSS Fortran header file
!
!           Contains more detailed information on internal datatypes and
!           constants used by DSS interface to PARDISO.
!
!*******************************************************************************

      MODULE MKL_SPARSE_CHECK

      USE, INTRINSIC :: ISO_C_BINDING, ONLY : C_INTPTR_T

      ENUM, BIND(C)
          ENUMERATOR :: MKL_ZERO_BASED, MKL_ONE_BASED
      END ENUM

      ENUM, BIND(C)
          ENUMERATOR :: MKL_C_STYLE, MKL_FORTRAN_STYLE
      END ENUM

      ENUM, BIND(C)
          ENUMERATOR :: MKL_NO_PRINT, MKL_PRINT
      END ENUM

      ENUM, BIND(C)
          ENUMERATOR :: MKL_GENERAL_STRUCTURE, MKL_UPPER_TRIANGULAR, MKL_LOWER_TRIANGULAR, MKL_STRUCTURAL_SYMMETRIC
      END ENUM

      ENUM, BIND(C)
          ENUMERATOR :: MKL_CSR
      END ENUM

      TYPE, BIND(C) :: SPARSE_STRUCT
          INTEGER N
          INTEGER (C_INTPTR_T) :: CSR_IA
          INTEGER (C_INTPTR_T) :: CSR_JA
          INTEGER CHECK_RESULT(3)
          INTEGER(KIND=4) INDEXING
          INTEGER(KIND=4) MATRIX_STRUCTURE
          INTEGER(KIND=4) MATRIX_FORMAT
          INTEGER(KIND=4) MESSAGE_LEVEL
          INTEGER(KIND=4) PRINT_STYLE
      END TYPE SPARSE_STRUCT

      INTERFACE

          FUNCTION sparse_matrix_checker(PT)
              IMPORT SPARSE_STRUCT
              TYPE(SPARSE_STRUCT), INTENT(INOUT) :: PT
              INTEGER sparse_matrix_checker
          END

          SUBROUTINE sparse_matrix_checker_init(PT)
              IMPORT SPARSE_STRUCT
              TYPE(SPARSE_STRUCT), INTENT(INOUT) :: PT
          END

      END INTERFACE

      END MODULE MKL_SPARSE_CHECK


	subroutine setrc(natom,*,nmedia,nobject,ndistr)
c
	include "qdiffpar4.h"
	include "qlog.h"
c
	character*80 line,filnam
	character*6 head,str6
	character*5 atnum
	character*24 crdstr
	character*13 radstr
	character*16 crgstr
	character*5 atmstr
	dimension atpos(3*1),rad3(1),chrgv4(1),xo(3)
	logical ifrm,iatinf,iatrad,iatcrg
	character*15 atinf(1)
c b++++++++++++++++++++
        integer nmedia,nobject,ndistr
c e++++++++++++++++++++
204	format(a80)
205	format(3f8.3)
206   format(F6.2,F7.3)
c
	write(6,*) "assigning charges and radii..."
	write(6,*) " "
	natom=0
c
c begin read
c b++++++++++++++++++++
	call getatm(pdbnam,pdblen,ifrm,idfrm,iatinf,iatrad,iatcrg,natom,
     &  nmedia,nobject,ndistr,repsin,epkt,realsiz)
	if (natom.gt.natmax) then
        write(6,*)'number of atom coordinates read',natom,'is larger'
        write(6,*)'than natmax parameter, it must be increased!!'
	  stop
	end if
c e++++++++++++++++++++
c
	if(.not.iatrad) then
c
	do i=1,natom
c
	  atm = atinf(i)(1:5)
	  res = atinf(i)(7:9)
	  rnum = atinf(i)(12:15)
	  chn = atinf(i)(11:11)
c
	  call up(atm,6)
	  call elb(atm,6)
	  call up(res,3)
	  call elb(res,3)
	  call up(rnum,4)
	  call elb(rnum,4)
	  call up(chn,1)
	  call elb(chn,1)
c
c assign radius, searching for decreasingly specific specification
c ending with generic atom type
c note all atoms must have an assignment
c
	call radass(atm,res,rnum,chn,rad,norad)
c
	if(norad.eq.1) then
	rad=0.0
c	if(atm(1:1).ne.'H')
c     &	write(6,'(''!!! WARNING: no radius record for '',a15)')atinf(i)

      write(6,'(''!!! WARNING: no radius record for '',a15)')atinf(i)
c
c need stop here
c
      elseif(rad.lt.1.e-6.and.(atm(1:1).ne.'H'.and.atm(2:2).ne.'H'))
     &  then
        write(6,'(''!!! WARNING: radius of heavy atom'',a15,''
     &	is set to zero'')')atinf(i)
	end if
c
c store rad,xn in rad3,  for later use
c
	rad3(i)=rad
c
c scale and assign charge to grid
c
	  call crgass(atm,res,rnum,chn,chrgv)
	  chrgv4(i)=chrgv
c
	end do
c
c write record to new coordinate file if required, with
c occupancy and temperature factor fields replaced by radius and charge
c
	end if
c
c check charge assignments (Sri April 2, 1996)
	call chkcrg(natom,i_atinf,chrgv4,resnummax,isitsf)
c unformatted write...
	if(ipdbwrt) then
	open(20,file=updbnam(:updblen),form='unformatted')
	do i=1,natom
c	   xo(1)=atpos(1,i)
c	   xo(2)=atpos(2,i)
c	   xo(3)=atpos(3,i)
	   xo(1)=atpos(3*i-2)
	   xo(2)=atpos(3*i-1)
	   xo(3)=atpos(3*i)
	   rad=rad3(i)
	   chrgv=chrgv4(i)
	   write(20) xo,rad,chrgv
	end do
	close(20)
	end if
c
	if(iatout) then
c
          open(19,file=mpdbnam(:mpdblen))
c
          filnam = ' '
          inquire(19,name = filnam)
          write(6,*)
     &	  'atomic coordinates, charges and radii written to file'
          write(6,*)filnam
          write(6,*)'   '
	   if (mpdbfrm.eq.0) then
	     write(19,*)'DELPHI PDB FILE'
	     write(19,*)'FORMAT = 1', mpdbfrm
           write(19,*)'HEADER output from qdiff'
           write(19,*)'HEADER atom radii in columns 55-60'
           write(19,*)'HEADER atom charges in columns 61-67'
	   end if
	   if (mpdbfrm.eq.1) then
	     write(19,*)'DELPHI PDB FILE'
	     write(19,*)'FORMAT = PQR'
           write(19,*)'HEADER output from qdiff'
           write(19,*)'HEADER atom charges in columns 56-61'
           write(19,*)'HEADER atom radii   in columns 63-68'
	   end if
c
	line=' '
	if (mpdbfrm.eq.0) then
	line(1:11)="ATOM       "
	do i=1,natom
	  rad=rad3(i)
	  chrgv=chrgv4(i)
c	  xo(1)=atpos(1,i)
c	  xo(2)=atpos(2,i)
c	  xo(3)=atpos(3,i)
	  xo(1)=atpos(3*i-2)
	  xo(2)=atpos(3*i-1)
	  xo(3)=atpos(3*i)
	  line(12:26)=atinf(i)
	  write(radstr,206)rad,chrgv
	  write(crdstr,205)xo
	  line(55:67) = radstr
	  line(31:54) = crdstr
	  line(27:30)='    '
	  write(19,204)line
	end do
      end if
c ++++++++++++++WWW++++++++++
	if (mpdbfrm.eq.1) then
	line(1:6)="ATOM  "
	do i=1,natom
	  write(atmstr,208)i
	  line(7:11)=atmstr
	  rad=rad3(i)
	  chrgv=chrgv4(i)
	  xo(1)=atpos(3*i-2)
	  xo(2)=atpos(3*i-1)
	  xo(3)=atpos(3*i)
	  line(12:26)=atinf(i)
	  line(22:22)=' '
	  write(crdstr,205)xo
	  line(31:54) = crdstr
c      blank after coordinates
        line(55:55)=' '
c	  write(crgstr,207)chrgv,rad
	  write(str6,209)chrgv
        line(56:61) = str6
	  line(62:62)=' '
	  write(str6,209)rad
        line(63:68) = str6
c	  line(55:70) = crgstr
	  line(27:30)='    '
c      clear the chain identifier
	  write(19,204)line
	end do
      end if
207   format(F8.4,F8.3)
209   format(F6.3)
208   format(I5)
c ++++++++++++++WWW++++++++++
	close(19)
	end if
c
	if((natom.eq.0).and.(nobject.eq.0)) goto 903
	return
903	write(6,*) "exiting due to non-existence of atom file
     &  nor object data"
	return 1
	end


	SUBROUTINE RS_DLN2  ( bull, lenb, defalt, bindex, day, hour,
     +			      obtype, wspcod, iret )
C************************************************************************
C* RS_DLN2								*
C*									*
C* This subroutine decodes the second line in a bulletin and returns	*
C* the date, time, wind speed units code, and observation type.  The	*
C* date/time group should be coded YYGGi(w).				*
C*									*
C* RS_DLN2  ( BULL, LENB, DEFALT, BINDEX, DAY, HOUR, OBTYPE, WSPCOD,	*
C*	      IRET )							*
C* 									*
C* Input parameters:							*
C*	BULL		CHAR*		Bulletin			*
C*	LENB		INTEGER		Bulletin length			*
C*	DEFALT		INTEGER		Missing value code		*
C*									*
C* Input/output parameters:						*
C*	BINDEX		INTEGER		Pointer to 2nd line -> first ob	*
C*	DAY		INTEGER		Day of observations		*
C*	HOUR		INTEGER		Hour of observations		*
C*									*
C* Output parameters:							*
C*	OBTYPE		CHAR*4		Contents of bulletin		*
C*					 SMUS = United States synoptics	*
C*					 SMNA = Foreign synoptics	*
C*					 SHBY = Ship or buoy reports	*
C*					 CMAM = C-man platform reports	*
C*					 XXXX = Unknown type		*
C*	WSPCOD		INTEGER		Wind speed units code		*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 -2 = unsupported format	*
C*					 -1 = no data in bulletin	*
C*					  1 = unknown bulletin format	*
C*					  2 = unexp. length of time grp	*
C**									*
C* Log:									*
C* J. Nielsen/MIT	 2/89						*
C* F. Cuq/UCLA		 8/90	Integer*2 -> integer*4			*
C* J. Nielsen/TAMU	 2/92	Gempacized, made MMXX undecodeable	*
C************************************************************************
	CHARACTER*(*)	bull
	INTEGER		lenb, defalt
C*
	INTEGER		bindex, day, hour
C*
	CHARACTER*4	obtype
	INTEGER		wspcod, iret
C*
	INTEGER		shift, lindex, leng, dayin, hourin
	CHARACTER	line*80, word*4
C------------------------------------------------------------------------
	iret = 0
	initdx = bindex
	wspcod = defalt
C
C*	Check length of bulletin
C
	IF  ( bindex + 30 .gt. lenb )  THEN
	    iret = -1
	    RETURN
	ENDIF
C
C*	Find the second line of bulletin
C
	leng = INDEX ( bull ( bindex : bindex+79 ), CHAR(10) ) - 1
	line = bull ( bindex : bindex+leng-1 )
C
C*	Attempt to identify report
C
	IF  ( leng .gt. 25 )  THEN
C
C*	Too long for WMO line 2; better be a US synoptic ob
C
	    IF  ( obtype .eq. 'SMUS' )  RETURN
	    obtype = 'XXXX'
	    iret = 1
	    RETURN
	ENDIF
C
C*	Set return pointer to line 3
C
	bindex = bindex + leng + 1
C
C*	Read first word in second line; if none, better be US synoptic
C
	lindex = 1
	inum = 4
	CALL RS_GCHR ( line, lindex, leng, inum, shift, ier )
	IF  ( ier .lt. 0 )  THEN
	    IF  ( obtype .eq. 'SMUS' )  RETURN
	    obtype = 'XXXX'
	    iret = 1
	    RETURN
	ENDIF
	word = line ( lindex : lindex+3 )
C
C*	Determine report type
C
	IF  ( word .eq. 'BBXX' )  THEN
	    obtype = 'SHBY'
	ELSE IF  ( word .eq. 'AAXX' )  THEN
	    obtype = 'SMNA'
	ELSE IF  ( word .eq. 'CMAN' )  THEN
	    obtype = 'CMAN'
	ELSE IF  ( word .eq. 'MMXX' )  THEN
	    obtype = 'XXXX'
	    iret = -2
	    RETURN
	ELSE
	    obtype = 'XXXX'
	    iret = 1
	    RETURN
	ENDIF
C
C*	Find time group
C
	inum = 4
	CALL RS_GGRP ( line, lindex, leng, inum, shift, ier )
	IF  ( ier .lt. 0 )  THEN
	    iret = 2
	    RETURN
	ENDIF
	inum = 5
	CALL RS_GGRP ( line, lindex, leng, inum, shift, ier )
C
C*	If only four digits found, assume IIGG
C
	IF  ( ier .lt. 0 )  iret = 2
C
C*	Get day and hour, check for plausibility
C
	CALL RS_NUMD ( line ( lindex: ), 2, defalt, dayin, ier )
	IF  ( dayin .gt. 31 )  RETURN
	CALL RS_NUMD ( line ( lindex+2: ), 2, defalt, hourin, ier )
	IF  ( hourin .gt. 24 )  RETURN
	day = dayin
	hour = hourin
	IF  ( iret .eq. 2 )  RETURN
C
C*	Five digits, get wind speed units code
C
	CALL RS_NUMD ( line ( lindex+4: ), 1, defalt, wspcod, ier )
C
	RETURN
	END


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   EVB-QMDFF - RPMD molecular dynamics and rate constant calculations on
!               black-box generated potential energy surfaces
!
!   Copyright (c) 2021 by Julien Steffen (steffen@pctc.uni-kiel.de)
!                         Stefan Grimme (grimme@thch.uni-bonn.de) (QMDFF code)
!
!   Permission is hereby granted, free of charge, to any person obtaining a
!   copy of this software and associated documentation files (the "Software"),
!   to deal in the Software without restriction, including without limitation
!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!   and/or sell copies of the Software, and to permit persons to whom the
!   Software is furnished to do so, subject to the following conditions:
!
!   The above copyright notice and this permission notice shall be included in
!   all copies or substantial portions of the Software.
!
!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
!   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
!   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
!   THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
!   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
!   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
!   DEALINGS IN THE SOFTWARE.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!
!     function omega: calculates the inversion angle
!
!     part of QMDFF
!

real(kind=8) function omega (natoms,xyz,i,j,k,l)
use qmdff
implicit none
external::vecnorm
integer::ic,natoms,i,j,k,l
real(kind=8)::xyz(3,natoms),rd(3),re(3),rn(3)
real(kind=8)::rv(3),rnv,vecnorm,rkjn,rljn,rnn,rvn

do ic=1,3
   re(ic)=xyz(ic,i)-xyz(ic,j)
   rd(ic)=xyz(ic,k)-xyz(ic,j)
   rv(ic)=xyz(ic,l)-xyz(ic,i)
end do
!
!     apply periodic boundaries, if needed
!
if (periodic) then
   call box_image(re)
   call box_image(rd)
   call box_image(rv)
end if

call crossprod(re,rd,rn)
rnn=vecnorm(rn,3,1)
rvn=vecnorm(rv,3,1)

rnv=rn(1)*rv(1)+rn(2)*rv(2)+rn(3)*rv(3)
omega=asin( rnv )

return
end function omega


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine restarts(istep,nset,nload,nforc, nboun,nk,ne,
     &  nmpc,nalset,nmat,ntmat_,npmat_,norien,nam,nprint,mi,
     &  ntrans,ncs_,namtot,ncmat_,mpcfree,maxlenmpc,
     &  ne1d,ne2d,nflow,nlabel,iplas,
     &  nkon,ithermal,nmethod,iperturb,nstate_,nener,set,istartset,
     &  iendset,ialset,co,kon,ipkon,lakon,nodeboun,ndirboun,iamboun,
     &  xboun,ikboun,ilboun,ipompc,nodempc,coefmpc,labmpc,ikmpc,ilmpc,
     &  nodeforc,ndirforc,iamforc,xforc,ikforc,ilforc,nelemload,iamload,
     &  sideload,xload,elcon,nelcon,rhcon,nrhcon,
     &  alcon,nalcon,alzero,plicon,nplicon,plkcon,nplkcon,orname,orab,
     &  ielorien,trab,inotr,amname,amta,namta,t0,t1,iamt1,veold,
     &  ielmat,matname,prlab,prset,filab,vold,nodebounold,
     &  ndirbounold,xbounold,xforcold,xloadold,t1old,eme,
     &  iponor,xnor,knor,thicke,offset,iponoel,inoel,rig,
     &  shcon,nshcon,cocon,ncocon,ics,sti,
     &  ener,xstate,jobnamec,infree,irstrt,inpc,textpart,istat,n,
     &  key,prestr,iprestr,cbody,ibody,xbody,nbody,xbodyold,
     &  ttime,qaold,cs,mcs,output,physcon,ctrl,typeboun,iline,ipol,inl,
     &  ipoinp,inp,fmpc,tieset,ntie,tietol,ipoinpc,nslavs,t0g,t1g,nprop,
     &  ielprop,prop,mortar,nintpoint,ifacecount,islavsurf,pslavsurf,
     &  clearini,ier,vel,nef,velo,veloo,ne2boun,heading,network,
     &  irestartread)
!
      implicit none
!
      character*1 typeboun(*),inpc(*)
      character*4 output
      character*6 prlab(*)
      character*8 lakon(*)
      character*20 labmpc(*),sideload(*)
      character*66 heading(*)
      character*80 orname(*),amname(*),matname(*)
      character*81 set(*),prset(*),tieset(3,*),cbody(*)
      character*87 filab(*)
      character*132 jobnamec(*),textpart(16)
!
      integer istep,nset,nload,nforc,nboun,nk,ne,nmpc,nalset,nmat,
     &  ntmat_,npmat_,norien,nam,nprint,mi(*),ntrans,ncs_,
     &  namtot,ncmat_,mpcfree,ne1d,ne2d,nflow,nlabel,iplas,nkon,
     &  ithermal(*),nmethod,iperturb(*),nstate_,istartset(*),iendset(*),
     &  ialset(*),kon(*),ipkon(*),nodeboun(*),ndirboun(*),iamboun(*),
     &  ikboun(*),ilboun(*),ipompc(*),nodempc(*),ikmpc(*),ilmpc(*),
     &  nodeforc(*),ndirforc(*),iamforc(*),ikforc(*),ilforc(*),
     &  nelemload(*),iamload(*),nelcon(*),ipoinpc(0:*),
     &  nrhcon(*),nalcon(*),nplicon(*),nplkcon(*),ielorien(*),
     &  inotr(*),nprop,ielprop(*),mortar,nintpoint,ifacecount,
     &  namta(*),iamt1(*),ielmat(*),nodebounold(*),ndirbounold(*),
     &  iponor(*),knor(*),iponoel(*),inoel(*),rig(*),islavsurf(*),
     &  nshcon(*),ncocon(*),ics(*),infree(*),ier,network,
     &  nener,irestartstep,irestartread,irstrt(*),istat,n,i,key,
     &  iprestr,mcs,maxlenmpc,iline,ipol,inl,
     &  ipoinp(2,*),inp(3,*),ntie,ibody(*),nbody,nslavs,nef,
     &  ne2boun(2,*)
!
      real*8 co(*),xboun(*),coefmpc(*),xforc(*),xload(*),elcon(*),
     &  rhcon(*),alcon(*),alzero(*),plicon(*),plkcon(*),orab(*),
     &  trab(*),amta(*),t0(*),t1(*),prestr(*),veold(*),tietol(*),
     &  vold(*),xbounold(*),xforcold(*),xloadold(*),t1old(*),eme(*),
     &  xnor(*),thicke(*),offset(*),t0g(*),t1g(*),clearini(*),
     &  shcon(*),cocon(*),sti(*),ener(*),xstate(*),prop(*),
     &  ttime,qaold(2),cs(17,*),physcon(*),pslavsurf(*),
     &  ctrl(*),fmpc(*),xbody(*),xbodyold(*),vel(*),velo(*),veloo(*)
!
c      irestartread=0
      irestartstep=0
!
      do i=2,n
         if(textpart(i)(1:4).eq.'READ') then
            irestartread=1
         elseif(textpart(i)(1:5).eq.'STEP=') then
            read(textpart(i)(6:15),'(i10)',iostat=istat) irestartstep
            if(istat.gt.0) then
               call inputerror(inpc,ipoinpc,iline,
     &              "*RESTART%",ier)
               return
            endif
         elseif(textpart(i)(1:5).eq.'WRITE') then
            irstrt(1)=1
         elseif(textpart(i)(1:10).eq.'FREQUENCY=') then
            read(textpart(i)(11:20),'(i10)',iostat=istat) irstrt(1)
            if(istat.gt.0) then
               call inputerror(inpc,ipoinpc,iline,
     &              "*RESTART%",ier)
               return
            endif
         elseif(textpart(i)(1:7).eq.'OVERLAY') then
            irstrt(2)=1
         else
            write(*,*)
     &        '*WARNING in restarts: parameter not recognized:'
            write(*,*) '         ',
     &                 textpart(i)(1:index(textpart(i),' ')-1)
            call inputwarning(inpc,ipoinpc,iline,
     &"*RESTART%")
         endif
      enddo
!
      if(irestartread.eq.1) then
        call restartread(istep,nset,nload,nforc, nboun,nk,ne,
     &  nmpc,nalset,nmat,ntmat_,npmat_,norien,nam,nprint,mi,
     &  ntrans,ncs_,namtot,ncmat_,mpcfree,maxlenmpc,
     &  ne1d,ne2d,nflow,nlabel,iplas,
     &  nkon,ithermal,nmethod,iperturb,nstate_,nener,set,istartset,
     &  iendset,ialset,co,kon,ipkon,lakon,nodeboun,ndirboun,iamboun,
     &  xboun,ikboun,ilboun,ipompc,nodempc,coefmpc,labmpc,ikmpc,ilmpc,
     &  nodeforc,ndirforc,iamforc,xforc,ikforc,ilforc,nelemload,iamload,
     &  sideload,xload,elcon,nelcon,rhcon,nrhcon,
     &  alcon,nalcon,alzero,plicon,nplicon,plkcon,nplkcon,orname,orab,
     &  ielorien,trab,inotr,amname,amta,namta,t0,t1,iamt1,veold,
     &  ielmat,matname,prlab,prset,filab,vold,nodebounold,
     &  ndirbounold,xbounold,xforcold,xloadold,t1old,eme,
     &  iponor,xnor,knor,thicke,offset,iponoel,inoel,rig,
     &  shcon,nshcon,cocon,ncocon,ics,sti,
     &  ener,xstate,jobnamec,infree,irestartstep,prestr,iprestr,
     &  cbody,ibody,xbody,nbody,xbodyold,ttime,qaold,cs,mcs,
     &  output,physcon,ctrl,typeboun,fmpc,tieset,ntie,tietol,nslavs,
     &  t0g,t1g,nprop,ielprop,prop,mortar,nintpoint,ifacecount,
     &  islavsurf,pslavsurf,clearini,irstrt,vel,nef,velo,veloo,
     &  ne2boun,heading,network)
      endif
!
      call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl,
     &     ipoinp,inp,ipoinpc)
!
      return
      end


      subroutine corcon (bndval,thick ,namcon,itypc ,nobnd ,notims,
     *                   kmax  ,lstci ,nocon ,cgen  ,cadd  ,cmax  ,
     *                   cmin                                     )
!----- GPL ---------------------------------------------------------------------
!
!  Copyright (C)  Stichting Deltares, 2011-2016.
!
!  This program is free software: you can redistribute it and/or modify
!  it under the terms of the GNU General Public License as published by
!  the Free Software Foundation version 3.
!
!  This program is distributed in the hope that it will be useful,
!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!  GNU General Public License for more details.
!
!  You should have received a copy of the GNU General Public License
!  along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
!  contact: delft3d.support@deltares.nl
!  Stichting Deltares
!  P.O. Box 177
!  2600 MH Delft, The Netherlands
!
!  All indications and logos of, and references to, "Delft3D" and "Deltares"
!  are registered trademarks of Stichting Deltares, and remain the property of
!  Stichting Deltares. All rights reserved.
!
!-------------------------------------------------------------------------------
!  $Id: corcon.f 5717 2016-01-12 11:35:24Z mourits $
!  $HeadURL: https://svn.oss.deltares.nl/repos/delft3d/tags/6686/src/tools_gpl/nesthd2/packages/nesthd2/src/corcon.f $
!***********************************************************************
! Deltares                         marine and coastal management
!
! subroutine         : corcon
! version            : v1.0
! date               : July 1997
! programmer         : Theo van der Kaaij
!
! function           : Adjust transport bc. and determine deth averaged
!                      bc.
! limitations        :
! subroutines called :
!***********************************************************************

      integer      cgen   (  6   )

      real         thick  (kmax  ),
     *             cadd   (  6   ), cmax  (  6   ), cmin  (  6   )

      real         bndval (nobnd ,notims,kmax  ,lstci,2)

      character*20 namcon(lstci  + 2)
!
!----adjust boundary conditions
!
      nocon = 0
      do 10 icon = 1, lstci

         if (cgen (icon) .eq. 1) then
            nocon = nocon + 1
            namcon(nocon) = namcon(icon)

            do 20 ibnd = 1, nobnd
               do 20 isize = 1, 2
                  do 20 itim = 1, notims
                     do 20 k = 1, kmax
                        bndval(ibnd,itim,k,nocon,isize) =
     *                  bndval(ibnd,itim,k,icon ,isize) + cadd (icon)
                        bndval(ibnd,itim,k,nocon,isize) =
     *                  min(bndval(ibnd,itim,k,nocon,isize),cmax (icon))
                        bndval(ibnd,itim,k,nocon,isize) =
     *                  max(bndval(ibnd,itim,k,nocon,isize),cmin (icon))
   20       continue
        endif
   10 continue
!
!----determine depth-averaged boundary conditions (if requested)
!
      if (itypc .eq. 1) then
         do 30 ibnd = 1, nobnd
            do 30 isize = 1, 2
               do 30 itim = 1, notims
                  do 30 icon = 1, nocon
                     bndval (ibnd,itim,1,icon,isize) =
     *               bndval (ibnd,itim,1,icon,isize) * thick(1)
                     do 40 k = 2, kmax
                        bndval (ibnd,itim,1,icon,isize) =
     *                  bndval (ibnd,itim,1,icon,isize) +
     *                  bndval (ibnd,itim,k,icon,isize) * thick(k)
   40                continue

                     bndval (ibnd,itim,kmax,icon,isize) =
     *               bndval (ibnd,itim,1   ,icon,isize)
   30    continue
      endif

      return

      end


!
!***********************************************************************
!
      module Coupling_transform_cfg_LSLK
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                     last update: Oct 2015   *
!                                                                      *
!***********************************************************************
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      use Coupling_constants
      use Coupling_structures
      use Coupling_data
!-----------------------------------------------
!   R o u t i n e s
!-----------------------------------------------
      public  :: main_cfg_lslk
      public  :: count_nr_of_csfs_LK
      public  :: delete_cfg_expansions
      private :: form_list_nomach_csfs
      private :: form_csfs_LK
      private :: matrix_LS_LK
      private :: dotransform_LSLK
      private :: print_cfg_LSLK
      private :: equivalent_LSLK
!-----------------------------------------------
!   D e f i n i t i o n s
!-----------------------------------------------
      type::Ji_lists
         integer::nr_of_csf !serial number of csf_LS in csfs_LS
         type(list),dimension(:),pointer::Ji !i=1..nr_of_subc
      end type Ji_lists
!
      type:: cfg_Ji_lists
         integer::nr_of_subc
         integer::nr_of_nomach_csfs
         type(Ji_lists),dimension(:),pointer::csfs_Ji !i=1..nr_of_nomach_csfs
      end type cfg_Ji_lists
!
      type(expansion), public :: expansion_cfg_LS
      type(expansion), public :: expansion_cfg_LK
!
      type(list), private ::nomach_csfs_ls
      type(cfg_Ji_lists), private::cfg_Ji_structure
!-----------------------------------------------
!
contains
!
!***********************************************************************
!                                                                      *
      subroutine main_cfg_lslk(print_level)
!                                                                      *
!     This is managerial subroutine                                    *
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                     last update: Oct 2015   *
!                                                                      *
!***********************************************************************
      implicit none
      integer, intent(in) :: print_level
      integer::error
      integer::itype
      expansion_cfg_LK%nr_of_state=expansion_cfg_LS%nr_of_state
      call form_list_nomach_csfs
      itype=0
      call form_csfs_LK(itype)
      call dotransform_LSLK
      if(print_level.gt.1) call print_cfg_LSLK(2) ! 2-means print LS and LK expansions
      deallocate(nomach_csfs_ls%items, STAT = error)
      end subroutine main_cfg_lslk
!
!***********************************************************************
!                                                                      *
      subroutine count_nr_of_csfs_LK(nr_of_csfs)
!                                                                      *
!     This subroutine counts the number of oneconfigurational          *
!     expansion in LK coupling                                         *
!     (corresponding to the one in the JJ coupling "expansion_cfg_LS") *
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                     last update: Oct 2015   *
!                                                                      *
!***********************************************************************
      implicit none
      integer, intent(out):: nr_of_csfs
      integer::error
      integer::itype
      if(expansion_cfg_LS%csfs(1)%nosubc.lt.2) then
         write(*,*)                                                    &
            'ERROR at subroutine count_nr_of_csfs_LK: nosubc.lt.2'
         write(*,*)                                                    &
            '(you can not use LK coupling with less than 2 subshells)'
         write(*,*)'program is terminated'
         stop
      end if
      expansion_cfg_LK%nr_of_state=expansion_cfg_LS%nr_of_state
      call form_list_nomach_csfs
      itype=1
      call form_csfs_LK(itype)
      nr_of_csfs = expansion_cfg_LK%size
      if(associated(nomach_csfs_ls%items))                             &
                             deallocate(nomach_csfs_ls%items,STAT=error)
      end subroutine count_nr_of_csfs_LK
!
!***********************************************************************
!                                                                      *
      subroutine delete_cfg_expansions
!                                                                      *
!     This subroutine deallocates the arrays of                        *
!     oneconfigurational expansions "expansion_cfg_LK" and             *
!     "expansion_cfg_LS"                                               *
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                     last update: Oct 2015   *
!                                                                      *
!***********************************************************************
      integer::icsf
!
!write(iwrite_log,'(6x,a21)') 'delete_cfg_expansions'
!
!delete expansion_cfg_LK
      if(associated(expansion_cfg_LK%coeffs))                          &
                                      deallocate(expansion_cfg_LK%csfs)
      if(associated(expansion_cfg_LK%csfs)) then
         do icsf=1, expansion_cfg_LK%size
            if(associated(expansion_cfg_LK%csfs(icsf)%subc_cfg))       &
                        deallocate(expansion_cfg_LK%csfs(icsf)%subc_cfg)
            if(associated(expansion_cfg_LK%csfs(icsf)%subc))           &
                            deallocate(expansion_cfg_LK%csfs(icsf)%subc)
            if(associated(expansion_cfg_LK%csfs(icsf)%iM1))            &
                             deallocate(expansion_cfg_LK%csfs(icsf)%iM1)
            if(associated(expansion_cfg_LK%csfs(icsf)%iM2))            &
                             deallocate(expansion_cfg_LK%csfs(icsf)%iM2)
            if(associated(expansion_cfg_LK%csfs(icsf)%iJ))            &
                             deallocate(expansion_cfg_LK%csfs(icsf)%iJ)
         end do
         deallocate(expansion_cfg_LK%csfs)
      end if
      expansion_cfg_LK%size=0
      expansion_cfg_LK%nr_of_state=0
!
!delete expansion_cfg_LS
      if(associated(expansion_cfg_LS%coeffs))                          &
                                       deallocate(expansion_cfg_LS%csfs)
      if(associated(expansion_cfg_LS%csfs)) then
         do icsf=1, expansion_cfg_LS%size
            if(associated(expansion_cfg_LS%csfs(icsf)%subc_cfg))       &
                        deallocate(expansion_cfg_LS%csfs(icsf)%subc_cfg)
            if(associated(expansion_cfg_LS%csfs(icsf)%subc))           &
                            deallocate(expansion_cfg_LS%csfs(icsf)%subc)
            if(associated(expansion_cfg_LS%csfs(icsf)%iM1))            &
                             deallocate(expansion_cfg_LS%csfs(icsf)%iM1)
            if(associated(expansion_cfg_LS%csfs(icsf)%iM2))            &
                             deallocate(expansion_cfg_LS%csfs(icsf)%iM2)
            if(associated(expansion_cfg_LS%csfs(icsf)%iJ))            &
                             deallocate(expansion_cfg_LS%csfs(icsf)%iJ)
         end do
         deallocate(expansion_cfg_LS%csfs)
      end if
      expansion_cfg_LS%size=0
      expansion_cfg_LS%nr_of_state=0
!
!write(iwrite_log,'(6x,a25)') 'end delete_cfg_expansions'
!
      end subroutine delete_cfg_expansions
!
!***********************************************************************
!                                                                      *
      function equivalent_LSLK(csf1, csf2)   result(rez)
!                                                                      *
!     This function defines the "equivalency" of                       *
!     two csfs in LS coupling for the formation of LK csfs             *
!     (for notion of the "equivalency" see the                         *
!     description in the program)                                      *
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                     last update: Oct 2015   *
!                                                                      *
!***********************************************************************
      implicit none
      type(csf_LS) :: csf1, csf2
      logical :: rez
      integer::isubc
      rez = .true.
      if(csf1%nosubc.lt.2.or.csf2%nosubc.lt.2) then
         write(*,*)'ERROR at subroutine equivalent_LSLK: ',            &
                   'csf1%nosubc.lt.2.or.csf2%nosubc.lt.2'
         write(*,*)'(you can not use LK coupling with less than 2 ',   &
                   'subshells)'
         write(*,*)'program will be terminated'
         stop
      end if
      if(csf1%nosubc.eq.csf2%nosubc) then
         do isubc=1,csf1%nosubc-1
            if(.not.csf1%subc_cfg(isubc)==csf2%subc_cfg(isubc)) then
               rez=.false.
               exit
            else if(.not.csf1%subc(isubc)==csf2%subc(isubc)) then
               rez=.false.
               exit
            else if(.not.csf1%iM1(isubc)==csf2%iM1(isubc)) then
               rez=.false.
               exit
            else if(.not.csf1%iM2(isubc)==csf2%iM2(isubc)) then
               rez=.false.
               exit
            end if
         end do
         isubc=csf1%nosubc
         if(rez) then
            if(.not.csf1%subc_cfg(isubc)==csf2%subc_cfg(isubc))       &
                                                           rez=.false.
            if(.not.csf1%subc(isubc)==csf2%subc(isubc)) rez=.false.
            if(.not.csf1%iM1(isubc)==csf2%iM1(isubc)) rez=.false.
         end if
      else
         rez=.false.
      end if
      end function equivalent_LSLK
!
!***********************************************************************
!                                                                      *
      subroutine form_list_nomach_csfs
!                                                                      *
!     This subroutine form the list of serial numbers                  *
!     in "expansion_cfg_LS" of "nonequivalent" LS coupling csfs        *
!     (for notion of the "equivalency" see the                         *
!     description in the program)                                      *
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                     last update: Oct 2015   *
!                                                                      *
!***********************************************************************
      implicit none
      integer:: inomach_counter
      integer, dimension(:), pointer :: temp_list
      integer::icsf_LS, inew
      logical:: new_csf
!
      inomach_counter=0
      allocate(temp_list(expansion_cfg_LS%size))
!
      do icsf_LS=1,expansion_cfg_LS%size,1
         new_csf = .true.
         do inew = 1, inomach_counter, 1
            if(equivalent_LSLK(expansion_cfg_LS%csfs(icsf_LS),         &
              expansion_cfg_LS%csfs(temp_list(inew)))) new_csf = .false.
         end do
         if(new_csf) then
            inomach_counter = inomach_counter + 1
            if(inomach_counter.gt.expansion_cfg_LS%size) then
               write(*,*) 'stop at subroutine define_nomach: ',        &
                  'inomach_counter.gt.expansion_cfg_LS%size'
               stop
            end if
            temp_list(inomach_counter)= icsf_LS
         end if
      end do
!
      nomach_csfs_LS%list_size = inomach_counter
!
      allocate(nomach_csfs_LS%items(nomach_csfs_LS%list_size))
!
      do icsf_LS=1, nomach_csfs_LS%list_size, 1
         nomach_csfs_LS%items(icsf_LS) = temp_list(icsf_LS)
      end do
!
      deallocate(temp_list)
!----- print down data -----------
!write(iwrite_log, *)'Nonmaching csfs_LS:'
!write(iwrite_log, *)'       Nr.   icsf_nr '
!do icsf_LS=1, nomach_csfs_LS%list_size, 1
!	 write(iwrite_log, '(4x,i3,2x,i3)') icsf_LS, nomach_csfs_LS%items(icsf_LS)
!end do !icsf_LS
!write(iwrite_log, *)'  '
!
      end subroutine form_list_nomach_csfs
!
!***********************************************************************
!                                                                      *
      subroutine form_csfs_LK(itype)
!                                                                      *
!     This subroutine forms the oneconfigurational                     *
!     expansion in LK coupling "expansion_cfg_LK",                     *
!     correponding to the one in LS coupling "expansion_cfg_LS"        *
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                last update: February 2020   *
!                                                                      *
!***********************************************************************
      implicit none
!type(cfg_Ji_lists),intent(in)::cfg_Ji_structure
      integer:: itype !defines the type of execution
                      !itype=1 - to find the number
                      !of csfs_LK only,
                      !itype.ne.1 - perform full
                      !calculation
      integer :: inr_of_csfs_LK   !, icsf_nr
      integer :: icsf_LS, icsf_LK
      integer :: K, K_min, K_max, J, J_min,J_max
      integer :: isubc_aviable
      integer :: inosubc, isubc
      integer :: iJ_total
      integer :: inr_of_csf_in_expansion_LS
!
      isubc_aviable = 2
      if(expansion_cfg_LS%csfs(1)%nosubc.gt.isubc_aviable) then
         write(*,*) "is available =",isubc_aviable," we have =",       &
            expansion_cfg_LS%csfs(1)%nosubc
         write(*,*) 'STOP at subroutine define_number_of_csfs_LK ',    &
            'module transform_lsjj: cfg_Ji_structure%nr_of_subc.gt.',  &
            'isubc_aviable'
         stop
      end if
!
!write(*,*) '      subroutine form_csfs_LK'
!write(iwrite_log,*) '      subroutine form_csfs_LK'
!
      iJ_total=states%states(expansion_cfg_LS%nr_of_state)%J
!
      call define_number_of_csfs_LK(inr_of_csfs_LK)
!
      expansion_cfg_LK%size=inr_of_csfs_LK
      if(itype.ne.1) then
         allocate(expansion_cfg_LK%csfs(expansion_cfg_LK%size))
         allocate(expansion_cfg_LK%coeffs(expansion_cfg_LK%size))
         icsf_LK=0
         do icsf_LS=1, nomach_csfs_ls%list_size,1
            inr_of_csf_in_expansion_LS = nomach_csfs_ls%items(icsf_LS)
            inosubc = expansion_cfg_LS%csfs(                           &
                                     inr_of_csf_in_expansion_LS)%nosubc
            K_min = abs(expansion_cfg_LS%csfs(                         &
               inr_of_csf_in_expansion_LS)%iM1(inosubc) -              &
               expansion_cfg_LS%csfs(inr_of_csf_in_expansion_LS)%      &
               iM2(inosubc-1))
            K_max=abs(expansion_cfg_LS%csfs(                           &
               inr_of_csf_in_expansion_LS)%iM1(inosubc) +              &
               expansion_cfg_LS%csfs(inr_of_csf_in_expansion_LS)%      &
               iM2(inosubc-1))
            do K= K_min, K_max, 2
               J_min = abs(K - expansion_cfg_LS%csfs(                  &
                  inr_of_csf_in_expansion_LS)%subc(inosubc)%iS)
               J_max=abs(K + expansion_cfg_LS%csfs(                    &
                  inr_of_csf_in_expansion_LS)%subc(inosubc)%iS)
               do J = J_min, J_max, 2
                  if(J.eq.iJ_total) then
                     icsf_LK = icsf_LK + 1
                     if(icsf_LK.gt.expansion_cfg_LK%size) then
                        stop
                        write(8,*) 'stop at subroutine form_csfs_LK: ',&
                           'icsf_nr.gt.expansion_cfg_LK%size'
                     end if
                     expansion_cfg_LK%csfs(icsf_LK)%nosubc=inosubc
                     allocate(expansion_cfg_LK%csfs(icsf_LK)%subc_cfg( &
                        expansion_cfg_LK%csfs(icsf_LK)%nosubc))
                     allocate(expansion_cfg_LK%csfs(icsf_LK)%subc(     &
                        expansion_cfg_LK%csfs(icsf_LK)%nosubc))
                     allocate(expansion_cfg_LK%csfs(icsf_LK)%iM1(      &
                        expansion_cfg_LK%csfs(icsf_LK)%nosubc))
                     allocate(expansion_cfg_LK%csfs(icsf_LK)%iM2(      &
                        expansion_cfg_LK%csfs(icsf_LK)%nosubc))
                     allocate(expansion_cfg_LK%csfs(icsf_LK)%iJ(       &
                        expansion_cfg_LK%csfs(icsf_LK)%nosubc))
                     expansion_cfg_LK%csfs(icsf_LK)%iJ(                &
                     expansion_cfg_LK%csfs(icsf_LK)%nosubc) = 0
                     do isubc=1,expansion_cfg_LK%csfs(icsf_LK)%        &
                                                            nosubc-1,1
                        expansion_cfg_LK%csfs(icsf_LK)%iJ(isubc) = 0
                        expansion_cfg_LK%csfs(icsf_LK)%subc_cfg(isubc) &
                           = expansion_cfg_LS%csfs(                    &
                           inr_of_csf_in_expansion_LS)%subc_cfg(isubc)
                        expansion_cfg_LK%csfs(icsf_LK)%subc(isubc) =   &
                           expansion_cfg_LS%csfs(                      &
                           inr_of_csf_in_expansion_LS)%subc(isubc)
                        expansion_cfg_LK%csfs(icsf_LK)%iM1(isubc) =    &
                           expansion_cfg_LS%csfs(                      &
                           inr_of_csf_in_expansion_LS)%iM1(isubc)
                        expansion_cfg_LK%csfs(icsf_LK)%iM2(isubc) =    &
                           expansion_cfg_LS%csfs(                      &
                           inr_of_csf_in_expansion_LS)%iM2(isubc)
                     end do
                     isubc = expansion_cfg_LK%csfs(icsf_LK)%nosubc
                     expansion_cfg_LK%csfs(icsf_LK)%subc_cfg(isubc) =  &
                        expansion_cfg_LS%csfs(                         &
                        inr_of_csf_in_expansion_LS)%subc_cfg(isubc)
                     expansion_cfg_LK%csfs(icsf_LK)%subc(isubc) =      &
                        expansion_cfg_LS%csfs(                         &
                        inr_of_csf_in_expansion_LS)%subc(isubc)
                     expansion_cfg_LK%csfs(icsf_LK)%iM1(isubc) =       &
                        expansion_cfg_LS%csfs(                         &
                        inr_of_csf_in_expansion_LS)%iM1(isubc)
                     expansion_cfg_LK%csfs(icsf_LK)%iM2(isubc)= K
!
                  end if
               end do
            end do
         end do
!
      end if
!
!write(*,*) '      end subroutine form_csfs_LK'
!write(iwrite_log,*) '      end subroutine form_csfs_LK'
!
      contains
!
!***********************************************************************
!                                                                      *
         subroutine  define_number_of_csfs_LK(irez)
!                                                                      *
!     This subroutine defines the number of csfs in LK coupling        *
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                     last update: Oct 2015   *
!                                                                      *
!***********************************************************************
         implicit none
         integer, intent(out)::irez
         integer::K, K_min, K_max, J, J_min,J_max
         integer::isubc_aviable
         integer::icsf
         integer :: icsf_nr_in_expansion_cfg_LS, inosubc
         isubc_aviable = 2
         if(expansion_cfg_LS%csfs(1)%nosubc .gt. isubc_aviable) then
           write(*,*) 'STOP at subroutine define_number_of_csfs_LK ',  &
              'module transform_lsjj: cfg_Ji_structure%nr_of_subc.gt.',&
              'isubc_aviable'
           stop
         end if
         irez=0
         do icsf=1, nomach_csfs_ls%list_size,1
            icsf_nr_in_expansion_cfg_LS = nomach_csfs_ls%items(icsf)
            inosubc = expansion_cfg_LS%csfs(                           &
               icsf_nr_in_expansion_cfg_LS)%nosubc
            K_min = abs(expansion_cfg_LS%csfs(                         &
               icsf_nr_in_expansion_cfg_LS)%iM1(inosubc) -             &
               expansion_cfg_LS%csfs(icsf_nr_in_expansion_cfg_LS)%     &
               iM2(inosubc-1))
            K_max = abs(expansion_cfg_LS%csfs(                         &
               icsf_nr_in_expansion_cfg_LS)%iM1(inosubc) +             &
               expansion_cfg_LS%csfs(icsf_nr_in_expansion_cfg_LS)%     &
               iM2(inosubc-1))
            do K= K_min, K_max, 2
               J_min = abs(K - expansion_cfg_LS%csfs(                  &
                  icsf_nr_in_expansion_cfg_LS)%subc(inosubc)%iS)
               J_max = abs(K + expansion_cfg_LS%csfs(                  &
                  icsf_nr_in_expansion_cfg_LS)%subc(inosubc)%iS)
               do J = J_min, J_max, 2
                  if(J.eq.iJ_total) irez = irez + 1
               end do
            end do
         end do
         end subroutine  define_number_of_csfs_LK
      end subroutine form_csfs_LK
!
!***********************************************************************
!                                                                      *
      subroutine matrix_LS_LK(icsf_LS,icsf_LK,rez)
!                                                                      *
!     This subroutine calculates the transformation                    *
!     matrix element between two csfs  (in LS and LK couplings)        *
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                     last update: Oct 2015   *
!                                                                      *
!***********************************************************************
      implicit none
      integer,intent(in):: icsf_LS,icsf_LK
      real(kind=dp),intent(out)::rez
      integer::K, iSi, iS_i, iS_im1, iL_i, J
      integer::nosubc !number of subshells
      nosubc=expansion_cfg_LS%csfs(1)%nosubc
      rez = ZERO_dp
      if(equivalent_LSLK(expansion_cfg_LS%csfs(icsf_LS),               &
         expansion_cfg_LK%csfs(icsf_LK))) then
         iSi=expansion_cfg_LS%csfs(icsf_LS)%subc(nosubc)%iS
         iL_i=expansion_cfg_LS%csfs(icsf_LS)%iM1(nosubc)
         iS_i=expansion_cfg_LS%csfs(icsf_LS)%iM2(nosubc)
         iS_im1=expansion_cfg_LS%csfs(icsf_LS)%iM2(nosubc-1)
         K=expansion_cfg_LK%csfs(icsf_LK)%iM2(nosubc)
         J=states%states(expansion_cfg_LS%nr_of_state)%J
         call LKPER(0,0,iS_im1,iSi,iL_i,iS_i,J,iL_i,K,rez)
      end if
      end subroutine matrix_LS_LK
!
!***********************************************************************
!                                                                      *
      subroutine dotransform_LSLK
!                                                                      *
!     This subroutine calculates the weights of the                    *
!     expansions in the LK coupling                                    *
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                     last update: Oct 2015   *
!                                                                      *
!***********************************************************************
      implicit none
      real(kind=dp)::coeff_LK,coeff_LS, melement, sum_of_state
      integer::icsf_LS,icsf_LK
      melement=0.
      sum_of_state = 0.
      do icsf_LK=1,expansion_cfg_LK%size
         coeff_LK = 0.
         do icsf_LS=1, expansion_cfg_LS%size
            call matrix_LS_LK(icsf_LS,icsf_LK,melement)
            coeff_LS=expansion_cfg_LS%coeffs(icsf_LS)
            coeff_LK = coeff_LK + coeff_LS*melement
         end do
         if((dabs(coeff_LK)-dp_coeff_precision).gt.ONE_dp) then
            write(*,*)'possible error at subroutine dotransform_LSLK:',&
               ' coeff_LK=',coeff_LK
            write(iwrite_log,*)'possible error at subroutine ',        &
               'dotransform_LSLK: coeff_LK=',coeff_LK
         end if
         expansion_cfg_LK%coeffs(icsf_LK)= coeff_LK
         sum_of_state = sum_of_state + coeff_LK*coeff_LK
      end do
      if((sum_of_state-TWO_dp*dp_coeff_precision).gt.ONE_dp) then
         write(*,*)'possible error at subroutine dotransform_LSLK: ',  &
            'sum_of_state=',sum_of_state
         write(iwrite_log,*)'possible error at subroutine ',           &
            'dotransform_LSLK: sum_of_state=',sum_of_state
      end if
      end subroutine dotransform_LSLK
!
!***********************************************************************
!                                                                      *
      subroutine print_cfg_LSLK(itype)
!                                                                      *
!     This subroutine prints the oneconfigurational                    *
!     expansions to the unit "iwrite_cfg_expansions_LK"                *
!     (see module "Coupling_constants")                                *
!                                                                      *
!     Written by G. Gaigalas,                                          *
!     NIST                                     last update: Oct 2015   *
!                                                                      *
!***********************************************************************
      implicit none
      integer, intent(in) :: itype
      integer             :: icsf, isubc, j
      character(len=1)    :: CVAL
      character(len=4)    :: JVAL
!
!     LS - Coupling
!
      if(itype.gt.0) then
         write(iwrite_cfg_expansions_LK,*)  &
         '-------------------------------------'
         write(iwrite_cfg_expansions_LK,*)  &
         'state Nr.',expansion_cfg_LS%nr_of_state
         write(iwrite_cfg_expansions_LK,'(3x,a3,a4,a9,3x,f15.8)')    &
         'J =', JVAL(states%states(expansion_cfg_LS%nr_of_state)%J), &
         ' Energy =',states%states(expansion_cfg_LS%nr_of_state)%energy
         write(iwrite_cfg_expansions_LK,'(3x,a29,i2)')               &
         'expansion size (LS coupling): ', expansion_cfg_LS%size
         write(iwrite_cfg_expansions_LK,*)''
         if(associated(expansion_cfg_LS%csfs)) then
            do icsf=1,expansion_cfg_LS%size
               if(associated(expansion_cfg_LS%csfs(icsf)%subc_cfg)) then
                  if(icsf ==1)write(iwrite_cfg_expansions_LK,*)'csf Nr.'
                  if(expansion_cfg_LS%csfs(icsf)%nosubc == 1) then
                     write(iwrite_cfg_expansions_LK,                   &
                     '(1x,i5,3x,i2,a1,"(",i1,")",6x,a6,f10.7)') icsf,  &
                     expansion_cfg_LS%csfs(icsf)%subc_cfg(1)%in,       &
                    CVAL(1,expansion_cfg_LS%csfs(icsf)%subc_cfg(1)%il),&
                     expansion_cfg_LS%csfs(icsf)%subc_cfg(1)%iN_big,   &
                     'coeff:',expansion_cfg_LS%coeffs(icsf)
                  else if (expansion_cfg_LS%csfs(icsf)%nosubc == 2) then
                     write(iwrite_cfg_expansions_LK,                   &
                     '(1x,i5,3x,2(i2,a1,"(",i1,")"),6x,a6,f10.7)')icsf,&
                     (expansion_cfg_LS%csfs(icsf)%subc_cfg(j)%in,      &
                    CVAL(1,expansion_cfg_LS%csfs(icsf)%subc_cfg(j)%il),&
                     expansion_cfg_LS%csfs(icsf)%subc_cfg(j)%iN_big,   &
                     j=1,2),                                           &
                     'coeff:',expansion_cfg_LS%coeffs(icsf)
                  else
                    STOP &
                 'To many coupled shells in Coupling_transform_cfg_LSLK'
                  end if
               else
                  write(iwrite_cfg_expansions_LK,'(9x,a51)')   &
                  'expansion_cfg_LS%csfs(icsf)%subc_cfg NOT associated'
               end if
               if(associated(expansion_cfg_LS%csfs(icsf)%subc)  &
               .and.associated(expansion_cfg_LS%csfs(icsf)%iM1) &
               .and.associated(expansion_cfg_LS%csfs(icsf)%iM2)) then
                  if(expansion_cfg_LS%csfs(icsf)%nosubc == 1) then
                     write(iwrite_cfg_expansions_LK,                &
                     '(13x,i2,a1,i1)')                              &
                     expansion_cfg_LS%csfs(icsf)%subc(1)%iS+1,      &
                     CVAL(2,expansion_cfg_LS%csfs(icsf)%subc(1)%iL),&
                     expansion_cfg_LS%csfs(icsf)%subc(1)%inr
                  else if (expansion_cfg_LS%csfs(icsf)%nosubc == 2) then
                     write(iwrite_cfg_expansions_LK,                 &
                     '(12x,7(1x,i2,a1,i1))')                         &
                     (expansion_cfg_LS%csfs(icsf)%subc(j)%iS+1,      &
                      CVAL(2,expansion_cfg_LS%csfs(icsf)%subc(j)%iL),&
                      expansion_cfg_LS%csfs(icsf)%subc(j)%inr,       &
                      j=1,2),                                        &
                      expansion_cfg_LS%csfs(icsf)%iM2(2)+1,          &
                      CVAL(2,expansion_cfg_LS%csfs(icsf)%iM1(2))
                  end if
               else
                   write(iwrite_cfg_expansions_LK,'(9x,a63)') &
       'expansion_cfg_LS%csfs(icsf)%subc (or iM1 or iM2) NOT associated'
               end if
               write(iwrite_cfg_expansions_LK,*)' '
            end do
         else
            write(iwrite_cfg_expansions_LK,*) &
            'expansion_cfg_LS%csfs NOT associated'
         end if
      end if
!
!     LK - Coupling
!
      if(itype.gt.1) then
         write(iwrite_cfg_expansions_LK,*) &
         '-------------------------------------'
         write(iwrite_cfg_expansions_LK,*) &
         'state Nr.',expansion_cfg_LK%nr_of_state
         write(iwrite_cfg_expansions_LK,'(3x,a3,a4,a9,3x,f15.8)')    &
         'J =', JVAL(states%states(expansion_cfg_LK%nr_of_state)%J), &
         ' Energy =',states%states(expansion_cfg_LK%nr_of_state)%energy
         write(iwrite_cfg_expansions_LK,'(3x,a29,i2)')               &
         'expansion size (LK coupling): ', expansion_cfg_LK%size
         write(iwrite_cfg_expansions_LK,*)''
         if(associated(expansion_cfg_LK%csfs)) then
            do icsf=1,expansion_cfg_LK%size
               if(associated(expansion_cfg_LK%csfs(icsf)%subc_cfg)) then
                  if(icsf ==1)write(iwrite_cfg_expansions_LK,*)'csf Nr.'
                  if(expansion_cfg_LS%csfs(icsf)%nosubc == 1) then
                     write(iwrite_cfg_expansions_LK,                   &
                     '(1x,i5,3x,i2,a1,"(",i1,")",6x,a6,f10.7)') icsf,  &
                     expansion_cfg_LK%csfs(icsf)%subc_cfg(1)%in,       &
                    CVAL(1,expansion_cfg_LK%csfs(icsf)%subc_cfg(1)%il),&
                     expansion_cfg_LK%csfs(icsf)%subc_cfg(1)%iN_big,   &
                     'coeff:',expansion_cfg_LK%coeffs(icsf)
                  else if (expansion_cfg_LS%csfs(icsf)%nosubc == 2) then
                     write(iwrite_cfg_expansions_LK,                   &
                     '(1x,i5,3x,2(i2,a1,"(",i1,")"),6x,a6,f10.7)')icsf,&
                     (expansion_cfg_LK%csfs(icsf)%subc_cfg(j)%in,      &
                    CVAL(1,expansion_cfg_LK%csfs(icsf)%subc_cfg(j)%il),&
                     expansion_cfg_LK%csfs(icsf)%subc_cfg(j)%iN_big,   &
                     j=1,2),                                           &
                     'coeff:',expansion_cfg_LK%coeffs(icsf)
                  end if
               else
                  write(iwrite_cfg_expansions_LK,'(9x,a51)') &
                  'expansion_cfg_LK%csfs(icsf)%subc_cfg NOT associated'
               end if
               if(associated(expansion_cfg_LK%csfs(icsf)%subc)     &
                  .and.associated(expansion_cfg_LK%csfs(icsf)%iM1) &
                  .and.associated(expansion_cfg_LK%csfs(icsf)%iM2)) then
                  if(expansion_cfg_LS%csfs(icsf)%nosubc == 1) then
                     write(iwrite_cfg_expansions_LK,                &
                     '(12x,2(1x,i2,a1,i1))')                        &
                     expansion_cfg_LK%csfs(icsf)%subc(1)%iS+1,      &
                     CVAL(2,expansion_cfg_LK%csfs(icsf)%subc(1)%iL),&
                     expansion_cfg_LK%csfs(icsf)%subc(1)%inr
                  else if (expansion_cfg_LS%csfs(icsf)%nosubc == 2) then
                     write(iwrite_cfg_expansions_LK,                &
                     '(12x,2(1x,i2,a1,i1),3x,a1," [",a4,"]",a4)')   &
                     (expansion_cfg_LK%csfs(icsf)%subc(j)%iS+1,     &
                     CVAL(2,expansion_cfg_LK%csfs(icsf)%subc(j)%iL),&
                     expansion_cfg_LK%csfs(icsf)%subc(j)%inr,       &
                     j=1,2),                                        &
                     CVAL(2,expansion_cfg_LK%csfs(icsf)%iM1(2)),    &
                     JVAL(expansion_cfg_LK%csfs(icsf)%iM2(2)),      &
                     JVAL(states%states(expansion_cfg_LK%nr_of_state)%J)
                  end if
               else
                  write(iwrite_cfg_expansions_LK,'(9x,a63)') &
       'expansion_cfg_LK%csfs(icsf)%subc (or iM1 or iM2) NOT associated'
               end if
               write(iwrite_cfg_expansions_LK,*)' '
            end do
         else
            write(iwrite_cfg_expansions_LK,*) &
            'expansion_cfg_LK%csfs NOT associated'
         end if
            write(iwrite_cfg_expansions_LK,*) &
            '-------------------------------------'
      end if
      end subroutine print_cfg_LSLK
!
      end module Coupling_transform_cfg_LSLK