        SUBROUTINE UMD2F1 (CP, N, CPERM, RPERM, NZOFF,
     $          ITAIL, XTAIL, XX, XSIZE, XUSE, II, ISIZE, IUSE,
     $          ICNTL, CNTL, INFO, RINFO, NBLKS,
     $          AP, AI, AX, PRESRV, K1, AN, ANZ, PR, KEEP,
     $          RMAX, CMAX, TOTNLU, XRMAX, XRUSE, IOUT, XOUT)
        INTEGER XSIZE, ISIZE, N, ICNTL (20), INFO (40), XUSE, IUSE,
     $          ITAIL, XTAIL, II (ISIZE), CP (N+1), CPERM (N), NZOFF,
     $          AN, ANZ, RPERM (N), AI (ANZ), AP (AN+1), K1, PR (AN),
     $          NBLKS, KEEP (20), RMAX, CMAX, TOTNLU, XRMAX, XRUSE
        LOGICAL PRESRV, IOUT, XOUT
        DOUBLE PRECISION
     $          XX (XSIZE), AX (ANZ)
        DOUBLE PRECISION
     $          CNTL (10), RINFO (20)

C=== UMD2F1 ============================================================
C
C  Unsymmetric-pattern MultiFrontal Package (UMFPACK). Version 2.2d
C  Copyright (C) 1997, Timothy A. Davis, University of Florida, USA.
C  ALL RIGHTS RESERVED.
C  Joint work with Iain S. Duff, Rutherford Appleton Laboratory, UK.
C  July 7, 1997. Work supported by the National Science Foundation
C  (DMS-9223088 and DMS-9504974) and the State of Florida; and by CRAY
C  Research Inc. through the allocation of supercomputing resources.

C***********************************************************************
C* NOTICE:  "The UMFPACK Package may be used SOLELY for educational,   *
C* research, and benchmarking purposes by non-profit organizations and *
C* the U.S. government.  Commercial and other organizations may make   *
C* use of UMFPACK SOLELY for benchmarking purposes only.  UMFPACK may  *
C* be modified by or on behalf of the User for such use but at no time *
C* shall UMFPACK or any such modified version of UMFPACK become the    *
C* property of the User.  UMFPACK is provided without warranty of any  *
C* kind, either expressed or implied.  Neither the Authors nor their   *
C* employers shall be liable for any direct or consequential loss or   *
C* damage whatsoever arising out of the use or misuse of UMFPACK by    *
C* the User.  UMFPACK must not be sold.  You may make copies of        *
C* UMFPACK, but this NOTICE and the Copyright notice must appear in    *
C* all copies.  Any other use of UMFPACK requires written permission.  *
C* Your use of UMFPACK is an implicit agreement to these conditions."  *
C*                                                                     *
C* The MA38 Package in Release 12 of the Harwell Subroutine Library    *
C* (HSL) has equivalent functionality (and identical calling interface)*
C* as UMFPACK (the HSL has single and double precision versions only,  *
C* however).  It is available for commercial use.   Technical reports, *
C* information on HSL, and matrices are available via the World Wide   *
C* Web at http://www.cis.rl.ac.uk/struct/ARCD/NUM.html, or by          *
C* anonymous ftp at seamus.cc.rl.ac.uk/pub.  Also contact Dr. Scott    *
C* Roberts, Harwell Subroutine Library, B 552, AEA Technology,         *
C* Harwell, Didcot, Oxon OX11 0RA, England.                            *
C* telephone (44) 1235 434988, fax (44) 1235 434136                    *
C* email Scott.Roberts@aeat.co.uk, who will provide details of price   *
C* and conditions of use.                                              *
C***********************************************************************

C=======================================================================
C  NOT USER-CALLABLE.

C=======================================================================
C  DESCRIPTION:
C=======================================================================
C
C  UMD2F1 factorizes the n-by-n column-form matrix at the head of II/XX
C  or in Ap/Ai/Ax, and places its LU factors at the tail of II/XX.  The
C  input matrix overwritten if it is located in II/XX on input.  If
C  block-triangular-form (BTF) is in use, this routine factorizes a
C  single diagonal block.

C=======================================================================
C  INPUT:
C=======================================================================
C
C       n:              order of matrix (or order of diagonal block
C                       if BTF is in use).
C       Cp (1..n+1):    column pointers for input matrix
C       nblks:          number of diagonal blocks in BTF form
C       isize:          size of II
C       xsize:          size of XX
C       k1:             first index of this matrix (1 if BTF not used)
C       Icntl:          integer control parameters, see UMD21I
C       Cntl:           real control parameters, see UMD21I
C       Keep (6..8):    integer control parameters, see UMD21I
C       iuse:           memory usage in Index
C       xuse:           memory usage in Value
C       rmax:           maximum ludegr seen so far (see UMD2F2 for info)
C       cmax:           maximum ludegc seen so far (see UMD2F2 for info)
C       totnlu:         total number of LU arrowheads constructed so far
C
C       if nblks>1 then:
C          Cperm (1..n):        col permutation to BTF
C          Rperm (1..n):        row permutation to BTF
C       else
C          Cperm (1..n):        undefined on input
C          Rperm (1..n):        undefined on input
C
C
C       presrv:         if true then input matrix is preserved
C
C       if presrv is true then:
C           an:                 order of preserved matrix (all blocks)
C           anz:                entries in preserved matrix
C           Ap (1..an+1):       column pointers for preserved matrix
C           Ai (1..anz):        row indices of preserved matrix
C           Ax (1..anz):        values of preserved matrix
C                               The preserved matrix is not in BTF form;
C                               it is in the orginal order.
C           if nblks > 1:
C               Pr (1..n):      inverse row permutations to BTF form
C               nzoff           entries in off-diagonal blocks
C                               seen so far
C           else
C               Pr (1..n):      undefined on input
C
C           II (1..isize):      undefined on input
C           XX (1..xsize):      undefined on input
C           Cp (1..n+1):        undefined on input
C
C       else, if presrv is false:
C           an:                         1
C           anz:                        1
C           II (1..Cp (1) - 1):         unused
C           II (Cp (1) ... Cp (n+1)-1): row indices of matrix to factor,
C                                       will be overwritten on output
C           II (Cp (n+1) ... isize):    unused on input
C
C           XX (1..Cp (1) - 1):         unused
C           XX (Cp (1) ... Cp (n+1)-1): values of matrix to factorize,
C                                       will be overwritten on output
C           XX (Cp (n+1) ... xsize):    unused on input
C                       If BTF is in use, then II and XX contain a
C                       single diagonal block.

C=======================================================================
C  OUTPUT:
C=======================================================================
C
C       XX (xtail ... xsize), xtail,  II (itail ... isize), itail:
C
C                       The LU factors of a single diagonal block.
C                       See UMD2F2 for a description.
C
C       II (cp1 ... itail-1):   undefined on output
C       XX (cp1 ... xtail-1):   undefined on output,
C                       where cp1 is equal to the value of Cp (1)
C                       if presrv is false, or cp1 = 1 if presrv is
C                       true.
C
C       Info:           integer informational output, see UMD2FA
C       Rinfo:          real informational output, see UMD2FA
C       Cperm (1..n):   the final col permutations, including BTF
C       Rperm (1..n):   the final row permutations, including BTF
C
C       iuse:           memory usage in Index
C       xuse:           memory usage in Value
C       rmax:           maximum ludegr seen so far (see UMD2F2 for info)
C       cmax:           maximum ludegc seen so far (see UMD2F2 for info)
C       totnlu:         total number of LU arrowheads constructed so far
C
C       if nblks>1 and presrv:
C           nzoff       entries in off-diagonal blocks seen so far
C
C       iout:           true if ran out of integer memory in UMD2F1
C       xout:           true if ran out of real memory in UMD2F1

C=======================================================================
C  SUBROUTINES AND FUNCTIONS CALLED / CALLED BY:
C=======================================================================
C
C       called by subroutine:   UMD2F0
C       subroutines called:     UMD2F2
C       functions called:       MAX, SQRT
        INTRINSIC MAX, SQRT

C=======================================================================
C  LOCAL SCALARS:
C=======================================================================

        INTEGER CP1, PC, PEND, PCOL, CDEG, COL, CSIZ, NZ, XP, IP, IS, P,
     $          DN, DSIZ, WRKSIZ, I, CLEN, ROW, CSCAL
        PARAMETER (CSCAL = 9)

C  Original and expanded column-form:
C  ----------------------------------
C  cp1:     = value of Cp (1) on input
C  pc:      pointer to integer part of expanded column-form matrix
C  pend:    column col ends here in the input column-form matrix
C  pcol:    column col starts here in the input column-form matrix
C  cdeg:    degree (number of entries) in a column
C  clen:    number of original entries in a column (= degree, here,
C           but decreases in UMD2F2)
C  csiz:    size of the integer part of an expanded column (cdeg+cscal)
C  cscal:   = 9, the number of scalars in column data structure
C  nz:      number of entries in the diagonal block being factorized
C  xp:      pointer to real part of the expanded column
C  ip:      pointer to integer part of the expanded column
C
C  Memory usage:
C  -------------
C  wrksiz:  size of integer workspace needed by UMD2F2
C
C  "Dense" columns: (converted to a prior, or artificial, frontal mat.):
C  ----------------
C  dn:      number of "dense" columns
C  dsiz:    a column is "dense" if it has more than dsiz entries
C
C  Other:
C  ------
C  row:     row index
C  col:     a column index
C  i:       loop index
C  p:       pointer

C=======================================================================
C  EXECUTABLE STATEMENTS:
C=======================================================================

        IOUT = .FALSE.
        XOUT = .FALSE.

C-----------------------------------------------------------------------
C  count "dense" columns (they are treated as a priori frontal matrices)
C-----------------------------------------------------------------------

C       a column is "dense" if it has more than dsiz entries
        DSIZ = MAX (0, KEEP (7),
     $                 KEEP (8) * INT (SQRT (REAL (N))))
        DN = 0
        IF (PRESRV) THEN
           IF (NBLKS .EQ. 1) THEN
              DO 10 COL = 1, N
                 IF (AP (COL+1) - AP (COL) .GT. DSIZ) THEN
C                   this is a "dense" column
                    DN = DN + 1
                 ENDIF
10            CONTINUE
           ELSE
              DO 40 COL = 1, N
C                if col might be dense, check more carefully:
                 CDEG = AP (CPERM (COL) + 1)- AP (CPERM (COL))
                 IF (CDEG .GT. DSIZ) THEN
                    CDEG = 0
                    DO 20 P = AP (CPERM (COL)), AP (CPERM (COL) + 1) -1
                       ROW = PR (AI (P))
                       IF (ROW .GE. K1) THEN
                          CDEG = CDEG + 1
                          IF (CDEG .GT. DSIZ) THEN
C                            this is a "dense" column, exit out of loop
                             DN = DN + 1
                             GO TO 30
                          ENDIF
                       ENDIF
20                  CONTINUE
C                   loop exit label:
30                  CONTINUE
                 ENDIF
40            CONTINUE
           ENDIF
        ELSE
           DO 50 COL = 1, N
              IF (CP (COL+1) - CP (COL) .GT. DSIZ) THEN
C                this is a "dense" column
                 DN = DN + 1
              ENDIF
50         CONTINUE
        ENDIF

C-----------------------------------------------------------------------
C  get size of workspaces to allocate from II
C-----------------------------------------------------------------------

C       workspaces: WiR (n), WiC (n), WpR (n), WpC (n),
C       Wm (n), Head (n), Rp (n+dn), Wc (n+dn), Wr (n+dn), Wj (n)
        IF (NBLKS .EQ. 1) THEN
C          Rperm (1..n) is used as WiR (1..n), and
C          Cperm (1..n) is used as WiC (1..n) in UMD2F2
           WRKSIZ = 8*N + 3*DN
        ELSE
           WRKSIZ = 10*N + 3*DN
        ENDIF

C-----------------------------------------------------------------------
C  construct the expanded column-form of the matrix or the diag. block
C-----------------------------------------------------------------------

        IF (PRESRV) THEN

C          -------------------------------------------------------------
C          allocate space for wrksiz workspace and nz+cscal*n
C          integers and nz reals for the expanded column-form matrix.
C          -------------------------------------------------------------

           CP1 = 1
           XP = 1
           IP = 1 + WRKSIZ
           IF (NBLKS .EQ. 1) THEN

C             ----------------------------------------------------------
C             construct copy of entire matrix
C             ----------------------------------------------------------

              NZ = ANZ
              IS = NZ + WRKSIZ + CSCAL*N
              IUSE = IUSE + IS
              XUSE = XUSE + NZ
              INFO (18) = MAX (INFO (18), IUSE)
              INFO (19) = MAX (INFO (19), IUSE)
              INFO (20) = MAX (INFO (20), XUSE)
              INFO (21) = MAX (INFO (21), XUSE)
              IOUT = IS .GT. ISIZE
              XOUT = NZ .GT. XSIZE
              IF (IOUT .OR. XOUT) THEN
C                error return, if not enough integer and/or real memory:
                 GO TO 9000
              ENDIF

              PC = IP
              DO 70 COL = 1, N
                 CP (COL) = PC - WRKSIZ
                 CDEG = AP (COL+1) - AP (COL)
                 CLEN = CDEG
                 CSIZ = CDEG + CSCAL
                 II (PC) = CSIZ
                 II (PC+1) = CDEG
                 II (PC+5) = 0
                 II (PC+6) = CLEN
                 II (PC+7) = 0
                 II (PC+8) = 0
                 II (PC+2) = XP
                 XP = XP + CDEG
                 PC = PC + CSCAL
                 P = AP (COL)
                 DO 60 I = 0, CDEG - 1
                    II (PC + I) = AI (P + I)
60               CONTINUE
                 PC = PC + CDEG
70            CONTINUE
              DO 80 P = 1, NZ
                 XX (P) = AX (P)
80            CONTINUE

           ELSE

C             ----------------------------------------------------------
C             construct copy of a single block in BTF form
C             ----------------------------------------------------------

C             check for memory usage during construction of block
              DO 100 COL = 1, N
                 PC = IP
                 CP (COL) = PC - WRKSIZ
                 IP = IP + CSCAL
                 IOUT = IP .GT. ISIZE
                 IF (IOUT) THEN
C                   error return, if not enough integer memory:
                    GO TO 9000
                 ENDIF
                 II (PC+2) = XP
                 CDEG = IP
                 DO 90 P = AP (CPERM (COL)), AP (CPERM (COL)+1)-1
                    ROW = PR (AI (P))
                    IF (ROW .GE. K1) THEN
                       IOUT = IP .GT. ISIZE
                       XOUT = XP .GT. XSIZE
                       IF (IOUT .OR. XOUT) THEN
C                         error return, if not enough memory
                          GO TO 9000
                       ENDIF
                       II (IP) = ROW - K1 + 1
                       XX (XP) = AX (P)
                       IP = IP + 1
                       XP = XP + 1
                    ELSE
C                      entry in off-diagonal part
                       NZOFF = NZOFF + 1
                    ENDIF
90               CONTINUE
                 CDEG = IP - CDEG
                 CLEN = CDEG
                 CSIZ = CDEG + CSCAL
                 II (PC) = CSIZ
                 II (PC+1) = CDEG
                 II (PC+5) = 0
                 II (PC+6) = CLEN
                 II (PC+7) = 0
                 II (PC+8) = 0
100           CONTINUE

              NZ = XP - 1
              IS = NZ + WRKSIZ + CSCAL*N
              IUSE = IUSE + IS
              XUSE = XUSE + NZ
              INFO (18) = MAX (INFO (18), IUSE)
              INFO (19) = MAX (INFO (19), IUSE)
              INFO (20) = MAX (INFO (20), XUSE)
              INFO (21) = MAX (INFO (21), XUSE)

           ENDIF

C          -------------------------------------------------------------
C          get memory usage for next call to UMD2RF
C          -------------------------------------------------------------

           XRUSE = XRUSE + NZ
           XRMAX = MAX (XRMAX, XRUSE)

        ELSE

C          -------------------------------------------------------------
C          allocate space for wrksiz workspace and additional cscal*n
C          space for the expanded column-form of the matrix.
C          -------------------------------------------------------------

           CP1 = CP (1)
           NZ = CP (N+1) - CP1
           PC = CP1 + WRKSIZ + (NZ+CSCAL*N)
           IUSE = IUSE + WRKSIZ + CSCAL*N
           INFO (18) = MAX (INFO (18), IUSE)
           INFO (19) = MAX (INFO (19), IUSE)
           IOUT = PC .GT. ISIZE+1
           IF (IOUT) THEN
C             error return, if not enough integer memory:
              GO TO 9000
           ENDIF

C          -------------------------------------------------------------
C          expand the column form in place and make space for workspace
C          -------------------------------------------------------------

           XP = NZ + 1
           IP = NZ + CSCAL*N + 1
           PEND = CP (N+1)
           DO 120 COL = N, 1, -1
              PCOL = CP (COL)
              DO 110 P = PEND-1, PCOL, -1
                 PC = PC - 1
                 II (PC) = II (P)
110           CONTINUE
              PC = PC - CSCAL
              CDEG = PEND - PCOL
              CLEN = CDEG
              PEND = PCOL
              CSIZ = CDEG + CSCAL
              IP = IP - CSIZ
              CP (COL) = IP
              II (PC) = CSIZ
              II (PC+1) = CDEG
              II (PC+5) = 0
              II (PC+6) = CLEN
              II (PC+7) = 0
              II (PC+8) = 0
              XP = XP - CDEG
              II (PC+2) = XP
120        CONTINUE
        ENDIF

C-----------------------------------------------------------------------
C  factorize the expanded column-form, with allocated workspaces
C-----------------------------------------------------------------------

        XP = CP1
        IP = CP1 + WRKSIZ

        IF (NBLKS .EQ. 1) THEN

C          pass Rperm and Cperm as the WiR and WiC arrays in UMD2F2:
           CALL UMD2F2 (CP, NZ, N, 1, 1, 1, ITAIL, XTAIL,
     $          XX (XP), XSIZE-XP+1, II (IP), ISIZE-IP+1, ICNTL, CNTL,
     $          INFO, RINFO, .FALSE., IUSE, XUSE,
     $          RPERM, CPERM, II (CP1), II (CP1+N),
     $          II (CP1+2*N), II (CP1+3*N), II (CP1+4*N), II (CP1+5*N),
     $          II (CP1+6*N+DN), II (CP1+7*N+2*DN),
     $          DN, DSIZ, KEEP, RMAX, CMAX, TOTNLU, XRMAX, XRUSE)

        ELSE

C          pass Cperm, Rperm, WiC and WiR as separate arrays, and
C          change Cperm and Rperm from the BTF permutations to the
C          final permutations (including BTF and numerical pivoting).
           CALL UMD2F2 (CP, NZ, N, N, CPERM, RPERM, ITAIL, XTAIL,
     $          XX (XP), XSIZE-XP+1, II (IP), ISIZE-IP+1, ICNTL, CNTL,
     $          INFO, RINFO, .TRUE., IUSE, XUSE,
     $          II (CP1), II (CP1+N), II (CP1+2*N), II (CP1+3*N),
     $          II (CP1+4*N), II (CP1+5*N), II (CP1+6*N), II (CP1+7*N),
     $          II (CP1+8*N+DN), II (CP1+9*N+2*DN),
     $          DN, DSIZ, KEEP, RMAX, CMAX, TOTNLU, XRMAX, XRUSE)

        ENDIF

        IF (INFO (1) .LT. 0) THEN
C          error return, if error occured in UMD2F2:
           RETURN
        ENDIF

C-----------------------------------------------------------------------
C  adjust tail pointers, and save pointer to numerical part of LU
C-----------------------------------------------------------------------

C       head = cp1
        IUSE = IUSE - WRKSIZ
        ITAIL = ITAIL + IP - 1
        XTAIL = XTAIL + XP - 1
        II (ITAIL) = XTAIL
        RETURN

C=======================================================================
C  Error return
C=======================================================================

C       error return label:
9000    CONTINUE
        RETURN
        END


      real*8 lat,lon,sand,silt,bulk,dep,orgc,wilt,field,satw
      integer i

      open(11,file='data_old.dat')
      open(21,file='data.dat')

      wilt = -999.0
      orgc = -999.0
      field = -999.0
      satw = -999.0
      bulk = -999.0

      do i=1,64800
        read(11,*) lat,lon,sand,silt,bulk,dep
        if (dep.lt.0.0000001) dep = -999.0d0
        write(21,'(f7.3,f9.3,14f10.4)') lat,lon,sand,silt,
     &bulk,orgc,wilt,field,satw,dep
      enddo

      stop
      end


      module rrsw_kg26

      use shr_kind_mod, only: r8 => shr_kind_r8

!      use parkind ,only : jpim, jprb
      use parrrsw, only : ng26

      implicit none
      save

!-----------------------------------------------------------------
! rrtmg_sw ORIGINAL abs. coefficients for interval 26
! band 26: 22650-29000 cm-1 (low - nothing; high - nothing)
!
! Initial version:  JJMorcrette, ECMWF, oct1999
! Revised: MJIacono, AER, jul2006
!-----------------------------------------------------------------
!
!  name     type     purpose
!  ----   : ----   : ---------------------------------------------
!sfluxrefo: real
! raylo   : real
!-----------------------------------------------------------------

      integer, parameter :: no26 = 16

      real(kind=r8) :: sfluxrefo(no26)
      real(kind=r8) :: raylo(no26)

!-----------------------------------------------------------------
! rrtmg_sw COMBINED abs. coefficients for interval 26
! band 26: 22650-29000 cm-1 (low - nothing; high - nothing)
!
! Initial version:  JJMorcrette, ECMWF, oct1999
! Revised: MJIacono, AER, jul2006
!-----------------------------------------------------------------
!
!  name     type     purpose
!  ----   : ----   : ---------------------------------------------
! sfluxref: real
! rayl    : real
!-----------------------------------------------------------------

      real(kind=r8) :: sfluxref(ng26)
      real(kind=r8) :: rayl(ng26)

      end module rrsw_kg26


*----------------------------------------------------------------------*
      subroutine evpc_core(iter,
     &       task,iroute,xrsnrm,xeig,
     &       use_s,
     &       me_opt,me_trv,me_mvp,me_dia,me_met,me_scr,me_ext,
     &       me_special,nspecial,nextra,idxspc,
c     &       ffopt,fftrv,ffmvp,ffdia,
     &       nincore,lenbuf,
     &       xbuf1,xbuf2,xbuf3,
     &       flist,depend,
     &       fspc,nspcfrm,
     &       opti_info,opti_stat,
     &       orb_info,op_info,str_info,strmap_info)
*----------------------------------------------------------------------*
*     core driver for EVP solver
*----------------------------------------------------------------------*
      implicit none

      include 'stdunit.h'
c      include 'def_filinf.h'
      include 'mdef_operator_info.h'
      include 'def_file_array.h'
      include 'def_optimize_info.h'
      include 'def_optimize_status.h'
      include 'ifc_memman.h'
      include 'def_graph.h'
      include 'def_strinf.h'
      include 'def_strmapinf.h'
      include 'def_orbinf.h'
      include 'opdim.h'
      include 'def_contraction.h'
      include 'def_formula_item.h'
      include 'def_dependency_info.h'

      integer, parameter ::
     &     ntest = 000

      integer, intent(inout) ::
     &     task
      integer, intent(inout) ::
     &     iter
      integer, intent(in) ::
     &     iroute, nincore, lenbuf, nspecial, nextra, idxspc, nspcfrm
      logical, intent(in) ::
     &     use_s(*)

      type(me_list_array), intent(in) ::
     &     me_opt(*), me_dia(*),
     &     me_mvp(*), me_special(*), me_scr(*),me_ext(*)
      type(me_list_array), intent(inout) ::
     &     me_met(*), me_trv(*)
c      type(file_array), intent(in) ::
c     &     ffopt(*), fftrv(*), ffmvp(*), ffdia(*)

      type(formula_item), intent(inout) ::
     &     flist
      type(dependency_info) ::
     &     depend
      type(formula_item), intent(in) ::
     &     fspc(nspcfrm)

      type(optimize_info), intent(in) ::
     &     opti_info
      type(optimize_status), intent(inout), target ::
     &     opti_stat

      real(8), intent(inout) ::
     &     xrsnrm(opti_info%nroot,opti_info%nopt),
     &     xeig(opti_info%nroot,2)

      real(8), intent(inout) ::
     &     xbuf1(*), xbuf2(*), xbuf3(*)

      type(orbinf), intent(in) ::
     &     orb_info
      type(operator_info), intent(inout) ::
     &     op_info
      type(strinf), intent(in) ::
     &     str_info
      type(strmapinf) ::
     &     strmap_info

* local
      logical ::
     &     zero_vec(opti_stat%ndim_vsbsp), init, conv, trafo, getnewrec
      integer ::
     &     idx, jdx, kdx, iroot, nred, nadd, nnew, irecscr,idxdbg,
     &     imet, idamp, nopt, nroot, mxsub, lenmat, job,
     &     ndim_save, ndel, iopt, jopt, lenscr, ioff,
     &     ifree, restart_mode, ierr, nselect, irec, ioff_s
      real(8) ::
     &     cond, xdum, xnrm, xshf
      real(8), pointer ::
     &     gred(:), vred(:), mred(:), sred(:), eigr(:), eigi(:),
     &     xmat1(:), xmat2(:), xmat3(:), xvec(:), xret(:)
      integer, pointer ::
     &     ndim_rsbsp, ndim_vsbsp, ndim_ssbsp,
     &     iord_rsbsp(:), iord_vsbsp(:), iord_ssbsp(:),
     &     nwfpar(:), idxselect(:),
     &     ipiv(:), idxroot(:)
      type(file_array), pointer ::
     &     ffrsbsp(:), ffvsbsp(:), ffssbsp(:), ffscr(:), ffmet(:),
     &     ffext(:)
      type(filinf) ::
     &     fdum
      type(filinf), pointer ::
     &     ffspc
      type(filinf), target ::
     &     fdum2

      integer, external ::
     &     ioptc_get_sbsp_rec
      real(8), external ::
     &     dnrm2, ddot, xnormop

      if (ntest.ge.100)
     &     call write_title(lulog,wst_dbg_subr,'evpc_core entered')
      if (ntest.ge.100) write (lulog,*) "iteration ",iter
      zero_vec(1:opti_stat%ndim_vsbsp) = .false.
      nopt = opti_info%nopt
      nroot = opti_info%nroot
      mxsub = opti_stat%mxdim_sbsp
      mred => opti_stat%sbspmat(1:)
      vred => opti_stat%sbspmat(mxsub**2+1:)
      sred => opti_stat%sbspmat(2*mxsub**2+1:)
      ndim_rsbsp => opti_stat%ndim_rsbsp
      ndim_vsbsp => opti_stat%ndim_vsbsp
      ndim_ssbsp => opti_stat%ndim_ssbsp
      iord_rsbsp => opti_stat%iord_rsbsp
      iord_vsbsp => opti_stat%iord_vsbsp
      iord_ssbsp => opti_stat%iord_ssbsp
      ffscr => opti_stat%ffscr
      ffext => opti_stat%ffext
      ffrsbsp => opti_stat%ffrsbsp
      ffvsbsp => opti_stat%ffvsbsp
      ffssbsp => opti_stat%ffssbsp
      nwfpar => opti_info%nwfpar

      allocate(ffmet(nopt))

      ifree = mem_alloc_int(idxroot,nopt*nroot,'EVP_idxroot')

      if (ndim_vsbsp.ne.ndim_rsbsp)
     &     call quit(1,'evpc_core','subspace dimensions differ?')
c dbg
c      call optc_check_redsp(
c     &     ndim_vsbsp,ndim_vsbsp,nopt,
c     &     iord_vsbsp,ffvsbsp,
c     &     nincore,nwfpar,lenbuf,xbuf1,xbuf2,xbuf3)
c dbg
      nred = ndim_vsbsp
      do iopt = 1, nopt
        init = iopt.eq.1
        ! update reduced space:
        ! ffvsbsp and ffrsbsp point to ff_trv(iopt)%fhand ...
        if (.not.use_s(iopt)) then
!         if (nopt.ne.1) call quit(1,'evpc_core','not this route')
          call optc_update_redsp3
     &       (mred,xdum,nred,0,mxsub,
     &       opti_stat%nadd,opti_stat%ndel,init,
     &       iord_vsbsp,ffvsbsp(iopt)%fhand,
     &       iord_rsbsp,ffrsbsp(iopt)%fhand,fdum,
     &       nincore,nwfpar(iopt),lenbuf,xbuf1,xbuf2,xbuf3)
        else
          call optc_update_redsp4
     &       (mred,sred,xdum,nred,0,mxsub,
     &       opti_stat%nadd,opti_stat%ndel,init,
     &       iord_vsbsp,ffvsbsp(iopt)%fhand,
     &       iord_rsbsp,ffrsbsp(iopt)%fhand,
     &       iord_ssbsp,ffssbsp(iopt)%fhand,fdum,
     &       nincore,nwfpar(iopt),lenbuf,xbuf1,xbuf2,xbuf3)
        end if
      end do ! iopt
      ! ------------------------
      !    solve reduced EVP
      ! ------------------------

      ! allocate some scratch
      ! (automatically deallocated after leaving leq_evp_control() )
      lenmat = nred*nred
      ifree = mem_alloc_real(xmat1,lenmat,'EVP_mat1')
      ifree = mem_alloc_real(xmat2,lenmat,'EVP_mat2')
      ifree = mem_alloc_real(xmat3,lenmat,'EVP_mat3')
      ifree = mem_alloc_real(eigr,nred,'EVP_eig_r')
      ifree = mem_alloc_real(eigi,nred,'EVP_eig_i')
      ifree = mem_alloc_real(xvec,nred,'EVP_vec')

      ! get a copy of the subspace matrix
      kdx = 0
      do idx = 1, nred
        do jdx = 1, nred
          kdx = kdx+1
          xmat1(kdx) = mred((idx-1)*mxsub+jdx)
        end do
      end do
      kdx = 0
      do idx = 1, nred
        do jdx = 1, nred
          kdx = kdx+1
          xmat3(kdx) = sred((idx-1)*mxsub+jdx)
        end do
      end do

      if (.not.use_s(1)) then
        call eigen_asym(nred,xmat1,eigr,eigi,xmat2,xmat3,ierr)
      else
c dbg
c         print *,"debug: input to eigen_asym_met",
c         print *,
c dbgend
        call eigen_asym_met(nred,xmat1,xmat3,eigr,eigi,xmat2,xmat3,ierr)
      end if

      ! copy back to vred with mxsub as leading dim
      kdx = 0
      do idx = 1, nred
        do jdx = 1, nred
          kdx = kdx+1
          vred((idx-1)*mxsub+jdx) = xmat2(kdx)
        end do
      end do

      if (ntest.ge.50) then
        write(lulog,*) 'Eigenvalues in subspace:'
        do idx = 1, nred
          write(lulog,'(2x,i4,x,g20.12,x,g20.12)')
     &         idx, eigr(idx), eigi(idx)
        end do
        if (ntest.ge.100) then
          write(lulog,*) 'eigenvectors:'
          call wrtmat2(vred,nred,nred,mxsub,mxsub)
        end if
      end if

      xeig(1:nroot,1) = eigr(1:nroot)
      xeig(1:nroot,2) = eigi(1:nroot)

      irecscr = 1
      do iroot = 1, nroot
        ! assemble residual in full space

        do iopt = 1, nopt
          if (opti_info%typ_prc(iopt).eq.optinf_prc_traf) then
            ffspc => me_special(1)%mel%fhand
            trafo = .true.
          elseif (opti_info%typ_prc(iopt).eq.optinf_prc_traf_spc)then
             if (nspecial .lt. 4) call quit(1,'evpc_core',
     &            'TR0 with <4 me_lists')
             ffspc => me_special(4)%mel%fhand
             trafo = .true.
          else
            ffspc => ffscr(iopt)%fhand
            trafo = .false.
          end if
          ! M.v ....
          idx = (iroot-1)*mxsub + 1
          xvec(1:nred) = vred(idx:idx+nred-1)
          call optc_expand_vec(xvec,ndim_rsbsp,
     &                                     xrsnrm(iroot,iopt),.false.,
     &         ffspc,irecscr,0d0,ffrsbsp(iopt)%fhand,
     &         iord_rsbsp,
     &         nincore,nwfpar(iopt),lenbuf,xbuf1,xbuf2)

          xvec(1:nred) = -eigr(iroot)*xvec(1:nred)
          if (.not.use_s(iopt)) then
          ! - eig * v
            call optc_expand_vec(xvec,ndim_vsbsp,
     &                                    xrsnrm(iroot,iopt),.not.trafo,
     &       ffspc,irecscr,1d0,ffvsbsp(iopt)%fhand,
     &       iord_vsbsp,
     &           nincore,nwfpar(iopt),lenbuf,xbuf1,xbuf2)
          else
            ! - eig * S * v
            call optc_expand_vec(xvec,ndim_vsbsp,
     &                                    xrsnrm(iroot,iopt),.not.trafo,
     &           ffspc,irecscr,1d0,ffssbsp(iopt)%fhand,
     &           iord_ssbsp,
     &           nincore,nwfpar(iopt),lenbuf,xbuf1,xbuf2)
          end if

          ! if requested, transform residual
          if (trafo) then
            ! assign op. with list containing the scratch trial vector
            call assign_me_list(me_scr(iopt)%mel%label,
     &                          me_opt(iopt)%mel%op%name,op_info)
            ! use daggered transformation matrix if requested
            if (nspecial.ge.3)
     &         call assign_me_list(me_special(3)%mel%label,
     &                             me_special(3)%mel%op%name,op_info)
            ! calculate transformed residual
            allocate(xret(depend%ntargets),idxselect(depend%ntargets))
            nselect = 0
            call select_formula_target(idxselect,nselect,
     &                  me_trv(iopt)%mel%label,depend,op_info)
            if (opti_info%typ_prc(iopt).eq.optinf_prc_traf_spc)then
               call  switch_mel_record(me_special(4)%mel,irecscr)
            else
               call switch_mel_record(me_special(1)%mel,irecscr)
            endif

            call switch_mel_record(me_scr(iopt)%mel,irecscr)
            ! pretend that me_trv is not up to date
            call reset_file_rec(me_trv(iopt)%mel%fhand)
            call frm_sched(xret,flist,depend,idxselect,nselect,
     &             .true.,.false.,op_info,str_info,strmap_info,orb_info)
            ! residual norm (nselect should be 1):
            xrsnrm(iroot,iopt) = xret(idxselect(1))
            deallocate(xret,idxselect)

!     set all single excitations to zero if requestes
!     after long deliberation, I decided to also include V,V so one can be sure to include
!     **all** singular excitations even if T1 changes

            if (opti_info%typ_prc(iopt).eq.optinf_prc_traf_spc)then
               call set_blks(me_scr(iopt)%mel,"P,H|P,V|V,H|V,V",0d0)
               xrsnrm(iroot,iopt)=xnormop(me_scr(iopt)%mel)
            endif

c dbg
C            if (iopt .ne. 2) then
c            print *,'residual vector before transformation:'
c            call vec_from_da(ffspc,
c     &        irecscr,xbuf1,nwfpar(iopt))
c            do idx = 1, nwfpar(iopt)
c              print *,idx,xbuf1(idx)
c            end do
c            call print_list('transformed residual vector:',
c     &           me_scr(iopt)%mel,"LIST",
c     &           -1d0,0d0,
c     &           orb_info,str_info)
c            endif
c dbgend

          end if
        end do

        ! not yet converged? increase record counter
        conv = .true.
        do iopt = 1, nopt
          conv = conv.and.xrsnrm(iroot,iopt).lt.opti_info%thrgrd(iopt)
        end do
        if (.not.conv.and.iter.lt.opti_info%maxmacit) then
          idxroot(irecscr) = iroot
          irecscr = irecscr+1
        end if

      end do

      ! number of new directions
      nnew = irecscr-1
      if (nnew.gt.0) then

        ! reduced space exhausted?
        if (nred+nnew.gt.mxsub) then
          restart_mode = 0
          if (restart_mode.eq.0) then
            ! complete internal restart
            ! assemble orth. subspace exactly spanning the nroot
            ! currently best solution vectors
            call optc_minspace(
     &           iord_vsbsp,ffvsbsp,
     &           iord_rsbsp,ffrsbsp,
     &           iord_ssbsp,ffssbsp,use_s,
     &           vred,xdum,mred,sred,nred,nroot,0,mxsub,nopt,
     &           ffext,0,  ! only scratch
     &           nincore,nwfpar,lenbuf,xbuf1,xbuf2,xbuf3)
            ndim_vsbsp = nred
            ndim_rsbsp = nred
            ndim_ssbsp = nred
          else
!> @TODO implement evpc_core with restart possibility.
            call quit(1,'evpc_core','baustelle')
          end if

        end if

        ! divide new directions by preconditioner
        do iopt = 1, nopt
          select case(opti_info%typ_prc(iopt))
          case(optinf_prc_file,optinf_prc_traf,optinf_prc_traf_spc
     &         ,optinf_prc_spinp,optinf_prc_prj,optinf_prc_spinrefp)
            if (opti_info%typ_prc(iopt).eq.optinf_prc_traf) then
              ffspc => me_special(1)%mel%fhand
              trafo = .true.
            elseif (opti_info%typ_prc(iopt).eq.optinf_prc_traf_spc)then
               ffspc => me_special(4)%mel%fhand
               trafo = .true.
            else
              ffspc => ffscr(iopt)%fhand
              trafo = .false.
            end if
            if (nincore.ge.2) then
              call vec_from_da(
     &             me_dia(iopt)%mel%fhand,1,xbuf2,nwfpar(iopt))
              do iroot = 1, nnew
                call vec_from_da(ffscr(iopt)%fhand,iroot,xbuf1,
     &                           nwfpar(iopt))
                ! scale residual for numerical stability:

                xnrm = 0d0
                do jopt = 1, nopt
                  xnrm = xnrm+xrsnrm(idxroot(iroot),jopt)**2
                end do
                xnrm = sqrt(xnrm)
c dbg
c                print *,"xnorm:",xnrm
c dbgend
c                xnrm = 1d0
c dbg
c                print *,"precon not yet applied. "
c                do idxdbg = 1, nwfpar(iopt)
c                   print *,idxdbg,xbuf1(idxdbg)
c                end do
c dbgend
                xshf = -xeig(idxroot(iroot),1)
                call diavc(xbuf1,xbuf1,1d0/xnrm,xbuf2,xshf,nwfpar(iopt))
c dbg
c                print *,"debug shift:",xshf
c                print *,"precon applied. ",nwfpar(iopt),"entries"
c                do idxdbg = 1, nwfpar(iopt)
c                   print *,idxdbg,xbuf1(idxdbg),xbuf2(idxdbg)
c                end do
c dbgend
                if (nopt.eq.1) then
                  xnrm = dnrm2(nwfpar(iopt),xbuf1,1)
                  call dscal(nwfpar(iopt),1d0/xnrm,xbuf1,1)
                end if
                call vec_to_da(ffspc,iroot,xbuf1,
     &                         nwfpar(iopt))
              end do
            else
              do iroot = 1, nnew
c            ! request (nroot-iroot+1)th-last root
c            irec = ioptc_get_sbsp_rec(-nroot+iroot-1,
c     &         iord_vsbsp,ndim_vsbsp,mxsbsp)
                xnrm = 0d0
                do jopt = 1, nopt
                  xnrm = xnrm+xrsnrm(idxroot(iroot),jopt)**2
                end do
                xnrm = sqrt(xnrm)
                xshf = -xeig(idxroot(iroot),1)
                ! decrease xshf in first iteration
                if (iter .eq. 1) xshf=0.8d0*xshf
                call da_diavec(ffspc,iroot,0d0,
     &                   ffscr(iopt)%fhand,iroot,
     &                   1d0/xnrm,me_dia(iopt)%mel%fhand,
     &                   1,xshf,-1d0,
     &                   nwfpar(iopt),xbuf1,xbuf2,lenbuf)
              end do
            end if

            ! project out spin contaminations or other components?
            if (opti_info%typ_prc(iopt).eq.optinf_prc_spinp.or.
     &          opti_info%typ_prc(iopt).eq.optinf_prc_prj.or.
     &          opti_info%typ_prc(iopt).eq.optinf_prc_spinrefp) then
              ! assign op. with list containing the scratch trial vector
c dbg
c               print *, "assign ",me_scr(iopt)%mel%label," to ",
c     &              me_opt(iopt)%mel%op%name
c dbgend
              call assign_me_list(me_scr(iopt)%mel%label,
     &                            me_opt(iopt)%mel%op%name,op_info)
              do iroot = 1, nnew
                call switch_mel_record(me_scr(iopt)%mel,iroot)
                ! <--- below: normalize=.true. for nopt=1, although I do
                ! not see the reason for normalizing here ...
                if (opti_info%typ_prc(iopt).eq.optinf_prc_spinp) then
                  call spin_project(me_scr(iopt)%mel,
     &                                         me_special(idxspc)%mel,
     &                              fspc(1),opti_info%nwfpar(iopt),
     &                              xbuf1,xbuf2,nopt.eq.1,xnrm, !<--
     &                              opti_info,orb_info,
     &                              op_info,str_info,strmap_info)
                elseif (opti_info%typ_prc(iopt).eq.
     &                  optinf_prc_spinrefp)then
                  call spin_project(me_scr(iopt)%mel,
     &                                         me_special(idxspc)%mel,
     &                              fspc(2),opti_info%nwfpar(iopt),
     &                              xbuf1,xbuf2,nopt.eq.1,xnrm, !<--
     &                              opti_info,orb_info,
     &                              op_info,str_info,strmap_info)

                  call evaluate2(fspc(1),.false.,.false.,
     &                           op_info,str_info,strmap_info,orb_info,
     &                           xnrm,.false.)

                else
c dbg
c                  print *,"iopt=",iopt
c                  call print_list('projected vector:',
c     &                 me_scr(iopt)%mel,"NORM",
c     &                 -1d0,0d0,
c     &                 orb_info,str_info)
c dbgend
                  call evaluate2(fspc(1),.false.,.false.,
     &                 op_info,str_info,strmap_info,orb_info,
     &                 xnrm,.false.)
c dbg
c                  call print_list('projected vector:',
c     &                 me_scr(iopt)%mel,"NORM",
c     &                 -1d0,0d0,
c     &                 orb_info,str_info)
c dbgend
                end if
                ! no need to worry, if more components exist:
                if (nopt.eq.1.and.xnrm.lt.1d-12) call warn('evpc_core',
     &               'Nothing left after projection!')
              end do
              ! reassign op. with list containing trial vector
              call assign_me_list(me_trv(iopt)%mel%label,
     &                            me_opt(iopt)%mel%op%name,op_info)
            end if
          case(optinf_prc_blocked)
            if (nincore.lt.3)
     &           call quit(1,'evpc_core',
     &           'I need at least 3 incore vectors (prc_special)')
            do iroot = 1, nnew
              xnrm = 0d0
              do jopt = 1, nopt
                xnrm = xnrm+xrsnrm(idxroot(iroot),jopt)**2
              end do
              xnrm = sqrt(xnrm)
c              xnrm = 1d0
              call vec_from_da(ffscr(iopt)%fhand,iroot,xbuf1,
     &                         nwfpar(iopt))
              call dscal(nwfpar(iopt),1d0/xnrm,xbuf1,1)
              xshf = -xeig(idxroot(iroot),1)
              call optc_prc_special2(me_mvp(iopt)%mel,me_special,
     &                                                        nspecial,
     &                           me_opt(iopt)%mel%op%name,xshf,
     &                           nincore,xbuf1,xbuf2,xbuf3,lenbuf,
     &                           orb_info,op_info,str_info,strmap_info)
              call vec_to_da(ffscr(iopt)%fhand,iroot,xbuf1,
     &                       nwfpar(iopt))
            end do
          case default
            call quit(1,'evpc_core','unknown preconditioner type')
          end select

          ! if requested, transform new subspace vectors
          if (trafo) then
            ! use non-daggered transformation matrix if requested
            if (nspecial.ge.3)
     &         call assign_me_list(me_special(2)%mel%label,
     &                             me_special(2)%mel%op%name,op_info)
            ! assign op. with original list
            ! (to ensure proper spin symmetry if needed)
            call assign_me_list(me_opt(iopt)%mel%label,
     &                          me_opt(iopt)%mel%op%name,op_info)

            ! calculate transformed vector
            allocate(xret(depend%ntargets),idxselect(depend%ntargets))
            nselect = 0
            call select_formula_target(idxselect,nselect,
     &                  me_trv(iopt)%mel%label,depend,op_info)
            do iroot = 1, nnew
               if (opti_info%typ_prc(iopt).eq.optinf_prc_traf_spc)then
                  call  switch_mel_record(me_special(4)%mel,iroot)
               else
                  call switch_mel_record(me_special(1)%mel,iroot)
               endif

               call switch_mel_record(me_opt(iopt)%mel,iroot)
              ! pretend that me_trv is not up to date
              call reset_file_rec(me_trv(iopt)%mel%fhand)
              call frm_sched(xret,flist,depend,idxselect,nselect,
     &             .true.,.false.,op_info,str_info,strmap_info,orb_info)
              ! in reality me_trv is still up to date:
              call touch_file_rec(me_trv(iopt)%mel%fhand)
              ! copy to scr list and reassign
              call switch_mel_record(me_scr(iopt)%mel,iroot)
              call list_copy(me_opt(iopt)%mel,me_scr(iopt)%mel,.false.)
            end do
            call assign_me_list(me_scr(iopt)%mel%label,
     &                          me_opt(iopt)%mel%op%name,op_info)
            deallocate(xret,idxselect)
c dbg
c            print *,'back-transformed trial vector:'
c            call vec_from_da(me_scr(iopt)%mel%fhand,
c     &        me_scr(iopt)%mel%fhand%current_record,xbuf1,nwfpar(iopt))
c            do idx = 1, nwfpar(iopt)
c              print *,idx,xbuf1(idx)
c            end do
c            ! symmetrize!
c            if (nspecial.eq.3) then
c              call sym_ab_blk(xbuf2(2),xbuf1(2),0.5d0,dble(1),
c     &                        me_scr(iopt)%mel,2,
c     &                        str_info,strmap_info,orb_info)
c              xbuf2(1) = 0d0
c              print *,'back-transformed trial vector:'
c              do idx = 1, nwfpar(iopt)
c                print *,idx,xbuf2(idx)
c              end do
c              call vec_to_da(me_scr(iopt)%mel%fhand,
c     &         me_scr(iopt)%mel%fhand%current_record,xbuf2,nwfpar(iopt))
c            end if
c dbgend

            ! reassign op. with list containing trial vector
            call assign_me_list(me_trv(iopt)%mel%label,
     &                          me_opt(iopt)%mel%op%name,op_info)
          end if

        end do ! iopt

        do iroot = 1, nnew
          getnewrec = .true.
          do iopt = 1, nopt

            if (use_s(iopt)) then
              ! assign op. with list containing the scratch trial vector
              call assign_me_list(me_scr(iopt)%mel%label,
     &                          me_opt(iopt)%mel%op%name,op_info)

c dbg
c              call print_list("scratch trial vec", me_scr(iopt)%mel,
c     &             "NORM",0,0,orb_info,str_info)
c dbgend
              ! calculate metric * scratch trial vector
              allocate(xret(depend%ntargets),idxselect(depend%ntargets))
              nselect = 0
              call select_formula_target(idxselect,nselect,
     &                  me_met(iopt)%mel%label,depend,op_info)
              if (getnewrec) then
                irec = ioptc_get_sbsp_rec(0,iord_ssbsp,ndim_ssbsp,mxsub)
                if (iroot.eq.1) ioff_s = irec-1
                getnewrec = .false.
              end if

              call switch_mel_record(me_met(iopt)%mel,irec)
              call switch_mel_record(me_scr(iopt)%mel,iroot)
              call frm_sched(xret,flist,depend,idxselect,nselect,
     &            .true.,.false.,op_info,str_info,strmap_info,orb_info)
              ! apply sign-fix (if needed)
              call optc_fix_signs2(me_met(iopt)%mel%fhand,irec,
     &                             opti_info,iopt,
     &                             opti_info%nwfpar(iopt),xbuf1)
              call reset_file_rec(me_met(iopt)%mel%fhand)

              ! reassign op. with list containing trial vector
              call assign_me_list(me_trv(iopt)%mel%label,
     &                          me_opt(iopt)%mel%op%name,op_info)
              ffmet(iopt)%fhand => me_met(iopt)%mel%fhand
              deallocate(xret,idxselect)
            else
              ffmet(iopt)%fhand => fdum2
            end if

          end do ! iopt
        end do ! iroot

        ! orthogonalize new directions to existing subspace
        ! and add linear independent ones to subspace
        call optc_orthvec(nadd,nopt.gt.1,
     &                  ffssbsp,iord_ssbsp,sred,
     &                  ffvsbsp,iord_vsbsp,ndim_vsbsp,mxsub,zero_vec,
     &                  use_s,ioff_s,ffmet,ffscr,nnew,nopt,
     &                  nwfpar,nincore,xbuf1,xbuf2,xbuf3,lenbuf)
c dbg
c            print *,'orthogonalized trial vector:'
c            print *,'ndim= ',ndim_vsbsp!-1
c            call vec_from_da(ffvsbsp(1)%fhand,
cc     &        ndim_vsbsp-1,xbuf1,nwfpar(1))
c     &        ndim_vsbsp,xbuf1,nwfpar(1))
c            do idx = 1, nwfpar(1)
c              print *,idx,xbuf1(idx)
c            end do
c dbgend

        ! set nadd
        if (nadd.eq.0)
     &       call quit(0,'evpc_core',
     &       'solver in problems: only linear dependent '//
     &       'new directions?')
        opti_stat%nadd = nadd

        ! |Mv> subspace organisation should be identical to |v> subsp.
        ndim_rsbsp = ndim_vsbsp
        iord_rsbsp = iord_vsbsp
        ! dto. for |Sv> subspace ...
        ndim_ssbsp = ndim_vsbsp
        iord_ssbsp = iord_vsbsp

      else
        ! if all converged or last iteration: assemble vectors

        do iopt = 1, nopt
          do iroot = 1, nroot

            idx = (iroot-1)*mxsub + 1
            call optc_expand_vec(vred(idx),ndim_vsbsp,xdum,.false.,
     &           me_opt(iopt)%mel%fhand,iroot,0d0,
     &                              ffvsbsp(iopt)%fhand,iord_vsbsp,
     &           nincore,nwfpar(iopt),lenbuf,xbuf1,xbuf2)

          end do
        end do

      end if

      deallocate(ffmet)

      return
      end


!!  Copyright (C)  Stichting Deltares, 2012-2015.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License version 3,
!!  as published by the Free Software Foundation.
!!
!!  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 registered trademarks
!!  of Stichting Deltares remain the property of Stichting Deltares. All
!!  rights reserved.

!
! **********************************************************************
! * Begin subroutine to calculate solar intensity and efficiency       *
! * matrix for the phytoplankton model bloom ii                        *
! * the program has been updated most recently in december 2015        *
! * to be part of delwaq/bloom as a subroutine                         *
! * the user may specify the photosynthetic curves tablelized          *
! **********************************************************************
!
      subroutine bleffpro(lunrep, lunblm, nuecog, nz, zvec, fun, der)

      implicit none
      dimension power(51),solvec(51),rho(51,30),fun(51,30),der(51,30),
     1          sfirst(51),solar(51),time(51),cdf(51),freq(51),
     2          dens(51),tsol(51),tden(51),domf(51),rfirst(51,30),
     3          gfun(51),gder(51),zvec(51),daymul(24,30),dl(24)
      common/effcny/rho,power
      common/solrad/tsol,tden,freq,nval
      common/solval/delsol,solmax,day
      character*5 table
      character*265 inputfile
      character*265 outputfile
      integer lunblm, lunrep
      integer irc, npoint, i, j, k, nsp, nval, nz
      real*8 power, rho, solvec, time, solar, cdf, dens, freq, tsol, tden, domf
      real*8 rfirst, zvec, done, dneg, sfirst, gfun, gder, fun, der
      real*8 daymul, dl, delsol, solmax, day
!
      integer nuecog ! Number of groups
!
!  Read number of light intensity points
!  Read efficiency data for each ecogroup
!
      read (lunblm,*) npoint
!
!  Read in tables
!
   15 continue
      do 20 i=1,npoint
   20 read (lunblm,*) power(i),(rho(i,j),j=1,nuecog)
!
!  Read, integrate, and transform diurnal intensity distribution
!  Read number of points in solar radiation distribution
!
      read (lunblm,*) nsp
!
!  Read: solvec--solar radiation level; time--time of day
!
      read (lunblm,*) (solvec(k),time(k),k=1,nsp)
!
!  nval is the number of points desired in the transformed solar
!   radiation distribution function (max 50)
!
      nval=50
      call solcdf(solvec,time,nsp,nval,solar,cdf)
      call convrt(solar,cdf,nval,dens)
      call indist(nval,solar,dens,freq,tsol,tden)
!
!  Transform efficiency data
!
      call inteff(npoint,nuecog,domf,rfirst)
!
!  Determine appropriate tabulation points for convolution
!  nz is the number of points desired in the convolution (max 51)
!  Write convolution points into data set
!
      nz=51
      call zval(domf,npoint,tsol,nval,zvec,nz)
!
!  Compute convolutions and their derivatives
!  Calculate constants and determine roots for each order
!
      done = 1.0d0
      dneg = -1.0d0
      do 80 j=1,nuecog
      do 60 k=1,npoint
   60 sfirst(k)=rfirst(k,j)
      call cvolve(tsol,freq,nval,done,domf,sfirst,npoint,dneg,zvec,
     1            gfun,nz)
      call cvolve(domf,sfirst,npoint,dneg,tsol,tden,nval,done,zvec,
     1            gder,nz)
      do 70 k=1,nz
      fun(k,j)=gfun(k)
   70 der(k,j)=gder(k)
   80 continue
      return
      end subroutine
!
!  Subroutine to adjust lower end of efficiency data and transform it
!  to a logarithmic form
!
      subroutine inteff(npoint,nuecog,domf,rfirst)
      implicit none
      dimension effic(51,30),power(51),domf(51),rfirst(51,30),e(30)
      common/effcny/effic,power
      integer npoint, nuecog, i, j, i1
      real*8 power, p, effic, e, rfirst, domf
!
!  Move lower end of curve away from zero.
!
    1 if (power(1) .gt. 0.001*power(2)) go to 15
      p=0.001*power(2)
      call interm(power,effic,npoint,nuecog,p,e)
      do 12 j=1,nuecog
   12 effic(1,j)=e(j)
      power(1)=p
!
!  Transform intensity into its logarithmic form
!
   15 do 20 i=1,npoint
      i1=npoint-i+1
      do 18 j=1,nuecog
   18 rfirst(i,j)=effic(i1,j)
   20 domf(i)=-dlog(power(i1))
      return
      end
!
!  Subroutine to find cumulative distribution function
!
      subroutine solcdf(solvec,time,nsp,nval,solar,cdf)
      implicit none
      dimension solvec(51),time(51),cdf(51),solar(51),solna(51),
     1          solnb(51),timea(51),timeb(51),value(2)
      common/solval/delsol,solmax,day
      integer i, nsp, it, na, nb, j, jk, jkn, n, nval
      real*8 solmax, solvec, rn, delsol, day, time, solna, timea, solnb
      real*8 timeb, solar, cdf, rj, sol, value, dens, ri
!
!  Find maximum intensity
!
    1 solmax=solvec(1)
      do 5 i=1,nsp
    5 if (solvec(i) .gt. solmax) solmax=solvec(i)
!
!  SET CONSTANTS
!
      rn=nval-1
      delsol=solmax/rn
      day=time(nsp)-time(1)
!
!   SPLIT SOLAR RADIATION VECTOR INTO ASCENDING AND DESCENDING PARTS
!
      it=0
      i=1
   12 if (solvec(i) .eq. solmax) it=1
      solna(i)=solvec(i)
      timea(i)=time(i)
      if (it .eq. 1) go to 15
      i=i+1
      go to 12
   15 na=i
      nb=nsp-na+1
      do 18 j=1,nb
      jk=j-1
      jkn=nsp-jk
      solnb(j)=solvec(jkn)
   18 timeb(j)=time(jkn)
!
!  Calculate cdf for radiation function
!  Set endpoints of arrays
!
      solar(1)=0.0
      cdf(1)=0.0
!
!  Begin calculation of cdf
!
      do 20 j=2,nval
      rj=j-1
      sol=delsol*rj
      call interp(solna,timea,na,sol,value(1))
      call interp(solnb,timeb,nb,sol,value(2))
      cdf(j)=(value(1)-time(1)+time(nsp)-value(2))/day
   20 solar(j)=sol
      return
      end
!
!  Subroutine to convert cdf to probability density function
!
      subroutine convrt(solar,cdf,nval,dens)
      implicit none
      dimension solar(51),cdf(51),dens(51),value(2)
      common/solval/delsol,solmax,day
      integer i, n, nval, imin
      real*8 rj, sol, value, dens, ri, solc, delsol, soll, solu
      real*8 solar, cdf, solmax, day
!
!  Set constants and endpoints
!
    1 dens(1)=0.0
!
!  Iterate through intensity function
!  Determine density values
!
      n=nval-1
      do 10 i=2,n
      ri=i-1
      solc=delsol*ri
      if (i .eq. 2) go to 6
      value(1)=value(2)
      soll=solu
    4 solu=solc+0.5*delsol
      call interp(solar,cdf,nval,solu,value(2))
      go to 8
    6 soll=0.5*delsol
      call interp(solar,cdf,nval,soll,value(1))
      go to 4
    8 dens(i)=(value(2)-value(1))/delsol
   10 continue
      dens(nval)=(1.0-value(2))*2.0/delsol
      return
      end
!
!  Subroutine to integrate and normalize diurnal intensity
!  distribution, and compute mean intensity
!
      subroutine indist(nval,solar,dens,freq,tsol,tden)
      implicit none
      dimension solar(51),freq(51),dens(51),tsol(51),tden(51)
      integer i, nval
      real*8 solar, s, dens, d, freq, sbar, del, amult, tsol, tden
!
!  Move lower end of curve away from zero
!
      if (solar(1) .gt. 0.001*solar(2)) go to 15
      s=0.001*solar(2)
      call interp(solar,dens,nval,s,d)
      dens(1)=d
      solar(1)=s
!
!  Integrate to get cumulative distribution
!
   15 freq(1)=0.0
      sbar=0.0
      do 20 i=2,nval
      del=0.5*(solar(i)-solar(i-1))*(dens(i-1)+dens(i))
      freq(i)=freq(i-1)+del
   20 sbar=sbar+solar(i)*del
      amult=1.0/freq(nval)
      sbar=sbar*amult
!
!  Normalize distribution
!
      do 30 i=1,nval
      dens(i)=dens(i)*amult
      freq(i)=freq(i)*amult
      tsol(i)=dlog(solar(i)/sbar)
   30 tden(i)=solar(i)*dens(i)
      return
      end
!
!  Subroutine to determine z-values for convolutions
!
      subroutine zval(xvec,nx,yvec,ny,zvec,nz)
      implicit none
      dimension xvec(51),yvec(51),zvec(51),ix(51)
      integer i, nx, ix, nz1, nz, ny, n1, n2, j, k, imin, ixk
      real*8 rat, crat, xvec, yvec, zvec, smin, del

      do 10 i=1,nx
   10 ix(i)=1
      nz1=nz-1
      rat=(nx*ny-1)/nz1
      crat=0.0
      zvec(1)=xvec(1)+yvec(1)
      ix(1)=2
      zvec(nz)=xvec(nx)+yvec(ny)
      n2=0
!
!  Loop through desired number of z-values
!
      do 20 i=2,nz1
      n1=n2+1
      crat=crat+rat
      n2=crat+0.5
!
!  Loop through next "rat" potential z-values in ascending order
!
      do 15 j=n1,n2
      smin=zvec(nz)+1.0
      imin=0
      do 12 k=1,nx
      if (ix(k) .gt. ny) go to 12
      ixk=ix(k)
      if (xvec(k)+yvec(ixk) .ge. smin) go to 12
      smin=xvec(k)+yvec(ixk)
      imin=k
   12 continue
   15 ix(imin)=ix(imin)+1
!
!  Fill in next actual z-value
!
   20 zvec(i)=smin
!
!  Adjust for duplicates
!
      do 30 i=2,nz
      if (zvec(i) .gt. zvec(i-1)) go to 30
      do 25 j=i,nz
      if (zvec(j) .gt. zvec(i-1)) go to 26
   25 continue
   26 del =(zvec(j)-zvec(i-1))/(j-i)
      do 27 k=i,j
   27 zvec(k)=zvec(k-1)+del
   30 continue
      return
      end
!
!  Subroutine to convolve the functions f(x) and g(y)
!
      subroutine cvolve(xvec,fofx,nx,ax,yvec,gofy,ny,ay,zvec,
     1                  fstarg,nz)
      implicit none
      dimension xvec(51),fofx(51),yvec(51),gofy(51),zvec(51),
     1          fstarg(51)
      integer i, j, nx, ny, nz, ix, iy
      real*8 xvec, yvec, zvec, fofx, fstarg, bot, top
      real*8 ex1, ax, ex2, ey1, ay, ey2, f2, f1, g2, gofy, g1, d, s
      real*8 tmp, x
!
!  Add a convenience point to f(x).
!
      xvec(nx+1)=xvec(nx)+1.0
      fofx(nx+1)=fofx(nx)
      do 50 i=1,nz
      fstarg(i)=0.0
      iy=2
      bot=yvec(1)
      ix=nx
      do 1 j=1,nx
      if (zvec(i)-xvec(ix) .gt. yvec(1)) go to 20
    1 ix=ix-1
!
!  G-domain lies entirely to the right of inverted f-domain
!  integral must be zero
!
      go to 50
!
!  Integrate over the overlapping parts of f- and g-domains
!
   20 top=dmin1(yvec(iy),zvec(i)-xvec(ix))
      ex1=dexp(ax*xvec(ix))
      ex2=dexp(ax*xvec(ix+1))
      ey1=dexp(ay*yvec(iy))
      ey2=dexp(ay*yvec(iy-1))
      f2=(fofx(ix+1)-fofx(ix))/(ex2-ex1)
      f1=fofx(ix)-f2*ex1
      g2=(gofy(iy-1)-gofy(iy))/(ey2-ey1)
      g1=gofy(iy)-g2*ey1
      d=ay-ax
      s=f1*g1*(top-bot)+f1*g2*(dexp(ay*top)-dexp(ay*bot))/ay
     2 -f2*g1*(dexp(ax*(zvec(i)-top))-dexp(ax*(zvec(i)-bot)))/ax
     3 +f2*g2*dexp(ax*zvec(i))*(dexp(d*top)-dexp(d*bot))/d
      fstarg(i)=fstarg(i)+s
!
!  Update intervals and stop if x(1) or y(ny) has been reached
!
      if (top .ge. yvec(iy)) iy=iy+1
!
      tmp = zvec(i) - xvec(ix) - 1.0d-60
      if (top .ge. tmp) ix=ix-1
      if (iy .gt. ny) go to 50
      if (ix .lt. 1) go to 50
      bot=top
      go to 20
   50 continue
      return
      end
!
!  Subroutine to perform linear interpolations
!
      subroutine interp(xvec,fofx,n,x,f)
!
!  Performs a single linear interpolation
!
      implicit none
      dimension xvec(51),fofx(51),fofxm(51,30),fm(30)
      integer i, n
      real*8 x, xvec, f, fofx, fofxm, alam, fm
!
!  Check whether x is too low or too high
!
      if (x .gt. xvec(1)) go to 20
      f=fofx(1)
      return
   20 if (x .lt. xvec(n)) go to 40
      f=fofx(n)
      return
   40 do 60 i=2,n
      if (x .le. xvec(i)) go to 80
   60 continue
   80 alam=(x-xvec(i-1))/(xvec(i)-xvec(i-1))
      f=alam*fofx(i)+(1.0-alam)*fofx(i-1)
      return
      end
!
!  Entry for multiple value functions
!
      subroutine interm(xvec,fofxm,n,nuecog,x,fm)
      implicit none
      dimension xvec(51),fofx(51),fofxm(51,30),fm(30)
      integer i, j, n, nuecog
      real*8 x, xvec, fm, fofxm, alam, fofx
!
!  Check whether x is too low or too high
!
      if (x .gt. xvec(1)) go to 120
      do 110 j=1,nuecog
  110 fm(j)=fofxm(1,j)
      return
  120 if (x .lt. xvec(n)) go to 140
      do 130 j=1,nuecog
  130 fm(j)=fofxm(n,j)
      return
  140 do 160 i=2,n
      if (x .le. xvec(i)) go to 180
  160 continue
  180 alam=(x-xvec(i-1))/(xvec(i)-xvec(i-1))
      do 190 j=1,nuecog
  190 fm(j)=alam*fofxm(i,j)+(1.0-alam)*fofxm(i-1,j)
      return
      end


*dk,try2to2r
      subroutine try2to2r(nface,n2to2,
     *                    npoints,ntets,toldamage)

C ######################################################################
C
C     PURPOSE -
C
C        THIS ROUTINE ATTEMPTS TO FLIP CONNECTIONS ON REFLECTING
C        BOUNDARY PLANES.
C
C     INPUT ARGUMENTS -
C
C        nface   - THE NUMBER OF FACES IN THE "IRCLST" ARRAY
C
C     OUTPUT ARGUMENTS -
C
C        n2to2   - THE NUMBER OF BOUNDARY FLIPS PERFORMED
C
C     CHANGE HISTORY -
C
C        $Log: try2to2r.f,v $
C        Revision 2.00  2007/11/09 20:04:05  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.11   05 Jan 2001 12:58:18   dcg
CPVCS    use dble in place of float so as not to lose digits
CPVCS
CPVCS       Rev 1.10   Thu Oct 16 14:31:14 1997   kuprat
CPVCS    Added TOLDAMAGE feature where flips are rejected if their
CPVCS    damage exceeds TOLDAMAGE.
CPVCS
CPVCS       Rev 1.9   Mon Apr 14 17:05:04 1997   pvcs
CPVCS    No change.
CPVCS
CPVCS       Rev 1.8   Mon Jun 03 15:12:12 1996   dcg
CPVCS    hp changes
CPVCS
CPVCS       Rev 1.7   Fri May 17 09:16:48 1996   dcg
CPVCS    add mmgetblk for icontab
CPVCS
CPVCS       Rev 1.6   Mon May 06 12:26:42 1996   dcg
CPVCS    use itsttp to test for point types
CPVCS
CPVCS       Rev 1.5   Tue Apr 16 14:39:30 1996   dcg
CPVCS     replace pointer ipitets with array itets
CPVCS
CPVCS       Rev 1.4   02/10/95 08:27:52   het
CPVCS    Change the nfaces variable to nface because of cmo.h
CPVCS
CPVCS       Rev 1.3   12/02/94 15:07:08   het
CPVCS    Added an option for the "cmo" access functions
CPVCS
CPVCS
CPVCS       Rev 1.2   12/01/94 18:49:40   het
CPVCS    Added a data type to the "cmo" calles
CPVCS       and added the "cmo.h" include file.
CPVCS
CPVCS       Rev 1.1   11/17/94 21:55:26   het
CPVCS    Added include files for chydro, neibor, cmerge, comdict. Added calles and
CPVCS    pointer statements for current_mesh_object database access.
CPVCS
CPVCS       Rev 1.0   11/10/94 12:19:42   pvcs
CPVCS    Original version.
C
C ######################################################################
C
      implicit none
C
      include "cmo.h"
      include "chydro.h"
      include "neibor.h"
      include "cmerge.h"
      include "consts.h"

C arguments (nface,n2to2,npoints,ntets,toldamage)
      integer nface,n2to2,npoints,ntets
      real*8 toldamage

C variables

      integer id(8),jd(8),itets(301)

      pointer (ipicontab,icontab)
      integer icontab(50,*)

      integer i,j,k,i1,i2,i3,i4,i5,ip1,ip2,it,it2,ipos1
      integer ierror,length,icmotype,lenitp1,lenicr1,
     *        lenxic,lenyic,lenzic,lenitetclr,ier,lenitet,
     *        lenjtet,itwo,iface,n1,n2,n3,volit,n2to0,
     *        volit2,m,idup,icrnbr1,icrnbr2,icrnbr4,
     *        icrnbr5,j1,j2,j4,j5,irb1,irb2,irb4,irb5,
     *        ipos2,iflag,
     *        nflips,itx

      real*8  xn,yn,zn,sn,xnorm1,ynorm1,znorm1,snorm1,
     *        xnorm2,ynorm2,znorm2,snorm2,dot1,dot2,xst
      real*8 a124x,a124y,a124z,a215x,a215y,a215z,
     *       atotx,atoty,atotz,atot,xmid,ymid,zmid,
     *       dot124,dot215,dot4,dot5,dotmin,dotmax,
     *       damage,dist4,dist5

      logical itsttp
C
      real*8 crosx1,crosy1,crosz1,volume
      crosx1(i,j,k)=(yic(j)-yic(i))*(zic(k)-zic(i))-
     *              (yic(k)-yic(i))*(zic(j)-zic(i))
      crosy1(i,j,k)=(xic(k)-xic(i))*(zic(j)-zic(i))-
     *              (xic(j)-xic(i))*(zic(k)-zic(i))
      crosz1(i,j,k)=(xic(j)-xic(i))*(yic(k)-yic(i))-
     *              (xic(k)-xic(i))*(yic(j)-yic(i))
      volume(i1,i2,i3,i4)=(xic(i4)-xic(i1))*crosx1(i1,i2,i3)+
     *                    (yic(i4)-yic(i1))*crosy1(i1,i2,i3)+
     *                    (zic(i4)-zic(i1))*crosz1(i1,i2,i3)

      character*32 isubname
C
C ######################################################################
C BEGIN begin
C
C
C     ******************************************************************
C     FETCH MESH OBJECT NAME AND POINTER INFORMATION.
C
      if(icmoget.eq.1) then
C
      call cmo_get_name(cmo,ierror)
C
      call cmo_get_info('mbndry',cmo,mbndry,length,icmotype,ierror)
      call cmo_get_info('itp1',cmo,ipitp1,lenitp1,icmotype,ierror)
      call cmo_get_info('icr1',cmo,ipicr1,lenicr1,icmotype,ierror)
      call cmo_get_info('xic',cmo,ipxic,lenxic,icmotype,ierror)
      call cmo_get_info('yic',cmo,ipyic,lenyic,icmotype,ierror)
      call cmo_get_info('zic',cmo,ipzic,lenzic,icmotype,ierror)
      call cmo_get_info('itetclr',cmo,ipitetclr,lenitetclr,icmotype,ier)
      call cmo_get_info('itet',cmo,ipitet,lenitet,icmotype,ierror)
      call cmo_get_info('jtet',cmo,ipjtet,lenjtet,icmotype,ierror)
C
      endif
      call cmo_get_info('icontab',cmo,ipicontab,length,icmotype,ierror)
      if(ierror.ne.0) call x3d_error(isubname,'cmo_get_info')
C
C     ******************************************************************
C
C
c     ipitets=loc(itets)
C
      itwo=2
      xst=1.0e-11
      n2to2=0
C
C     ******************************************************************
C
C     ATTEMPT RECONNECTIONS ACROSS THE FACES
C
      do 100 i=1,nface
         iface=irclst(i)
C**JM    if(ijtet1(iface).le.0) goto 100
         it=0.25*dble(iface)+0.9
         if(kfix(1,it).ge.1.or.itet(1,it).le.0) goto 100
C
C        _______________________________________________________________
C
C        SKIP FACE IF IT IS A BOUNDARY FACE.
C
         ip2=jtet1(iface)
         if(ip2.ge.mbndry) goto 100
         i5=itet1(ip2)
         if(jtet1(ip2).ge.mbndry) goto 100
         i4=itet1(jtet1(ip2))
C
C        _______________________________________________________________
C
C        SKIP FACE UNLESS POINTS i4 AND i5 ARE ON REFLECTING BOUNDARY.
C
         icrnbr4=icr1(i4)
         icrnbr5=icr1(i5)
         if(icrnbr4.eq.0.or.icrnbr5.eq.0) goto 100
C
C        _______________________________________________________________
C
C        SKIP FACE IF EITHER TETRAHEDRON IS INVERTED.
C
         call face(iface,ip1,it,n2,n1,n3)
C**JM    if(kfix(1,it).ge.1) goto 100
         volit=volume(itet(1,it),itet(2,it),itet(3,it),itet(4,it))
         if(volit.le.0) goto 100
         it2=0.25*dble(jtet1(iface))+0.9
         volit2=volume(itet(1,it2),itet(2,it2),itet(3,it2),itet(4,it2))
         if(volit2.le.0) goto 100
C
C        _______________________________________________________________
C
C        FIND OTHER TWO POINTS ON EXTERNAL BOUNDARY AND TEST FOR
C        FURTHER GEOMETRIC RESTRICTIONS.
C
         do 50 m=1,3
            idup=0
            if(m.eq.1) then
               i1=n1
               i2=n2
               i3=n3
            elseif(m.eq.2) then
               i1=n2
               i2=n3
               i3=n1
            elseif(m.eq.3) then
               i1=n3
               i2=n1
               i3=n2
            endif
C
C           ............................................................
C
C           DO NOT BREAK AN EXTERNAL INTERFACE CONNECTION.
C
Cdcg        if(itp1(i1).eq.ifitpinb.and.itp1(i2).eq.ifitpinb) goto 50
            if (itsttp('intrface',itp1(i1)).and.
     *          itsttp('intrface',itp1(i2)))  go to 50
C
C           ............................................................
C
C           ENSURE THAT FACES OPPOSITE i3 ARE EXTERNAL BOUNDARY FACES.
C
            ipos1=4
            if(itet(1,it).eq.i3) then
               ipos1=1
            elseif(itet(2,it).eq.i3) then
               ipos1=2
            elseif(itet(3,it).eq.i3) then
               ipos1=3
            endif
            if(jtet(ipos1,it).ne.mbndry) goto 50
            ipos2=4
            if(itet(1,it2).eq.i3) then
               ipos2=1
            elseif(itet(2,it2).eq.i3) then
               ipos2=2
            elseif(itet(3,it2).eq.i3) then
               ipos2=3
            endif
            if(jtet(ipos2,it2).ne.mbndry) goto 50
C
C           ............................................................
C
C           ENSURE THAT POINTS i1, i2, i4, AND i5 LIE IN SAME
C           REFLECTING BOUNDARY PLANE.
C
            icrnbr1=icr1(i1)
            icrnbr2=icr1(i2)
            if(icrnbr1.eq.0.or.icrnbr2.eq.0) then
               goto 50
            else
               if(icrnbr2.ne.icrnbr1.or.icrnbr4.ne.icrnbr1.or.
     *            icrnbr5.ne.icrnbr1) then
                  do 200 j1=3,5
                     irb1=icontab(j1,icrnbr1)
                     do 210 j2=3,5
                        irb2=icontab(j2,icrnbr2)
                        if(irb2.eq.irb1) then
                           do 220 j4=3,5
                              irb4=icontab(j4,icrnbr4)
                              if(irb4.eq.irb1) then
                                 do 230 j5=3,5
                                    irb5=icontab(j5,icrnbr5)
                                    if(irb5.eq.irb1) goto 240
  230                            continue
                              endif
  220                      continue
                        endif
  210                continue
  200             continue
                  goto 50
  240             continue
                  if(irb1.eq.0) goto 50
               endif
            endif

c.... Check that the 'damage' of performing a flip is less than
c.... TOLDAMAGE.  The damage will be nonzero if the points i1, i2,
c.... i4, i5 do not all lie in the same plane.  The damage is defined
c.... in a similar fashion as in the subroutine AGD3D.

c.... Form aggregate normal:  Area-weighted normal formed from the
c.... two boundary triangles [triangle (i1,i2,i4) and triangle (i2,i1,i5)].

      a124x=crosx1(i1,i2,i4)
      a124y=crosy1(i1,i2,i4)
      a124z=crosz1(i1,i2,i4)
      a215x=crosx1(i2,i1,i5)
      a215y=crosy1(i2,i1,i5)
      a215z=crosz1(i2,i1,i5)
      atotx=a124x+a215x
      atoty=a124y+a215y
      atotz=a124z+a215z
      atot=sqrt(atotx**2+atoty**2+atotz**2)
      atotx=atotx/atot
      atoty=atoty/atot
      atotz=atotz/atot

c.... Calculate midpoint of edge (i1,i2)

      xmid=half*(xic(i1)+xic(i2))
      ymid=half*(yic(i1)+yic(i2))
      zmid=half*(zic(i1)+zic(i2))

c.... If both boundary triangle normals are in the same direction as
c.... aggregate normal, damage is defined to be separation between two
c.... planes (normal to agg. normal) that sandwich the points i1, i2,
c.... i3, i4.  If one of the boundary triangle normals points contrary
c.... to the agg. normal, damage is defined as minimum of 'merge
c.... distances' from the midpoint of edge (i1,i2) to the points i4, i5.

      dot124=a124x*atotx+a124y*atoty+a124z*atotz
      dot215=a215x*atotx+a215y*atoty+a215z*atotz

      if (dot124.gt.zero.and.dot215.gt.zero) then

         dot1=(xic(i1)-xmid)*atotx+(yic(i1)-ymid)*atoty+
     &      (zic(i1)-zmid)*atotz
         dot2=(xic(i2)-xmid)*atotx+(yic(i2)-ymid)*atoty+
     &      (zic(i2)-zmid)*atotz
         dot4=(xic(i4)-xmid)*atotx+(yic(i4)-ymid)*atoty+
     &      (zic(i4)-zmid)*atotz
         dot5=(xic(i5)-xmid)*atotx+(yic(i5)-ymid)*atoty+
     &      (zic(i5)-zmid)*atotz
         dotmin=min(dot1,dot2,dot4,dot5)
         dotmax=max(dot1,dot2,dot4,dot5)
         damage=dotmax-dotmin
         if (damage.gt.toldamage) goto 50

      else

         dist4=sqrt((xic(i4)-xmid)**2+(yic(i4)-ymid)**2+
     &      (zic(i4)-zmid)**2)
         dist5=sqrt((xic(i5)-xmid)**2+(yic(i5)-ymid)**2+
     &      (zic(i5)-zmid)**2)
         damage=min(dist4,dist5)
         if (damage.gt.toldamage) goto 50

      endif
C
C           ............................................................
C
C           PREVENT THIN TETRAHEDRA FROM FORMING.
C
            xn=xic(i5)-xic(i4)
            yn=yic(i5)-yic(i4)
            zn=zic(i5)-zic(i4)
            sn=sqrt(xn*xn+yn*yn+zn*zn)
            xnorm1=crosx1(i4,i1,i3)
            ynorm1=crosy1(i4,i1,i3)
            znorm1=crosz1(i4,i1,i3)
            snorm1=sqrt(xnorm1**2+ynorm1**2+znorm1**2)
            xnorm2=crosx1(i4,i3,i2)
            ynorm2=crosy1(i4,i3,i2)
            znorm2=crosz1(i4,i3,i2)
            snorm2=sqrt(xnorm2**2+ynorm2**2+znorm2**2)
            dot1=xn*xnorm1+yn*ynorm1+zn*znorm1
            dot2=xn*xnorm2+yn*ynorm2+zn*znorm2
            iflag=0
            if(dot1.ge.xst*sn*snorm1.and.
     *         dot2.ge.xst*sn*snorm2) iflag=1
            if(iflag.eq.0) goto 50
C
C           ............................................................
C
C           PERFORM THE FLIP
C
            call find2to2(it,it2,i1,i2,i3,i4,i5,id(1),jd(1),
     *                    npoints,ntets)
            call flip2to2(it,it2,id(1),jd(1),
     *                    npoints,ntets)
            n2to2=n2to2+1
            kfix(1,it)=it
            kfix(1,it2)=it2
C
C           ...........................................................
C
C           ATTEMPT A 2-TO-0 FLIP.
C
            itets(1)=it
            itets(2)=it2
            call try2to0(itets,itwo,nflips,itx,
     *                   npoints,ntets)
            n2to0=n2to0+nflips
C
C           ...........................................................
C
            goto 100
 50      continue
C
C        _______________________________________________________________
C
 100  continue
C
C     ******************************************************************
C
C     SET UP THE USUAL CFT IMMUNE STATEMENT 9999 IN CASE DDT IS NEEDED.
C
      goto 9999
 9999 continue
C
C     ******************************************************************
C
      return
      end