!
!     (c) 2019 Guide Star Engineering, LLC
!     This Software was developed for the US Nuclear Regulatory Commission (US NRC)
!     under contract "Multi-Dimensional Physics Implementation into Fuel Analysis under
!     Steady-state and Transients (FAST)", contract # NRC-HQ-60-17-C-0007
!
!
!    NEMO - Numerical Engine (for) Multiphysics Operators
! Copyright (c) 2007, Stefano Toninel
!                     Gian Marco Bianchi  University of Bologna
!              David P. Schmidt    University of Massachusetts - Amherst
!              Salvatore Filippone University of Rome Tor Vergata
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification,
! are permitted provided that the following conditions are met:
!
!     1. Redistributions of source code must retain the above copyright notice,
!        this list of conditions and the following disclaimer.
!     2. Redistributions in binary form must reproduce the above copyright notice,
!        this list of conditions and the following disclaimer in the documentation
!        and/or other materials provided with the distribution.
!     3. Neither the name of the NEMO project nor the names of its contributors
!        may be used to endorse or promote products derived from this software
!        without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
! ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
! WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
! ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
! (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
! ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
!---------------------------------------------------------------------------------
!
! $Id: rd_gambit_mesh.f90 3093 2008-04-22 14:51:09Z sfilippo $
!
! Description:
!    To be added...
!
SUBMODULE (tools_mesh) rd_gambit_implementation
    USE type_table, ONLY : table
    USE class_connectivity
    IMPLICIT NONE

CONTAINS

    MODULE PROCEDURE rd_gambit_mesh
        USE class_psblas
        USE class_cell
        !USE class_connectivity
        USE class_face
        USE class_vertex
        IMPLICIT NONE
        !
        INTEGER, PARAMETER :: nlen = 80
        !
        ! --- Local variables ---
        !
        ! Parameters
        LOGICAL, PARAMETER :: debug = .FALSE.
        INTEGER, PARAMETER :: mesh = 10
        !
        ! Local copies of V2F_, V2C_, F2C_ objects (connectivity class)
        TYPE(table) :: v2f_, v2c_, f2c_
        !
        ! Vertex-related variables
        INTEGER :: nverts
        LOGICAL, ALLOCATABLE :: on_boundary(:)
        REAL(psb_dpk_), ALLOCATABLE :: xv(:), yv(:), zv(:)
        !
        ! face-related variables
        INTEGER :: nfaces
        INTEGER, ALLOCATABLE :: fnv(:), imaster(:), islave(:), iflag(:)
        INTEGER, ALLOCATABLE :: facenv(:), facemaster(:), faceslave(:), faceflag(:)
        !
        ! cell-related variables
        INTEGER :: ncells
        INTEGER, ALLOCATABLE :: cellnv(:), cellnf(:), cellgroup(:)
        CHARACTER(len=3), ALLOCATABLE :: cellgeo(:)
        !
        ! Group-related variables
        INTEGER :: ngroups
        INTEGER, ALLOCATABLE :: groupnc(:), groupmat(:)
        CHARACTER(len=32), ALLOCATABLE:: groupname(:)
        TYPE(table) :: c2g_
        !
        ! BC-related variables
        INTEGER :: nbcfaces
        INTEGER, ALLOCATABLE :: bcnf(:)
        TYPE(table) :: f2b
        !
        ! Work variables
        LOGICAL :: found
        INTEGER :: i, i1, i2, info, j, j1, j2, k, l, m, n
        INTEGER :: ib, ic, ig, icl
        INTEGER :: IF, if1, if2
        INTEGER :: iv, iv1, iv2, iv3, iv4, iv5, iv6, iv7, iv8
        INTEGER, ALLOCATABLE :: perm(:), pinv(:)
        INTEGER, ALLOCATABLE :: aux(:,:), buf(:), work(:)
        CHARACTER(len=32) :: str
        TYPE(table) :: f2v, dmy
        INTEGER :: status
        ! ------------------------------------------------------------------

        WRITE(*,*) 'Importing mesh in .NEU format on P0'

        ! Opens file *.neu
        OPEN(unit=mesh,file=ADJUSTL(mesh_file),status='old',iostat=status)
        IF(status /=0 ) THEN
            WRITE(*,050) ADJUSTL(mesh_file)
            CALL abort_psblas
        ENDIF

        DO i = 1, 2
            READ (mesh,'()')
        END DO

        ! mesh ID and global parameters
        READ (mesh,500) mesh_id
        DO i = 1, 3
            READ (mesh,'()')
        END DO
        READ (mesh,510) nverts, ncells, ngroups, nbc, ncd
        READ (mesh,'()')

        ! Arrays allocation
        ALLOCATE (xv(nverts), yv(nverts), zv(nverts), &
            & cellnv(ncells), cellnf(ncells), cellgeo(ncells), cellgroup(ncells), &
            & stat=info)
        IF(info /= 0) THEN
            WRITE (*,100)
            CALL abort_psblas
        END IF

        ! Reads vertices coordinates
        IF(ncd == 2) zv(:) = 0.d0
        READ (mesh,'()')
        DO  iv = 1, nverts
            READ (mesh,520) i, xv(iv), yv(iv), zv(iv)
        END DO
        READ (mesh,'()')

        ! Reads cells connections
        ! WARNING: connections of PYRAMIDS and HEXAEDRA are changed in order to
        ! make them consistent with the CGNS-SIDS standard
        IF(ncd == 2) THEN
            n = 4 * ncells
        ELSE IF(ncd == 3) THEN
            n = 8 * ncells
        END IF
        ALLOCATE(work(n),stat=info)
        IF(info /= 0) THEN
            WRITE(*,100)
            CALL abort_psblas
        END IF

        CALL v2c_%alloc_table(nel=ncells)

        READ (mesh,'()')
        i1 = 1; i2 = 0; v2c_%lookup(1) = 1
        DO ic = 1, ncells

            READ(mesh,530,advance='no') i, j, k

            cellnv(ic) = k
            i2 = i1 + cellnv(ic) - 1

            SELECT CASE(j)
            CASE(2)
                cellnf(ic) = 4
                cellgeo(ic) = 'qua'
                READ(mesh,540) work(i1:i2)
            CASE(3)
                cellnf(ic) = 3
                cellgeo(ic) = 'tri'
                READ(mesh,540) work(i1:i2)
            CASE(4)
                cellnf(ic) = 6
                cellgeo(ic) = 'hex'
                READ(mesh,540) work(i1:i2)
                iv3 = work(i1+2)
                iv4 = work(i1+3)
                iv7 = work(i1+6)
                iv8 = work(i1+7)
                work(i1+2) = iv4
                work(i1+3) = iv3
                work(i1+6) = iv8
                work(i1+7) = iv7
            CASE(5)
                cellnf(ic) = 5
                cellgeo(ic) = 'pri'
                READ(mesh,540) work(i1:i2)
            CASE(6)
                cellnf(ic) = 4
                cellgeo(ic) = 'tet'
                READ(mesh,540) work(i1:i2)
            CASE(7)
                cellnf(ic) = 5
                cellgeo(ic) = 'pyr'
                READ(mesh,540) work(i1:i2)
                iv3 = work(i1+2)
                iv4 = work(i1+3)
                work(i1+2) = iv4
                work(i1+3) = iv3
            END SELECT
            i1 = i2 + 1
            v2c_%lookup(ic+1) = i1
        END DO
        CALL v2c_%alloc_table(ntab=i2)

        v2c_%tab = work(1:i2)
        DEALLOCATE(work)
        READ (mesh,'()')

        ! Reads groups definition.
        CALL c2g_%alloc_table(nel=ngroups,ntab=ncells)

        ALLOCATE(groupnc(ngroups),groupmat(ngroups), &
            &   groupname(ngroups),stat=info)
        IF(info /= 0) THEN
            WRITE(*,100)
            CALL abort_psblas
        END IF

        i1 = 1; i2 = 0; c2g_%lookup(1) = 1
        DO ig = 1, ngroups
            READ (mesh,'()')
            READ (mesh,550) i, groupnc(ig), groupmat(ig), j
            READ (mesh,560) groupname(ig)
            READ (mesh,'()')
            i2  =i1 + groupnc(ig) - 1
            READ (mesh,570) c2g_%tab(i1:i2)
            DO ic = i1, i2
                icl = c2g_%tab(ic)
                cellgroup(icl) = ig
            END DO
            i1 = i2 + 1
            c2g_%lookup(ig+1) = i1
            READ (mesh,'()')
        END DO

        ! Creates face-cell connectivity
        !
        ! Estimation of elements number for f2c_%tab and v2f_%tab
        nfaces = 0; n = 0
        DO ic = 1, ncells
            j = cellnf(ic)
            nfaces = nfaces + j

            SELECT CASE(cellgeo(ic))
            CASE('qua')
                k = 8
            CASE('tri')
                k = 6
            CASE('hex')
                k = 24
            CASE('pri')
                k = 18
            CASE('tet')
                k = 12
            CASE('pyr')
                k = 16
            END SELECT
            n = n + k
        END DO

        ! Allocation of face-related connectivity tables
        CALL f2c_%alloc_table(nel=ncells,ntab=nfaces)
        CALL v2f_%alloc_table(nel=nfaces,ntab=n)

        ! Allocation of temporary face-related arrays
        ALLOCATE(iflag(nfaces), fnv(nfaces),  &
            &   imaster(nfaces), islave(nfaces), stat=info)
        IF(info /= 0) THEN
            WRITE(*,100)
            CALL abort_psblas
        END IF

        i1 = 1; i2 = 0; f2c_%lookup(1) = 1
        j1 = 1; j2 = 0; v2f_%lookup(1) = 1
        DO ic = 1, ncells
            i2 = i1 + cellnf(ic) - 1

            iv  = v2c_%lookup(ic) - 1
            iv1 = v2c_%tab(iv+1)
            iv2 = v2c_%tab(iv+2)
            iv3 = v2c_%tab(iv+3)
            IF(cellnv(ic) > 3) iv4 = v2c_%tab(iv+4) ! quad, tet
            IF(cellnv(ic) > 4) iv5 = v2c_%tab(iv+5) ! pyr
            IF(cellnv(ic) > 5) iv6 = v2c_%tab(iv+6) ! pri
            IF(cellnv(ic) > 7) THEN                ! hex
                iv7 = v2c_%tab(iv+7)
                iv8 = v2c_%tab(iv+8)
            END IF

            DO IF = i1, i2
                f2c_%tab(IF) = IF
                iflag(IF) =0
                imaster(IF) = ic
                islave(IF) = 0 ! Further defined
            END DO

            SELECT CASE(cellgeo(ic))
            CASE('qua')
                j2 = j1 + 8 - 1
                v2f_%tab(j1:j2) = (/ iv1,iv2, iv2,iv3, iv3,iv4, iv4,iv1 /)
                v2f_%lookup(i1:i2) = (/ j1, (j1+2), (j1+4), (j1+6) /)
                fnv(i1:i2) = (/ 2, 2, 2, 2 /)
            CASE('tri')
                j2 = j1 + 6 - 1
                v2f_%tab(j1:j2) = (/ iv1,iv2, iv2,iv3, iv3,iv1 /)
                v2f_%lookup(i1:i2) = (/ j1, (j1+2), (j1+4) /)
                fnv(i1:i2) = (/ 2, 2, 2 /)
            CASE('hex')
                j2 = j1 + 24 - 1
                v2f_%tab(j1:j2) = (/ iv1,iv2,iv6,iv5, iv2,iv3,iv7,iv6, iv3,iv4,iv8,iv7, &
                    &             iv4,iv1,iv5,iv8, iv2,iv1,iv4,iv3, iv5,iv6,iv7,iv8 /)
                v2f_%lookup(i1:i2) = (/ j1, (j1+4), (j1+8), (j1+12), (j1+16), (j1+20) /)
                fnv(i1:i2) = (/ 4, 4, 4, 4, 4, 4 /)
            CASE('pri')
                j2 = j1 + 18 - 1
                v2f_%tab(j1:j2) = (/ iv1,iv2,iv5,iv4, iv2,iv3,iv6,iv5, iv3,iv1,iv4,iv6, &
                    &             iv1,iv3,iv2, iv4,iv5,iv6 /)
                v2f_%lookup(i1:i2) = (/ j1, (j1+4), (j1+8), (j1+12), (j1+15) /)
                fnv(i1:i2) = (/ 4, 4, 4, 3, 3  /)
            CASE('tet')
                j2 = j1 + 12 - 1
                v2f_%tab(j1:j2) = (/ iv2,iv1,iv3, iv1,iv2,iv4, iv2,iv3,iv4, iv3,iv1,iv4 /)
                v2f_%lookup(i1:i2) = (/ j1, (j1+3), (j1+6), (j1+9) /)
                fnv(i1:i2) = (/ 3, 3, 3, 3  /)
            CASE('pyr')
                j2 = j1 + 16 - 1
                v2f_%tab(j1:j2) = (/ iv1,iv4,iv3,iv2, iv1,iv2,iv5, iv2,iv3,iv5, &
                    &            iv3,iv4,iv5, iv4,iv1,iv5 /)
                v2f_%lookup(i1:i2) = (/ j1, (j1+4), (j1+7), (j1+10), (j1+13) /)
                fnv(i1:i2) = (/ 4, 3, 3, 3, 3  /)
            END SELECT

            i1 = i2 + 1
            j1 = j2 + 1
            f2c_%lookup(ic+1) = i1
            v2f_%lookup(i2+1) = j1
        END DO

        ! #############################################################################
        IF(debug) THEN
            DO ic = 1, ncells
                i1 = f2c_%lookup(ic)
                i2 = f2c_%lookup(ic+1) - 1
                j1 = f2c_%tab(i1)
                j2 = f2c_%tab(i2)
                DO IF = j1, j2
                    iv1 = v2f_%lookup(IF)
                    iv2 = v2f_%lookup(IF+1) - 1
                    WRITE(*,300) ic, cellgeo(ic), IF, v2f_%tab(iv1:iv2);
                END DO
            END DO
            WRITE(*,*)
    300     FORMAT(' cell: ',i7,' type: ',a3, ' face: ',i6,' vertices:', 8(1x,i7))
        END IF
        ! ###########################################################################

        ! Builds connection table f2v, dual of v2f
        CALL v2f_%get_dual_table(f2v)

        ! Initializes face permutation array
        ALLOCATE(perm(nfaces), stat=info)
        IF(info /= 0) THEN
            WRITE(*,100)
            CALL abort_psblas
        END IF
        DO IF = 1, nfaces
            perm(IF) = IF
        END DO

        ! Locates repeated faces and sets their flags = -1
        IF(ncd == 2) THEN
            pile_2D:  DO iv = 1, nverts
                i = f2v%lookup(iv) - 1! Offset
                n = f2v%lookup(iv+1) - f2v%lookup(iv) ! # of elements
                if1_2D: DO j = 1, n
                    if1 = f2v%tab(i+j)
                    IF(iflag(if1) == -1 .OR. islave(if1) /= 0) CYCLE
                    i1 = v2f_%lookup(if1) - 1
                    iv1 = v2f_%tab(i1+1) ! 1st iv of if1
                    iv2 = v2f_%tab(i1+2) ! 2nd iv of if1
                    if2_2D: DO k = j+1, n
                        if2 = f2v%tab(i+k)
                        i2 = v2f_%lookup(if2)-1
                        iv3 = v2f_%tab(i2+1) ! 1st iv of if2
                        iv4 = v2f_%tab(i2+2) ! 2nd iv of if2
                        !---
                        IF(iv4 == iv1 .AND. iv3 == iv2) THEN
                            iflag(if2) = -1
                            islave(if1) = imaster(if2)
                            imaster(if2) = 0
                            perm(if2) = if1
                            EXIT if2_2D
                        END IF
                    END DO if2_2D
                END DO if1_2D
            END DO pile_2D
        ELSE IF(ncd == 3) THEN
            ALLOCATE(buf(6),stat=info)
            IF(info /= 0) THEN
                WRITE(*,100)
                CALL abort_psblas
            END IF
            ! ---
            pile_3D:  DO iv = 1, nverts
                i = f2v%lookup(iv) - 1! Offset
                n = f2v%lookup(iv+1) - f2v%lookup(iv) ! # of elements
                if1_3D: DO j = 1, n-1
                    if1=f2v%tab(i+j)
                    IF(iflag(if1) == -1 .OR. islave(if1) /= 0) CYCLE
                    ! iflag(if1) = -1  --> repeated face
                    ! islave(if1) /= 0 --> already examined face
                    i1 = v2f_%lookup(if1) - 1
                    iv1 = v2f_%tab(i1+1)
                    iv2 = v2f_%tab(i1+2)
                    iv3 = v2f_%tab(i1+3)
                    found = .FALSE.
                    if2_3D: DO k = j+1, n
                        if2 = f2v%tab(i+k)
                        i2 = v2f_%lookup(if2)
                        j2 = v2f_%lookup(if2+1) - 1
                        l = fnv(if2)
                        ! Copies if2 iv-sequence in buf
                        buf(1) = v2f_%tab(j2)
                        buf(2:(l+1)) = v2f_%tab(i2:j2)
                        buf(l+2) = v2f_%tab(i2)
                        IF(l == 3) buf(6) = 0
                        !---
                        ! Searches for iv2 in buf
                        match: DO m = 2, (l+1)
                            IF(buf(m) /= iv2) CYCLE
                            IF(buf(m+1) == iv1 .AND. buf(m-1) == iv3) THEN
                                iflag(if2) = -1
                                islave(if1) = imaster(if2)
                                imaster(if2) = 0
                                perm(if2) = if1
                                found = .TRUE.
                            END IF
                        END DO match
                        IF(found) EXIT if2_3D
                    END DO if2_3D
                END DO if1_3D
            END DO pile_3D
            DEALLOCATE(buf)
        END IF
        CALL f2v%free_table()

        ! ###########################################################################
        IF (debug) THEN
            DO IF = 1, nfaces
                WRITE(*,310) IF, iflag(IF), imaster(IF), islave(IF)
            END DO
            WRITE(*,*)
    310     FORMAT(' face: ',i4,' flag: ',i2,' master: ',i4,' slave: ',i4)
        END IF
        ! ###########################################################################

        ! Completes the definition of permutation array
        ! new=perm(old)
        ! old=pinv(new)
        !
        ! By first faces with iflag(if)=0 ...
        j = 0
        DO IF = 1, nfaces
            IF(iflag(IF) == 0) THEN
                j = j + 1
                perm(IF) = j
            END IF
        END DO
        ! ... then faces with iflag(if)=-1
        DO IF = 1, nfaces
            IF(iflag(IF) == -1) THEN
                j = perm(IF)
                perm(IF) = perm(j)
            END IF
        END DO

        ! ###########################################################################
        IF(debug) THEN
            n = COUNT(iflag == 0)
            DO IF = 1, nfaces
                i1 = v2f_%lookup(IF)
                k = fnv(IF)
                WRITE(*,320) IF, iflag(IF), perm(IF), (v2f_%tab(j), j = i1, i1+k-1)
            END DO
            WRITE(*,*)
            DO IF = 1, nfaces
                i1 = v2f_%lookup(IF)
                k = fnv(IF)
            END DO
    320     FORMAT(' face: ',i7,' flag: ',i2,' perm: ',i7,' vertices',4i7)
        END IF
        ! ###########################################################################

        ! Reordering of face-based arrays

        ! Updates NFACES and stores OLD NFACES in N
        n = nfaces
        nfaces = COUNT(iflag == 0)

        ! Allocation of PINV and definitive face-related arrays
        ALLOCATE(pinv(nfaces), facenv(nfaces), faceflag(nfaces),&
            & facemaster(nfaces), faceslave(nfaces), stat=info)
        IF(info /= 0) THEN
            WRITE(*,100)
            CALL abort_psblas
        END IF

        ! Builds inverse permutation array for the NEW first NFACES faces
        DO IF = 1, n
            IF (iflag(IF) == 0) THEN
                j = perm(IF)
                pinv(j) = IF
            END IF
        END DO

        ! Reordering and assignment of definitive face-related arrays
        DO IF = 1, nfaces
            j = pinv(IF)

            facenv(IF)     = fnv(j)
            faceflag(IF)   = 0
            facemaster(IF) = imaster(j)
            faceslave(IF)  = islave(j)
        END DO
        DEALLOCATE(iflag,imaster,islave,fnv)

        ! Reordering and reallocation of v2f_
        k = 0
        DO IF = 1, nfaces
            j = k
            k = j + facenv(IF)
        END DO
        !
        CALL dmy%alloc_table(nel=nfaces,ntab=k)
        i1 = 1; i2 = 0; dmy%lookup(1) = 1
        DO IF = 1, nfaces
            j = pinv(IF)
            i2 = i1 + facenv(IF) - 1
            j1 = v2f_%lookup(j)
            j2 = j1 + facenv(IF) - 1
            dmy%tab(i1:i2) = v2f_%tab(j1:j2)
            i1 = i2 + 1
            dmy%lookup(IF+1) = i1
        END DO
        CALL v2f_%free_table()

        CALL v2f_%alloc_table(nel=nfaces,ntab=k)
        v2f_%lookup = dmy%lookup(1:nfaces+1)
        v2f_%tab = dmy%tab(1:k)

        ! Reordering of f2c_%tab
        DO ic = 1, ncells
            i1 = f2c_%lookup(ic)
            i2 = f2c_%lookup(ic+1) - 1
            DO i = i1, i2
                j = f2c_%tab(i)
                f2c_%tab(i) = perm(j)
            END DO
        END DO

        CALL dmy%free_table()
        DEALLOCATE(perm,pinv)

        ! ###########################################################################
        IF(debug) THEN
            DO IF = 1, nfaces
                i1 = v2f_%lookup(IF)
                i2 = v2f_%lookup(IF+1) - 1
                WRITE(*,330) IF, facemaster(IF), faceslave(IF), v2f_%tab(i1:i2)
            END DO
            WRITE(*,*)
            DO ic = 1, ncells
                i1 = f2c_%lookup(ic)
                i2 = f2c_%lookup(ic+1) - 1
                WRITE(*,340) ic, f2c_%tab(i1:i2)
            END DO
            WRITE(*,*)
    330     FORMAT(' face: ',i7, ' master: ',i7,' slave: ',i7,' vertices: ',4i7)
    340     FORMAT(' cell: ',i7, ' faces:',6(1x,i7))
        END IF
        ! ###########################################################################

        ! - Reads and assigns boundary conditions. Boundary flags are integer
        ! in the range [1-nbc]. If NBC = 0 from import, automatically NBC = 1 and where
        ! faceslave = 0 a boundary face is asssumed.
        ! - Builds list of faces, grouping them by their flag value.
        !
        ! faceflag(if)=0 --> fluid face
        ! faceflag(if)=i  --> i-th boundary face
        !

        ! Counts boundary faces (faceslave = 0)
        k = COUNT(faceslave == 0)

        IF(nbc /= 0) THEN
            ALLOCATE(f2b%lookup(nbc+1),f2b%tab(k), &
                &   bcnf(nbc),stat=info)
        ELSE
            ALLOCATE(f2b%lookup(2),f2b%tab(k), &
                &   bcnf(1),stat=info)
        END IF
        IF(info /= 0) THEN
            WRITE(*,100)
            CALL abort_psblas
        END IF

        ! Reads bc section
        IF(nbc /= 0) THEN
            i1 = 1; i2 = 0; f2b%lookup(1) = i1
            DO ib = 1, nbc
                READ (mesh,'()')
                READ (mesh,580) str, j, bcnf(ib)

                i2 = i1 + bcnf(ib) - 1

                DO j = 1, bcnf(ib)
                    READ (mesh,590) ic, k, l

                    m = f2c_%lookup(ic) - 1
                    IF = f2c_%tab(m+l)

                    f2b%tab(i1+j-1) = IF
                    faceflag(IF) = ib
                END DO

                i1 = i2 + 1
                f2b%lookup(ib+1) = i1
                READ (mesh,'()')
            END DO
        ELSE
            nbc = 1
            bcnf(1) = COUNT(faceslave == 0)
            f2b%lookup(1) = 1
            k = 0
            DO IF = 1, nfaces
                IF(faceslave(IF) == 0) THEN
                    k = k + 1
                    f2b%tab(k) = IF
                END IF
            END DO
            f2b%lookup(2)=k+1
            WHERE (faceslave == 0)
                faceflag = 1
            END WHERE
        END IF

        ! Reordering of if-indexing following the flag sequence: 0,1,2,...,nbc
        ! f2b%tab is used for building the inverse permutation array pinv
        ! old = pinv(new)
        ! new = perm(old)

        k=SIZE(v2f_%tab)
        ALLOCATE(perm(nfaces),pinv(nfaces),aux(4,nfaces),stat=info)
        IF(info /= 0) THEN
            WRITE(*,100)
            CALL abort_psblas
        END IF
        CALL dmy%alloc_table(nel=nfaces,ntab=k)

        ! Builds pinv
        k = 0
        ! First fluid faces ...
        DO IF = 1, nfaces
            IF(faceflag(IF) == 0) THEN
                k = k + 1
                pinv(k) = IF
            END IF
        END DO
        ! ... then bc faces.

        IF ( nfaces-k /= SIZE(f2b%tab) ) THEN
            WRITE(6,400)
            WRITE(6,*)"Check that the CAD model exported all faces."
            CALL abort_psblas
        ENDIF

        pinv(k+1:nfaces) = f2b%tab

        DO IF = 1, nfaces
            aux(1,IF) = facenv(IF)
            aux(2,IF) = faceflag(IF)
            aux(3,IF) = facemaster(IF)
            aux(4,IF) = faceslave(IF)
        END DO

        DO IF = 1, nfaces
            j = pinv(IF)
            perm(j) = IF ! Permutation array
            facenv(IF) = aux(1,j)
            faceflag(IF) = aux(2,j)
            facemaster(IF) = aux(3,j)
            faceslave(IF) = aux(4,j)
        END DO

        ! Reordering of v2f_%tab and v2f_%lookup
        k  = SIZE(v2f_%tab)
        dmy%lookup  = v2f_%lookup(1:nfaces+1)
        dmy%tab = v2f_%tab(1:k)
        i1 = 1; i2 = 0; v2f_%tab(i1) = 1
        DO IF = 1, nfaces
            i2 = i1 + facenv(IF) - 1

            j = pinv(IF)
            j1 = dmy%lookup(j)
            j2 = j1 + facenv(IF) - 1

            v2f_%tab(i1:i2) = dmy%tab(j1:j2)

            i1 = i2 + 1
            v2f_%lookup(IF+1) = i1
        END DO

        ! Reordering of f2c_%tab
        k = SIZE(f2c_%tab)
        DO i = 1, k
            j = f2c_%tab(i)
            f2c_%tab(i) = perm(j)
        END DO

        ! Counts total number of bc faces
        nbcfaces = COUNT(faceslave == 0)

        ! Redefinition of f2b%tab
        k = COUNT(faceflag == 0) ! Fluid faces
        DO IF = 1, nbcfaces
            f2b%tab(IF) = IF + k
        END DO

        ! ###########################################################################
        IF (debug) THEN
            WRITE(*,350) (f2b%tab(i), i = 1, f2b%lookup(1) -1)
            WRITE(*,*)

            DO ib = 1, nbc
                i1 = f2b%lookup(ib)
                i2 = i1 + bcnf(ib) - 1
                WRITE(*,360) ib, f2b%tab(i1:i2)
            END DO
            WRITE(*,*)

            DO IF = 1, nfaces
                WRITE(*,370) IF, faceflag(IF), facemaster(IF), faceslave(IF)
            END DO
            WRITE(*,*)

            DO i = 0, nbc
                WRITE(*,380) i, COUNT(faceflag == i)
            END DO

            WRITE(*,*)
    350     FORMAT(' Fluid faces: ',5i8:/(14x,5i8))
    360     FORMAT(' Bcset: ',i2,' List of faces: ', 5i8:/(40x,5i8:))
    370     FORMAT(' faces: ',i7,' Flag: ',i2,' Master: ',i7,' Slave: ',i7)
    380     FORMAT(' Total amount of faces with flag',i3,':',i8)
    400     FORMAT(' Fatal Error in RD_GAMBIT_MESH:  inconsistent face, boundary lists.')
        END IF
        ! ###########################################################################

        ! f2b is no longer useful. It can be deallocated
        CALL f2b%free_table()
        CALL dmy%free_table()
        DEALLOCATE(perm,pinv,aux,bcnf)

        ! Defines ON_BOUNDARY array
        ALLOCATE(on_boundary(nverts),stat=info)
        IF(info /= 0) THEN
            WRITE(*,100)
            CALL abort_psblas
        END IF
        on_boundary = .FALSE.

        k = COUNT(faceflag == 0) + 1 ! Offset

        ! Loop on boundary faces
        DO IF = k, nfaces
            i1 = v2f_%lookup(IF)
            i2 = v2f_%lookup(IF+1) - 1
            DO i = i1, i2
                iv = v2f_%tab(i)
                on_boundary(iv) = .TRUE.
            END DO
        END DO

        ! Copies vertex-related data in to the object VERTS of VERTEX class
        CALL alloc_vertex(verts,nverts)
        verts = vertex_(xv,yv,zv,on_boundary)
        DEALLOCATE(xv,yv,zv,on_boundary)

        ! Copies face-related data in to the object FACES of FACE class
        CALL alloc_face(faces,nfaces)
        faces = face_(facenv,facemaster,faceslave,faceflag)
        DEALLOCATE(facenv,facemaster,faceslave,faceflag)

        ! Copies cell-related data in to the object CELLS of CELL class
        CALL alloc_cell(cells,ncells)
        cells = cell_(cellnv,cellnf,cellgroup,cellgeo)
        DEALLOCATE(cellnv,cellnf,cellgroup,cellgeo)

        ! Copies connectivities  V2F, V2C, F2C to dummy arguments V2F_, V2C_, F2C_
        ! (objects of CONNECTIVITY class)
        CALL alloc_conn(v2f,nel=nfaces,nconn=SIZE(v2f_%tab))
        CALL alloc_conn(v2c,nel=ncells,nconn=SIZE(v2c_%tab))
        CALL alloc_conn(f2c,nel=ncells,nconn=SIZE(f2c_%tab))
        CALL alloc_conn(c2g,nel=ngroups,nconn=SIZE(c2g_%tab))

        DO IF = 1, nfaces
            i1 = v2f_%lookup(IF)
            i2 = v2f_%lookup(IF+1) - 1
            CALL v2f%set_ith_conn(IF,v2f_%tab(i1:i2))
        END DO

        DO ic = 1, ncells
            i1 = v2c_%lookup(ic)
            i2 = v2c_%lookup(ic+1) - 1
            CALL v2c%set_ith_conn(ic,v2c_%tab(i1:i2))
        END DO

        DO ic = 1, ncells
            i1 = f2c_%lookup(ic)
            i2 = f2c_%lookup(ic+1) - 1
            CALL f2c%set_ith_conn(ic,f2c_%tab(i1:i2))
        END DO

        DO ig = 1, ngroups
            i1 = c2g_%lookup(ig)
            i2 = c2g_%lookup(ig+1) - 1
            CALL c2g%set_ith_conn(ig,c2g_%tab(i1:i2))
        END DO

        ! Deallocates local copies of connectivity data
        CALL v2f_%free_table()
        CALL v2c_%free_table()
        CALL f2c_%free_table()
        CALL c2g_%free_table()

        ! Currently group data GROUPNC, GROUPMAT, GROUPNAME are not exported
        ! to the calling program => deallocation
        DEALLOCATE(groupnc,groupmat,groupname)

        CLOSE(mesh)

        WRITE(*,'()')

        !     FORMAT Instructions
050     FORMAT(' ERROR! Failure to open Gambit mesh file.',/,&
        &    ' File expected: ', a)
100     FORMAT(' ERROR! Memory allocation failure in RD_GAMBIT_MESH')
500     FORMAT(a80)
510     FORMAT(6(1x,i9))
520     FORMAT(i10,3(e20.11))
530     FORMAT(i8,1x,i2,1x,i2,1x)
540     FORMAT(7i8:/(t16,7i8:))
550     FORMAT(t8,i10,tr11,i10,tr11,i10,tr9,i10)
560     FORMAT(a32)
570     FORMAT((10i8))
580     FORMAT(a32,2i8)
590     FORMAT(i10,2i7)

    END PROCEDURE rd_gambit_mesh

END SUBMODULE rd_gambit_implementation


      subroutine rls_routeaqu (iob)

!!    ~ ~ ~ PURPOSE ~ ~ ~

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!
      use hru_module, only : ihru, hru
      use soil_module
      use hydrograph_module
      use organic_mineral_mass_module

      implicit none

      integer, intent (in) :: iob   !           |object number
      integer :: j                  !           |hru number
      integer :: lyr                !           |tile soil layer

      j = ihru

      !! add aquifer inflow and nitrate to the bottom soil layer
      !! if exceeds saturation, it will be redistributed in swr_satexcess
      lyr = soil(j)%nly
      soil(j)%phys(lyr)%st = soil(j)%phys(lyr)%st + ob(iob)%hin_til%flo
      soil1(j)%mn(lyr)%no3 = soil1(j)%mn(lyr)%no3 + ob(iob)%hin_til%no3

      return
      end subroutine rls_routeaqu


C    %W% %G%
      subroutine r1inp
C
C     THIS SUBROUTINE DECODES THE RATE OF CHANGE OF POWER RELAY
C     DATA CARD AND FORMS INITIAL TABLES.  IT IS CALLED BY INPUT2.
C
      include 'tspinc/params.inc'
      include 'tspinc/r1com.inc'
      include 'tspinc/param.inc'
      include 'tspinc/kntrly.inc'
      include 'tspinc/pointr.inc'
      include 'tspinc/reread.inc'
      include 'tspinc/workc.inc'
      include 'tspinc/bypass.inc'
      include 'tspinc/relays.inc'
      include 'tspinc/prt.inc'

      character*8 name1c, name2c
      character*1 idc, itrp, subtyp

C     -     begin     begin     begin     begin     begin     begin
      read (buffer, 10000) subtyp, name1c, base1, itrp, name2c, base2,
     & idc
10000 format (bz, 1x, a1, 4x, a8, f4.0, a1, a8, f4.0, a1)
      kb1 = nambas(base1)
      kb2 = nambas(base2)
      j1 = inam(name1c, kb1)
      j2 = inam(name2c, kb2)
      if (j1 .eq. 0 .or. j2 .eq. 0) then
        write (outbuf, 10010) buffer
10010   format ('0', a80)
        call prtout(1)
      else
        kntr1 = kntr1 + 1
        if (kntr1 .gt. MAXR1) then
          write (errbuf(1), 10020) MAXR1
10020     format (5x, ' YOU HAVE ENTERED MORE THAN ', i3,
     &     ' POWER RATE ', 'RELAY CARDS.  THE STUDY WILL ABORT.')
          call prterr('E', 1)
          iabort = 1
        else
          if (iswbps .ne. 0) then
C
C           STORE THIS LINE IN THE DEFAULT DISTANCE RELAY BYPASS T
C
            nbypas = nbypas + 1
            kbpass(1, nbypas) = j1
            kbpass(2, nbypas) = j2
          endif
          icd3r1(kntr1) = 1
          if (itrp .eq. 'C') icd3r1(kntr1) = 2
          ibusr1(kntr1) = j1
          jbusr1(kntr1) = j2
          iparr1(kntr1) = idc
          icd1r1(kntr1) = 1
          if (subtyp .eq. '1') icd2r1(kntr1) = 5
          if (subtyp .eq. '2') icd2r1(kntr1) = 6
          if (subtyp .eq. '3') icd2r1(kntr1) = 7
          icd4r1(kntr1) = 0
C
C         DECODE R3 TYPE RELAY
C
          if (subtyp .eq. '3') then
            read (buffer, 10030) rmax, rmin, rs, ps, tc, te, th, ttrp
10030       format (bz, 33x, 3f5.0, 5x, f5.0, 4f5.2)
            tc = tc*frqbse
            ps = ps/bmva
            denom = 1./(frqbse*bmva)
            rmax = rmax*denom
            rmin = rmin*denom
            rs = rs*denom
            rmaxr1(kntr1) = rmax
            rminr1(kntr1) = rmin
            tcr1(kntr1) = tc
            psr1(kntr1) = ps
            rsr1(kntr1) = rs
            ter1(kntr1) = te
            thr1(kntr1) = th
            ttrpr1(kntr1) = ttrp
            ttimr1(kntr1) = 0.0
          endif
C
C         DECODE R1 AND R2 CARDS
C
          if (subtyp .eq. '2' .or. subtyp .eq. '1') then
            read (buffer, 10040) rb, rmax, rs, bias, ps, tc, td, ttrp
10040       format (bz, 33x, 5f5.0, 2f5.2, 5x, f5.2)
            denom = 1./(frqbse*bmva)
            rb = rb*denom
            rs = rs*denom
            rmax = rmax*denom
            tc = tc*frqbse
            ps = ps/bmva
            bias = bias/bmva
            rbr1(kntr1) = rb
            rmaxr1(kntr1) = rmax
            rsr1(kntr1) = rs
            biasr1(kntr1) = bias
            psr1(kntr1) = ps
            tcr1(kntr1) = tc
            tdr1(kntr1) = td
            t1r1(kntr1) = td
            ttrpr1(kntr1) = ttrp
            ttimr1(kntr1) = 0.0
          endif
C
C         CALL BRNCHY TO OBTAIN ORGINAL ADMITTANCES RELAYED LINE
C
          call brnchy(j1, j2, idc, ierr, gkm, bkm, gmk, bmk, gk1, bk1,
     &                gk2, bk2)
C
C          IF IERR = -1, THEN THE LINE COULD NOT BE FOUND IN THE BR
C          DATA TABLES FROM THE POWER FLOW.
C
          if (ierr .eq. -1) then
            iabort = 1
            ksect = 0
            write (errbuf(1), 10050) name1c, base1, name2c, base2, idc,
     &       ksect
            call prterr('E', 1)
10050       format ('NO BRANCH DATA CAN BE FOUND FOR POWER RATE RELAY '
     &       , 'CARD.', a8, f5.1, 2x, a8, f5.1, 1x, a1, 1x, i1)
          else
            gijr1(kntr1) = gkm
            bijr1(kntr1) = bkm
            gior1(kntr1) = gk1
            bior1(kntr1) = bk1
            gjor1(kntr1) = gk2
            bjor1(kntr1) = bk2
          endif
        endif
      endif
      return
      end


MODULE iscplini
   !!======================================================================
   !!                       ***  MODULE  sbciscpl***
   !! Ocean forcing:  river runoff
   !!=====================================================================
   !! History :  NEMO  ! 2015-01 P. Mathiot: original
   !!----------------------------------------------------------------------

   !!----------------------------------------------------------------------
   !!   iscpl_init     : initialisation routine (namelist)
   !!   iscpl_alloc    : allocation of correction variables
   !!----------------------------------------------------------------------
   USE dom_oce         ! ocean space and time domain
   USE oce             ! global tra/dyn variable
   USE lib_mpp         ! MPP library
   USE lib_fortran     ! MPP library
   USE in_out_manager  ! I/O manager

   IMPLICIT NONE
   PRIVATE

   PUBLIC   iscpl_init
   PUBLIC   iscpl_alloc
   !!                                                      !!* namsbc_iscpl namelist *
   LOGICAL , PUBLIC                                        ::   ln_hsb
   INTEGER , PUBLIC                                        ::   nn_fiscpl, nstp_iscpl
   INTEGER , PUBLIC                                        ::   nn_drown
   REAL(wp), PUBLIC                                        ::   rdt_iscpl
   !!                                                      !!* namsbc_iscpl namelist *
   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:  ) ::   hdiv_iscpl
   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   htsc_iscpl
   !!----------------------------------------------------------------------
   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
   !! $Id: sbcrnf.F90 4666 2014-06-11 12:52:23Z mathiot $
   !! Software governed by the CeCILL licence     (./LICENSE)
   !!----------------------------------------------------------------------
CONTAINS

   INTEGER FUNCTION iscpl_alloc()
      !!----------------------------------------------------------------------
      !!                ***  ROUTINE sbc_iscpl_alloc  ***
      !!----------------------------------------------------------------------
      ALLOCATE( htsc_iscpl(jpi,jpj,jpk,jpts) , hdiv_iscpl(jpi,jpj,jpk) , STAT=iscpl_alloc )
         !
      IF( lk_mpp          )   CALL mpp_sum ( iscpl_alloc )
      IF( iscpl_alloc > 0 )   CALL ctl_warn('iscpl_alloc: allocation of arrays failed')
   END FUNCTION iscpl_alloc

   SUBROUTINE iscpl_init()
      INTEGER ::   ios           ! Local integer output status for namelist read
      NAMELIST/namsbc_iscpl/nn_fiscpl,ln_hsb,nn_drown
      !!----------------------------------------------------------------------
      !                                   ! ============
      !                                   !   Namelist
      !                                   ! ============
      !
      nn_fiscpl = 0
      ln_hsb    = .FALSE.
      REWIND( numnam_ref )              ! Namelist namsbc_iscpl in reference namelist : Ice sheet coupling
      READ  ( numnam_ref, namsbc_iscpl, IOSTAT = ios, ERR = 901)
901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_iscpl in reference namelist', lwp )

      REWIND( numnam_cfg )              ! Namelist namsbc_iscpl in configuration namelist : Ice Sheet coupling
      READ  ( numnam_cfg, namsbc_iscpl, IOSTAT = ios, ERR = 902 )
902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_iscpl in configuration namelist', lwp )
      IF(lwm) WRITE ( numond, namsbc_iscpl )
      !
      nstp_iscpl=MIN(nn_fiscpl, nitend-nit000+1) ! the coupling period have to be less or egal than the total number of time step
      rdt_iscpl = nstp_iscpl * rn_rdt
      !
      IF (lwp) THEN
         WRITE(numout,*) 'iscpl_rst:'
         WRITE(numout,*) '~~~~~~~~~'
         WRITE(numout,*) ' coupling     flag (ln_iscpl )            = ', ln_iscpl
         WRITE(numout,*) ' conservation flag (ln_hsb   )            = ', ln_hsb
         WRITE(numout,*) ' nb of stp for cons (rn_fiscpl)           = ', nstp_iscpl
         IF (nstp_iscpl .NE. nn_fiscpl) WRITE(numout,*) 'W A R N I N G: nb of stp for cons has been modified &
            &                                           (larger than run length)'
         WRITE(numout,*) ' coupling time step                       = ', rdt_iscpl
         WRITE(numout,*) ' number of call of the extrapolation loop = ', nn_drown
      END IF

   END SUBROUTINE iscpl_init

END MODULE iscplini


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2018 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 beamsections(inpc,textpart,set,istartset,iendset,
     &  ialset,nset,ielmat,matname,nmat,ielorien,orname,norien,
     &  thicke,ipkon,iponor,xnor,ixfree,
     &  offset,lakon,irstrt,istep,istat,n,iline,ipol,inl,ipoinp,inp,
     &  ipoinpc,mi,nelcon,ier)
!
!     reading the input deck: *BEAM SECTION
!
      implicit none
!
      logical nodalthickness
!
      character*1 inpc(*)
      character*4 section
      character*8 lakon(*)
      character*80 matname(*),orname(*),material,orientation
      character*81 set(*),elset
      character*132 textpart(16)
!
      integer istartset(*),iendset(*),ialset(*),mi(*),ielmat(mi(3),*),
     &  ipoinpc(0:*),numnod,
     &  ielorien(mi(3),*),ipkon(*),iline,ipol,inl,ipoinp(2,*),
     &  inp(3,*),nset,nmat,norien,istep,istat,n,key,i,j,k,l,imaterial,
     &  iorientation,ipos,m,iponor(2,*),ixfree,
     &  indexx,indexe,irstrt(*),nelcon(2,*),ier
!
      real*8 thicke(mi(3),*),thickness1,thickness2,p(3),xnor(*),
     &  offset(2,*),offset1,offset2,dd
!
      if((istep.gt.0).and.(irstrt(1).ge.0)) then
         write(*,*)
     &       '*ERROR reading *BEAM SECTION: *BEAM SECTION should'
         write(*,*) '  be placed before all step definitions'
         ier=1
         return
      endif
!
      nodalthickness=.false.
      offset1=0.d0
      offset2=0.d0
      orientation='
     &                           '
      section='    '
      ipos=1
!
      do i=2,n
         if(textpart(i)(1:9).eq.'MATERIAL=') then
            material=textpart(i)(10:89)
         elseif(textpart(i)(1:12).eq.'ORIENTATION=') then
            orientation=textpart(i)(13:92)
         elseif(textpart(i)(1:6).eq.'ELSET=') then
            elset=textpart(i)(7:86)
            elset(81:81)=' '
            ipos=index(elset,' ')
            elset(ipos:ipos)='E'
         elseif(textpart(i)(1:14).eq.'NODALTHICKNESS') then
            nodalthickness=.true.
         elseif(textpart(i)(1:8).eq.'SECTION=') then
            if(textpart(i)(9:12).eq.'CIRC') then
               section='CIRC'
            elseif(textpart(i)(9:12).eq.'RECT') then
               section='RECT'
            else
               write(*,*)
     &           '*ERROR reading *BEAM SECTION: unknown section'
               ier=1
               return
            endif
         elseif(textpart(i)(1:8).eq.'OFFSET1=') then
            read(textpart(i)(9:28),'(f20.0)',iostat=istat) offset1
            if(istat.gt.0) then
               call inputerror(inpc,ipoinpc,iline,
     &              "*BEAM SECTION%",ier)
               return
            endif
         elseif(textpart(i)(1:8).eq.'OFFSET2=') then
            read(textpart(i)(9:28),'(f20.0)',iostat=istat) offset2
            if(istat.gt.0) then
               call inputerror(inpc,ipoinpc,iline,
     &              "*BEAM SECTION%",ier)
               return
            endif
         else
            write(*,*)
     &       '*WARNING reading *BEAM SECTION: parameter not recognized:'
            write(*,*) '         ',
     &                 textpart(i)(1:index(textpart(i),' ')-1)
            call inputwarning(inpc,ipoinpc,iline,
     &"*BEAM SECTION%")
         endif
      enddo
!
!     check whether a sections was defined
!
      if(section.eq.'    ') then
         write(*,*) '*ERROR reading *BEAM SECTION: no section defined'
         ier=1
         return
      endif
!
!     check for the existence of the set,the material and orientation
!
      do i=1,nmat
         if(matname(i).eq.material) exit
      enddo
      if(i.gt.nmat) then
         write(*,*) '*ERROR reading *BEAM SECTION: nonexistent material'
         write(*,*) '  '
         call inputerror(inpc,ipoinpc,iline,
     &        "*BEAM SECTION%",ier)
         return
      endif
      imaterial=i
!
      if(orientation.eq.'
     &                                 ') then
         iorientation=0
      elseif(nelcon(1,i).eq.2) then
         write(*,*) '*INFO reading *SOLID SECTION: an orientation'
         write(*,*) '      is for isotropic materials irrelevant'
         call inputinfo(inpc,ipoinpc,iline,
     &"*SOLID SECTION%")
         iorientation=0
      else
         do i=1,norien
            if(orname(i).eq.orientation) exit
         enddo
         if(i.gt.norien) then
            write(*,*)
     &         '*ERROR reading *BEAM SECTION: nonexistent orientation'
            write(*,*) '  '
            call inputerror(inpc,ipoinpc,iline,
     &           "*BEAM SECTION%",ier)
            return
         endif
         iorientation=i
      endif
!
      do i=1,nset
         if(set(i).eq.elset) exit
      enddo
      if(i.gt.nset) then
         elset(ipos:ipos)=' '
         write(*,*) '*ERROR reading *BEAM SECTION: element set ',
     &      elset(1:ipos)
         write(*,*) '  has not yet been defined. '
         call inputerror(inpc,ipoinpc,iline,
     &        "*BEAM SECTION%",ier)
         return
      endif
!
!     assigning the elements of the set the appropriate material,
!     orientation number, section and offset(s)
!
      do j=istartset(i),iendset(i)
         if(ialset(j).gt.0) then
            if(lakon(ialset(j))(1:1).ne.'B') then
               write(*,*)
     &           '*ERROR reading *BEAM SECTION: *BEAM SECTION can'
               write(*,*) '       only be used for beam elements.'
               write(*,*) '       Element ',ialset(j),' is not a beam el
     &ement.'
               ier=1
               return
            endif
            ielmat(1,ialset(j))=imaterial
            ielorien(1,ialset(j))=iorientation
            offset(1,ialset(j))=offset1
            offset(2,ialset(j))=offset2
            if(section.eq.'RECT') then
               lakon(ialset(j))(8:8)='R'
            else
               lakon(ialset(j))(8:8)='C'
            endif
         else
            k=ialset(j-2)
            do
               k=k-ialset(j)
               if(k.ge.ialset(j-1)) exit
               if(lakon(k)(1:1).ne.'B') then
                  write(*,*)
     &              '*ERROR reading *BEAM SECTION: *BEAM SECTION can'
                  write(*,*) '       only be used for beam elements.'
                  write(*,*) '       Element ',k,' is not a beam element
     &.'
                  ier=1
                  return
               endif
               ielmat(1,k)=imaterial
               ielorien(1,k)=iorientation
               offset(1,k)=offset1
               offset(2,k)=offset2
               if(section.eq.'RECT') then
                  lakon(k)(8:8)='R'
               else
                  lakon(k)(8:8)='C'
               endif
            enddo
         endif
      enddo
!
      call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl,
     &     ipoinp,inp,ipoinpc)
!
!     assigning a thickness to the elements
!
      if(.not.nodalthickness) then
         read(textpart(1)(1:20),'(f20.0)',iostat=istat) thickness1
         if(istat.gt.0) then
            write(*,*)
     &   '*ERROR reading *BEAM SECTION: first beam thickness is lacking'
            call inputerror(inpc,ipoinpc,iline,
     &        "*BEAM SECTION%",ier)
            return
         endif
         if(n.gt.1) then
            read(textpart(2)(1:20),'(f20.0)',iostat=istat) thickness2
            if(istat.gt.0) then
               write(*,*)
     &              '*ERROR reading *BEAM SECTION: ',
     &              'second beam thickness is lacking'
               call inputerror(inpc,ipoinpc,iline,
     &              "*BEAM SECTION%",ier)
               return
            endif
         else
            thickness2=thickness1
         endif
      else
!
!        for those elements for which nodal thickness is activated
!        the thickness is set to -1.d0
!
         thickness1=-1.d0
         thickness2=thickness1
      endif
!
      do j=istartset(i),iendset(i)
         if(ialset(j).gt.0) then
            indexe=ipkon(ialset(j))
            read(lakon(ialset(j))(3:3),'(i1)') numnod
            numnod=numnod+1
            do l=1,numnod
               thicke(1,indexe+l)=thickness1
               thicke(2,indexe+l)=thickness2
            enddo
         else
            k=ialset(j-2)
            do
               k=k-ialset(j)
               if(k.ge.ialset(j-1)) exit
               indexe=ipkon(k)
               read(lakon(k)(3:3),'(i1)') numnod
               numnod=numnod+1
               do l=1,numnod
                  thicke(1,indexe+l)=thickness1
                  thicke(2,indexe+l)=thickness2
               enddo
            enddo
         endif
      enddo
!
      call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl,
     &     ipoinp,inp,ipoinpc)
      if((istat.lt.0).or.(key.eq.1)) return
!
!     assigning normal direction 1 for the beam
!
      indexx=-1
      read(textpart(1)(1:20),'(f20.0)',iostat=istat) p(1)
      if(istat.gt.0) then
         call inputerror(inpc,ipoinpc,iline,
     &        "*BEAM SECTION%",ier)
         return
      endif
      read(textpart(2)(1:20),'(f20.0)',iostat=istat) p(2)
      if(istat.gt.0) then
         call inputerror(inpc,ipoinpc,iline,
     &        "*BEAM SECTION%",ier)
         return
      endif
      read(textpart(3)(1:20),'(f20.0)',iostat=istat) p(3)
      if(istat.gt.0) then
         call inputerror(inpc,ipoinpc,iline,
     &        "*BEAM SECTION%",ier)
         return
      endif
      dd=dsqrt(p(1)*p(1)+p(2)*p(2)+p(3)*p(3))
      if(dd.lt.1.d-10) then
         write(*,*)
     &       '*ERROR reading *BEAM SECTION: normal in direction 1'
         write(*,*) '       has zero size'
         ier=1
         return
      endif
      do j=1,3
         p(j)=p(j)/dd
      enddo
      do j=istartset(i),iendset(i)
         if(ialset(j).gt.0) then
            indexe=ipkon(ialset(j))
            read(lakon(ialset(j))(3:3),'(i1)') numnod
            numnod=numnod+1
            do l=1,numnod
               if(indexx.eq.-1) then
                  indexx=ixfree
                  do m=1,3
                     xnor(indexx+m)=p(m)
                  enddo
                  ixfree=ixfree+6
               endif
               iponor(1,indexe+l)=indexx
            enddo
         else
            k=ialset(j-2)
            do
               k=k-ialset(j)
               if(k.ge.ialset(j-1)) exit
               indexe=ipkon(k)
               read(lakon(k)(3:3),'(i1)') numnod
               numnod=numnod+1
               do l=1,numnod
               if(indexx.eq.-1) then
                  indexx=ixfree
                  do m=1,3
                     xnor(indexx+m)=p(m)
                  enddo
                  ixfree=ixfree+6
               endif
               iponor(1,indexe+l)=indexx
               enddo
            enddo
         endif
      enddo
!
      call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl,
     &     ipoinp,inp,ipoinpc)
!
      return
      end


! THIS VERSION: GALAHAD 2.1 - 22/03/2007 AT 09:00 GMT.

!-*-*-*-*-*-*-*-*-  G A L A H A D   R U N E Q P _ S I F  *-*-*-*-*-*-*-*-*-*-

!  Nick Gould and Dominique Orban, for GALAHAD productions
!  Copyright reserved
!  March 25th 2004

   PROGRAM RUNEQP_SIF
   USE GALAHAD_USEEQP_double

!  Main program for the SIF/CUTEr interface to EQP, a projected
!  conjugate-gradient algorithm for solving equality-constrained
!  quadratic programs

!  Problem input characteristics

   INTEGER, PARAMETER :: input = 55
   CHARACTER ( LEN = 16 ) :: prbdat = 'OUTSDIF.d'

!  Open the data input file

   OPEN( input, FILE = prbdat, FORM = 'FORMATTED', STATUS = 'OLD'  )
   REWIND input

!  Call the CUTEr interface

   CALL USE_EQP( input )

!  Close the data input file

   CLOSE( input  )
   STOP

!  End of RUNEQP_SIF

   END PROGRAM RUNEQP_SIF


! problem-specific Fortran stuff goes here

subroutine problem_checkpoint(int_dir_name, len) bind(C, name="problem_checkpoint")

  ! called by the IO processor during checkpoint

  use amrex_fort_module, only : rt => amrex_real
  implicit none

  integer :: len
  integer :: int_dir_name(len)
  character (len=len) :: dir

  integer :: i

  ! dir will be the string name of the checkpoint directory
  do i = 1, len
     dir(i:i) = char(int_dir_name(i))
  enddo

end subroutine problem_checkpoint

subroutine problem_restart(int_dir_name, len) bind(C, name="problem_restart")

  ! called by ALL processors during restart

  use amrex_fort_module, only : rt => amrex_real
  implicit none

  integer :: len
  integer :: int_dir_name(len)
  character (len=len) :: dir

  integer :: i

  ! dir will be the string name of the checkpoint directory
  do i = 1, len
     dir(i:i) = char(int_dir_name(i))
  enddo

end subroutine problem_restart

subroutine bolometric_lum(rad_state,s_lo,s_hi, &
                          lo, hi, dx, time, &
                          lum) bind(C)
    use castro_util_module, only : position
    use amrex_constants_module, only: four, M_PI
    use fundamental_constants_module, only: c_light
    use rad_params_module, only : ngroups
    use meth_params_module, only: NVAR, QRAD
    use prob_params_module, only : probhi
    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer :: lo(3), hi(3)
    integer :: s_lo(3), s_hi(3)
    real(rt)        :: xlo(1), xhi(1), time, delta(1)
    real(rt)        :: rad_state(s_lo(1):s_hi(1),s_lo(2):s_hi(2),s_lo(3):s_hi(3),0:ngroups-1)
    real(rt)        :: lum

    ! Local variables

    integer :: i, j, k
    real(rt)         :: r(3), xx, dx

    do k = lo(3), hi(3)
       do j = lo(2), hi(2)
          do i = lo(1), hi(1)

             r = position(i,j,k)
             xx = abs(probhi(1)-r(1))

             if (xx .lt. 1.1e0_rt*dx) then

               lum = four*M_PI*r(1)*r(1)*c_light*rad_state(i,j,k,0)

             else
               lum = -1.e0_rt

             endif

          enddo
       enddo
    enddo

end subroutine bolometric_lum

subroutine rad_temp_rs(rad_state,s_lo,s_hi, &
                          lo, hi, dx, time, &
                          ind, temp) bind(C)
    use castro_util_module, only : position
    use amrex_constants_module, only: four, M_PI
    use fundamental_constants_module, only: c_light, a_rad
    use rad_params_module, only : ngroups
    use meth_params_module, only: NVAR, QRAD
    use prob_params_module, only : probhi
    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer :: lo(3), hi(3)
    integer :: s_lo(3), s_hi(3)
    integer, intent(in) :: ind
    real(rt)        :: xlo(1), xhi(1), time, delta(1)
    real(rt)        :: rad_state(s_lo(1):s_hi(1),s_lo(2):s_hi(2),s_lo(3):s_hi(3),0:ngroups-1)
    real(rt)        :: temp

    ! Local variables

    integer :: i, j, k
    real(rt)         :: r(3), xx, dx

    do k = lo(3), hi(3)
       do j = lo(2), hi(2)
          do i = lo(1), hi(1)

             if(i .eq. ind) then
                temp = (rad_state(i,j,k,0)/a_rad)**0.25
              endif

          enddo
       enddo
    enddo

end subroutine rad_temp_rs

subroutine rad_temp_cd(rad_state,s_lo,s_hi, &
                          lo, hi, dx, time, &
                          ind, temp) bind(C)
    use castro_util_module, only : position
    use amrex_constants_module, only: four, M_PI
    use fundamental_constants_module, only: c_light, a_rad
    use rad_params_module, only : ngroups
    use meth_params_module, only: NVAR, QRAD
    use prob_params_module, only : probhi
    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer :: lo(3), hi(3)
    integer :: s_lo(3), s_hi(3)
    integer, intent(in) :: ind
    real(rt)        :: xlo(1), xhi(1), time, delta(1)
    real(rt)        :: rad_state(s_lo(1):s_hi(1),s_lo(2):s_hi(2),s_lo(3):s_hi(3),0:ngroups-1)
    real(rt)        :: temp

    ! Local variables

    integer :: i, j, k
    real(rt)         :: r(3), xx, dx

    do k = lo(3), hi(3)
       do j = lo(2), hi(2)
          do i = lo(1), hi(1)

             if(i .eq. ind) then
                temp = (rad_state(i,j,k,0)/a_rad)**0.25
              endif

          enddo
       enddo
    enddo

end subroutine rad_temp_cd

subroutine rad_temp_fs(rad_state,s_lo,s_hi, &
                          lo, hi, dx, time, &
                          ind, temp) bind(C)
    use castro_util_module, only : position
    use amrex_constants_module, only: four, M_PI
    use fundamental_constants_module, only: c_light, a_rad
    use rad_params_module, only : ngroups
    use meth_params_module, only: NVAR, QRAD
    use prob_params_module, only : probhi
    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer :: lo(3), hi(3)
    integer :: s_lo(3), s_hi(3)
    integer, intent(in) :: ind
    real(rt)        :: xlo(1), xhi(1), time, delta(1)
    real(rt)        :: rad_state(s_lo(1):s_hi(1),s_lo(2):s_hi(2),s_lo(3):s_hi(3),0:ngroups-1)
    real(rt)        :: temp

    ! Local variables

    integer :: i, j, k
    real(rt)         :: r(3), xx, dx

    do k = lo(3), hi(3)
       do j = lo(2), hi(2)
          do i = lo(1), hi(1)

             if(i .eq. ind) then
                temp = (rad_state(i,j,k,0)/a_rad)**0.25
              endif

          enddo
       enddo
    enddo

end subroutine rad_temp_fs

subroutine rad_temp_phot(rad_state,s_lo,s_hi, &
                          lo, hi, dx, time, &
                          ind, temp) bind(C)
    use castro_util_module, only : position
    use amrex_constants_module, only: four, M_PI
    use fundamental_constants_module, only: c_light, a_rad
    use rad_params_module, only : ngroups
    use meth_params_module, only: NVAR, QRAD
    use prob_params_module, only : probhi
    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer :: lo(3), hi(3)
    integer :: s_lo(3), s_hi(3)
    integer, intent(in) :: ind
    real(rt)        :: xlo(1), xhi(1), time, delta(1)
    real(rt)        :: rad_state(s_lo(1):s_hi(1),s_lo(2):s_hi(2),s_lo(3):s_hi(3),0:ngroups-1)
    real(rt)        :: temp

    ! Local variables

    integer :: i, j, k
    real(rt)         :: r(3), xx, dx

    do k = lo(3), hi(3)
       do j = lo(2), hi(2)
          do i = lo(1), hi(1)

             if(i .eq. ind) then
                temp = (rad_state(i,j,k,0)/a_rad)**0.25
              endif

          enddo
       enddo
    enddo

end subroutine rad_temp_phot

subroutine gas_temp_rs(state,s_lo,s_hi, &
                          lo, hi, dx, time, &
                          ind, temp) bind(C)
    use castro_util_module, only : position
    use amrex_constants_module, only: four, M_PI
    use meth_params_module, only: NVAR, QRAD, URHO, UTEMP
    use prob_params_module, only : probhi
    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer :: lo(3), hi(3)
    integer :: s_lo(3), s_hi(3)
    integer, intent(in) :: ind
    real(rt)        :: xlo(1), xhi(1), time, delta(1)
    real(rt)        :: state(s_lo(1):s_hi(1),s_lo(2):s_hi(2),s_lo(3):s_hi(3),NVAR)
    real(rt)        :: temp

    ! Local variables

    integer :: i, j, k
    real(rt)         :: r(3), xx, dx

    do k = lo(3), hi(3)
       do j = lo(2), hi(2)
          do i = lo(1), hi(1)

             if(i .eq. ind) then
                temp = state(i,j,k,UTEMP)
              endif

          enddo
       enddo
    enddo

end subroutine gas_temp_rs

subroutine gas_temp_cd(state,s_lo,s_hi, &
                          lo, hi, dx, time, &
                          ind, temp) bind(C)
    use castro_util_module, only : position
    use amrex_constants_module, only: four, M_PI
    use meth_params_module, only: NVAR, QRAD, URHO, UTEMP
    use prob_params_module, only : probhi
    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer :: lo(3), hi(3)
    integer :: s_lo(3), s_hi(3)
    integer, intent(in) :: ind
    real(rt)        :: xlo(1), xhi(1), time, delta(1)
    real(rt)        :: state(s_lo(1):s_hi(1),s_lo(2):s_hi(2),s_lo(3):s_hi(3),NVAR)
    real(rt)        :: temp

    ! Local variables

    integer :: i, j, k
    real(rt)         :: r(3), xx, dx

    do k = lo(3), hi(3)
       do j = lo(2), hi(2)
          do i = lo(1), hi(1)

             if(i .eq. ind) then
                temp = state(i,j,k,UTEMP)
              endif

          enddo
       enddo
    enddo

end subroutine gas_temp_cd

subroutine gas_temp_fs(state,s_lo,s_hi, &
                          lo, hi, dx, time, &
                          ind, temp) bind(C)
    use castro_util_module, only : position
    use amrex_constants_module, only: four, M_PI
    use meth_params_module, only: NVAR, QRAD, URHO, UTEMP
    use prob_params_module, only : probhi
    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer :: lo(3), hi(3)
    integer :: s_lo(3), s_hi(3)
    integer, intent(in) :: ind
    real(rt)        :: xlo(1), xhi(1), time, delta(1)
    real(rt)        :: state(s_lo(1):s_hi(1),s_lo(2):s_hi(2),s_lo(3):s_hi(3),NVAR)
    real(rt)        :: temp

    ! Local variables

    integer :: i, j, k
    real(rt)         :: r(3), xx, dx

    do k = lo(3), hi(3)
       do j = lo(2), hi(2)
          do i = lo(1), hi(1)

             if(i .eq. ind) then
                temp = state(i,j,k,UTEMP)
              endif

          enddo
       enddo
    enddo

end subroutine gas_temp_fs

subroutine gas_temp_phot(state,s_lo,s_hi, &
                          lo, hi, dx, time, &
                          ind, temp) bind(C)
    use castro_util_module, only : position
    use amrex_constants_module, only: four, M_PI
    use meth_params_module, only: NVAR, QRAD, URHO, UTEMP
    use prob_params_module, only : probhi
    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer :: lo(3), hi(3)
    integer :: s_lo(3), s_hi(3)
    integer, intent(in) :: ind
    real(rt)        :: xlo(1), xhi(1), time, delta(1)
    real(rt)        :: state(s_lo(1):s_hi(1),s_lo(2):s_hi(2),s_lo(3):s_hi(3),NVAR)
    real(rt)        :: temp

    ! Local variables

    integer :: i, j, k
    real(rt)         :: r(3), xx, dx

    do k = lo(3), hi(3)
       do j = lo(2), hi(2)
          do i = lo(1), hi(1)

             if(i .eq. ind) then
                temp = state(i,j,k,UTEMP)
              endif

          enddo
       enddo
    enddo

end subroutine gas_temp_phot

subroutine vel_rs(state,s_lo,s_hi, &
                          lo, hi, dx, time, &
                          ind, vel) bind(C)
    use castro_util_module, only : position
    use amrex_constants_module, only: four, M_PI
    use meth_params_module, only: NVAR, QRAD, URHO, UMX
    use prob_params_module, only : probhi
    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer :: lo(3), hi(3)
    integer :: s_lo(3), s_hi(3)
    integer, intent(in) :: ind
    real(rt)        :: xlo(1), xhi(1), time, delta(1)
    real(rt)        :: state(s_lo(1):s_hi(1),s_lo(2):s_hi(2),s_lo(3):s_hi(3),NVAR)
    real(rt)        :: vel

    ! Local variables

    integer :: i, j, k
    real(rt)         :: r(3), xx, dx

    do k = lo(3), hi(3)
       do j = lo(2), hi(2)
          do i = lo(1), hi(1)

             if(i .eq. ind) then
                vel = state(i,j,k,UMX)/state(i,j,k,URHO)
              endif

          enddo
       enddo
    enddo

end subroutine vel_rs

subroutine vel_cd(state,s_lo,s_hi, &
                          lo, hi, dx, time, &
                          ind, vel) bind(C)
    use castro_util_module, only : position
    use amrex_constants_module, only: four, M_PI
    use meth_params_module, only: NVAR, QRAD, URHO, UMX
    use prob_params_module, only : probhi
    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer :: lo(3), hi(3)
    integer :: s_lo(3), s_hi(3)
    integer, intent(in) :: ind
    real(rt)        :: xlo(1), xhi(1), time, delta(1)
    real(rt)        :: state(s_lo(1):s_hi(1),s_lo(2):s_hi(2),s_lo(3):s_hi(3),NVAR)
    real(rt)        :: vel

    ! Local variables

    integer :: i, j, k
    real(rt)         :: r(3), xx, dx

    do k = lo(3), hi(3)
       do j = lo(2), hi(2)
          do i = lo(1), hi(1)

             if(i .eq. ind) then
                vel = state(i,j,k,UMX)/state(i,j,k,URHO)
              endif

          enddo
       enddo
    enddo

end subroutine vel_cd

subroutine vel_fs(state,s_lo,s_hi, &
                          lo, hi, dx, time, &
                          ind, vel) bind(C)
    use castro_util_module, only : position
    use amrex_constants_module, only: four, M_PI
    use meth_params_module, only: NVAR, QRAD, URHO, UMX
    use prob_params_module, only : probhi
    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer :: lo(3), hi(3)
    integer :: s_lo(3), s_hi(3)
    integer, intent(in) :: ind
    real(rt)        :: xlo(1), xhi(1), time, delta(1)
    real(rt)        :: state(s_lo(1):s_hi(1),s_lo(2):s_hi(2),s_lo(3):s_hi(3),NVAR)
    real(rt)        :: vel

    ! Local variables

    integer :: i, j, k
    real(rt)         :: r(3), xx, dx

    do k = lo(3), hi(3)
       do j = lo(2), hi(2)
          do i = lo(1), hi(1)

             if(i .eq. ind) then
                vel = state(i,j,k,UMX)/state(i,j,k,URHO)
              endif

          enddo
       enddo
    enddo

end subroutine vel_fs

subroutine phot_velocity(state,s_lo,s_hi, &
                          lo, hi, dx, time, &
                          ind, vel) bind(C)
    use castro_util_module, only : position
    use amrex_constants_module, only: four, M_PI
    use meth_params_module, only: NVAR, QRAD, URHO, UMX
    use prob_params_module, only : probhi
    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer :: lo(3), hi(3)
    integer :: s_lo(3), s_hi(3)
    integer, intent(in) :: ind
    real(rt)        :: xlo(1), xhi(1), time, delta(1)
    real(rt)        :: state(s_lo(1):s_hi(1),s_lo(2):s_hi(2),s_lo(3):s_hi(3),NVAR)
    real(rt)        :: vel

    ! Local variables

    integer :: i, j, k
    real(rt)         :: r(3), xx, dx

    do k = lo(3), hi(3)
       do j = lo(2), hi(2)
          do i = lo(1), hi(1)

             if(i .eq. ind) then
                vel = state(i,j,k,UMX)/state(i,j,k,URHO)
              endif

          enddo
       enddo
    enddo

end subroutine phot_velocity

subroutine lum_fs_shock(state,s_lo,s_hi, &
                          lo, hi, dx, time, &
                          lum,i_fs) bind(C)
    use castro_util_module, only : position
    use amrex_constants_module
    use fundamental_constants_module, only: c_light
    use meth_params_module, only: NVAR, QRAD, URHO, UMX, USHK, UFX
    use prob_params_module, only : probhi
    use probdata_module, only : kap
    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer :: lo(3), hi(3)
    integer :: s_lo(3), s_hi(3), cd_lo(3), cd_hi(3)
    real(rt)        :: xlo(1), xhi(1), time, delta(1)
    real(rt)        :: state(s_lo(1):s_hi(1),s_lo(2):s_hi(2),s_lo(3):s_hi(3),NVAR)
    real(rt)        :: lum

    integer :: i_fs

    ! Local variables

    integer :: i, j, k
    real(rt)         :: r(3), xx, dx
    real(rt)         :: lfac

    lfac = 9.e0_rt*M_PI/8.e0_rt

    do k = lo(3), hi(3)
       do j = lo(2), hi(2)
          do i = lo(1)+2, hi(1)-2

             r = position(i,j,k)

             if (i .eq. i_fs) then
              lum = lfac*r(1)*r(1)*state(i,j,k,UMX)**3/state(i,j,k,URHO)**2
            endif

          enddo
       enddo
    enddo

end subroutine lum_fs_shock

subroutine lum_rs_shock(state,s_lo,s_hi, &
                          lo, hi, dx, time, &
                          lum) bind(C)
    use castro_util_module, only : position
    use amrex_constants_module
    use fundamental_constants_module, only: c_light
    use meth_params_module, only: NVAR, QRAD, URHO, UMX, USHK, UFX
    use prob_params_module, only : probhi
    use probdata_module, only : kap
    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer :: lo(3), hi(3)
    integer :: s_lo(3), s_hi(3)
    real(rt)        :: xlo(1), xhi(1), time, delta(1)
    real(rt)        :: state(s_lo(1):s_hi(1),s_lo(2):s_hi(2),s_lo(3):s_hi(3),NVAR)
    real(rt)        :: lum

    ! Local variables

    integer :: i, j, k
    real(rt)         :: r(3), xx, dx
    real(rt)         :: lfac

    lfac = 9.e0_rt*M_PI/8.e0_rt

    do k = lo(3), hi(3)
       do j = lo(2), hi(2)
          do i = lo(1)+2, hi(1)-2

             r = position(i,j,k)

             if (state(i,j,k,USHK) > ZERO .and. state(i,j,k,UFX)/state(i,j,k,URHO) > HALF) then
              lum = lfac*r(1)*r(1)*(state(i-2,j,k,UMX)/state(i-2,j,k,URHO)-state(i+2,j,k,UMX)/state(i+2,j,k,URHO))**3*state(i,j,k,URHO)
              lum = abs(lum)
            endif

          enddo
       enddo
    enddo

end subroutine lum_rs_shock

subroutine cdshock(cd_mask, s_lo, s_hi, lo, hi, dx, time, r_cd,i_cd) bind(C,name='cdshock')

  use amrex_constants_module, only: ZERO,HALF
  use castro_util_module, only : position
  !use meth_params_module, only: NVAR, QRAD, URHO, UMX, USHK, UFX
  use amrex_fort_module, only : rt => amrex_real
  implicit none

  integer         ,  intent(in) :: s_lo(3), s_hi(3)

  double precision,  intent(in) :: cd_mask(s_lo(1):s_hi(1),s_lo(2):s_hi(2),s_lo(3):s_hi(3))

  integer         ,  intent(in) :: lo(3), hi(3)

  double precision,  intent(in) :: dx, time

  double precision,  intent(inout) :: r_cd

  integer         ,  intent(inout) :: i_cd

  integer :: i,j,k

  double precision :: r(3)

  !i_cd = 0

  do k = lo(3),hi(3)
    do j = lo(2),hi(2)
      do i = lo(1),hi(1)

        r = position(i,j,k)

        if (cd_mask(i,j,k) > ZERO) then
          if(r(1) < r_cd)then
          r_cd = r(1)
          i_cd = i
        endif
        endif

      enddo
    enddo
  enddo

end subroutine cdshock

subroutine csm_edge(csm_mask, r_lo, r_hi, lo, hi, dx, time, r_csm,i_csm) bind(C,name='csm_edge')

  use amrex_constants_module, only: HALF
  use castro_util_module, only : position

  implicit none

  integer         ,  intent(in) :: r_lo(3), r_hi(3)

  double precision,  intent(in) :: csm_mask(r_lo(1):r_hi(1),r_lo(2):r_hi(2),r_lo(3):r_hi(3))

  integer         ,  intent(in) :: lo(3), hi(3)

  double precision,  intent(in) :: dx, time

  double precision,  intent(inout) :: r_csm

  integer         ,  intent(inout) :: i_csm

  integer :: i,j,k

  double precision :: r(3)

  do k = lo(3),hi(3)
    do j = lo(2),hi(2)
      do i = lo(1),hi(1)

        r = position(i,j,k)

        if (csm_mask(i,j,k) > HALF) then
          if(r(1) .gt. r_csm) then
          r_csm = r(1)
          i_csm = i
        endif
        endif

      enddo
    enddo
  enddo

end subroutine csm_edge

subroutine rs_radius(state, s_lo, s_hi, lo, hi, dx, time, r_rs,i_rs) bind(C,name='rs_radius')

  use amrex_constants_module, only: ZERO
  use castro_util_module, only : position
  use meth_params_module, only: NVAR, QRAD, URHO, UMX, USHK, UFX
  use amrex_fort_module, only : rt => amrex_real
  implicit none

  integer         ,  intent(in) :: s_lo(3), s_hi(3)

  double precision,  intent(in) :: state(s_lo(1):s_hi(1),s_lo(2):s_hi(2),s_lo(3):s_hi(3),NVAR)

  integer         ,  intent(in) :: lo(3), hi(3)

  double precision,  intent(in) :: dx, time

  double precision,  intent(inout) :: r_rs

  integer         ,  intent(inout) :: i_rs

  integer :: i,j,k

  double precision :: r(3)

  do k = lo(3),hi(3)
    do j = lo(2),hi(2)
      do i = lo(1),hi(1)

        r = position(i,j,k)

        if (state(i,j,k,USHK) > ZERO .and. state(i,j,k,UFX)/state(i,j,k,URHO) > 0.9e0_rt) then
          if(r(1) < r_rs) then
          r_rs = r(1)
          i_rs = i
        endif
        endif

      enddo
    enddo
  enddo

end subroutine rs_radius

subroutine fs_radius(state, s_lo, s_hi, lo, hi, dx, time, r_fs,i_fs) bind(C,name='fs_radius')

  use amrex_constants_module, only: ZERO
  use castro_util_module, only : position
  use meth_params_module, only: NVAR, QRAD, URHO, UMX, USHK, UFX, QTEMP
  use probdata_module, only: rho_a
  use amrex_fort_module, only : rt => amrex_real
  implicit none

  integer         ,  intent(in) :: s_lo(3), s_hi(3)

  double precision,  intent(in) :: state(s_lo(1):s_hi(1),s_lo(2):s_hi(2),s_lo(3):s_hi(3),NVAR)

  integer         ,  intent(in) :: lo(3), hi(3)

  double precision,  intent(in) :: dx, time

  double precision,  intent(inout) :: r_fs

  integer         ,  intent(inout) :: i_fs

  integer :: i,j,k

  double precision :: r(3)

  do k = lo(3),hi(3)
    do j = lo(2),hi(2)
      do i = lo(1),hi(1)

        r = position(i,j,k)

        if (state(i,j,k,USHK) > ZERO .and. state(i,j,k,UFX+1)/state(i,j,k,URHO) > 0.9e0_rt) then
        !  if(state(i,j,k,UMX)/state(i,j,k,URHO) .gt. 1.0e5_rt) then
          if(r(1) < r_fs) then
          r_fs = r(1)
          i_fs = i
      !  endif
        endif
        endif

      enddo
    enddo
  enddo

end subroutine fs_radius


	Subroutine TextRead(id,nid,panel)

	Implicit none

	Include 'common1.h'
	Include 'common2.h'
	Include 'common3.h'

        Integer nid,id(nid),imax,jmax,kmax,data_format,panel
	Real temp_array(512,512)

	Open (unit=54,file=data_file,status="unknown")

	Print*, '*************************'
	Print*, '1.  P3'
	Print*, '2.  HURRICANE'
	Print*, '3.  PRESSURE'
	Print*, '4.  WEN-CHAU'
	Print*
	Print*, 'Please enter the data format you wish to plot:'
	Read*, data_format

	IF (data_format.LT.4) THEN
C Read the initial parameters for 1st 3 formats
	   Call ReadData(id,nid,imax,jmax,kmax,panel)
 	ENDIF

	IF (data_format.EQ.1) THEN  !PROCESS P3
C Read data from the P3 format
	  Call StoreDataP3(id,nid,imax,jmax,kmax,temp_array,data_format)
C Calc stats for P3 data
	  Call Calc_Stats(imax,jmax,kmax)
	ELSEIF (data_format.EQ.2) THEN
	  Call StoreData(id,nid,imax,jmax,temp_array)
        ELSEIF (data_format.EQ.3) THEN
	  Call StoreDataP3(id,nid,imax,jmax,kmax,temp_array,data_format)
        ELSEIF (data_format.EQ.4) THEN
	  Call WenChau(id,nid,panel)
	ENDIF

	Close(unit=54)

	Return
	End
**************************************************
	Subroutine ReadData(id,nid,imax,jmax,kmax,panel)

	Implicit none

	Include 'common1.h'
	Include 'common2.h'
	Include 'common3.h'

        Integer nid,id(nid),imax,jmax,kmax,Nmosm
	Integer yr,mon,day,hr,mn,sec,panel
	Real sx,sy,sz,Olat,Olong,z0,Su,Sv,Baddata

* Read array header & store in id
        Read (54,15),imax,jmax,kmax,sx,sy,sz,Olat,Olong,z0,Nmosm,Su,Sv,
     $                Baddata,yr,mon,day,hr,mn,sec
15      Format (3I5,6F8.2,I5,3F8.2,1X,3I2,1X,3I2)

        id(162) = imax
        id(167) = jmax
        id(172) = kmax
        id(163) = int(sx*1000)
        id(168) = int(sy*1000)
        id(173) = int(sz*1000)
        id(33) = int(Olat)
        id(34) = nint((Olat-id(33))*60)
        id(35) = 0
        id(36) = int(Olong)
        id(37) = nint((Olong-id(36))*60)
        id(38) = 0
        id(170) = z0*1000
        id(116) = yr
        id(117) = mon
        id(118) = day
        id(119) = hr
        id(120) = mn
        id(121) = sec
        id(160) = 0*100
        id(161) = id(160) + (id(163)*.1*(id(162)-1))
*        id(165) = 0*100
        id(165) = 30*100
        id(166) = id(165) + (id(168)*.1*(id(167)-1))
        id(171) = id(170) + (id(173)*(id(172)-1))

C CALCULATE THE LEVEL

        IF (fix_axis.EQ.'Z'.OR.fix_axis.EQ.'z') THEN
           fix_beg=id(170)/float(1000) !convert to km
           fix_inc=id(173)/float(1000) !convert to km
        ELSEIF (fix_axis.EQ.'Y'.OR.fix_axis.EQ.'y') THEN
           fix_beg=id(165)/float(id(68)) !scale factor
           fix_inc=id(168)/float(1000) !convert to km
        ELSEIF (fix_axis.EQ.'X'.OR.fix_axis.EQ.'x') THEN
           fix_beg=id(160)/float(id(68)) !scale factor
           fix_inc=id(163)/float(1000)   !convert to km
        ENDIF

        IF (level_flag.EQ.'D'.OR.level_flag.EQ.'d') THEN
           level=nint(((plots(panel)-fix_beg)/fix_inc)+1)
	ENDIF

	Return
	End
**************************************************
	Subroutine StoreData(id,nid,imax,jmax,temp_array)

	Implicit none

	Include 'common1.h'
	Include 'common2.h'
	Include 'common3.h'

	integer id,nid,imax,jmax,i,j,k,str_index(4),num
	Real temp_array(imax,jmax)
	Character*25 field
	Character*3 match

C The names of the fields are stored in the array str

	field='EMPTY_FIELD'
	k=0
	num=1

C Initialize the data array
	DO k=1,4
	 DO i=1,imax
	  DO j=1,jmax
	   fld_data(i,j,k)=0.0
	  ENDDO
	 ENDDO
C count the characters in the fields
	 str_index(k)=index(str(k),' ')-1
	ENDDO

	k=0

C Read the data & store it into a temporary array
10	IF (field(1:8).NE.'colornum'.AND.num.LE.4) THEN
	 Read (54,*),field
C Check for correct field
	 IF (field(1:str_index(num)).EQ.str(num)(1:str_index(num))) THEN
	  Read (54,*),temp_array
	  k=k+1
	  match='yes'
	 ELSE
	  match='no'
	 ENDIF

	 IF (match.EQ.'yes') THEN
C Threshold the data
	  IF (field(1:7).EQ.'meanref') THEN
	   DO i=1,imax
	    DO j=1,jmax
	     IF (temp_array(i,j).GT.50) temp_array(i,j) = -999.0
	    ENDDO
	   ENDDO
	  ELSEIF (field(1:6).EQ.'twinds') THEN
	   DO i=1,imax
	    DO j=1,jmax
	     IF (temp_array(i,j).LT.0) temp_array(i,j) = -999.0
	    ENDDO
	   ENDDO
	  ELSEIF (field(1:7).EQ.'ang_mom') THEN
	   DO i=1,imax
	    DO j=1,jmax
	     temp_array(i,j)=temp_array(i,j)*.0001
	    ENDDO
	   ENDDO
	  ENDIF
C Store the data in fld_data
	  DO i=1,imax
	   DO j=1,jmax
	    fld_data(i,j,k)=temp_array(i,j)
	   ENDDO
	  ENDDO
	  Rewind(unit=54)
	  Read (54,*)
	  num=num+1
	 ELSE
*	  DO i=1,imax
*	   Read (54,*)
	   Read (54,*),temp_array
*	  ENDDO
	 ENDIF

	 go to 10
	ENDIF

	Return
	End
**************************************************
	Subroutine StoreDataP3(id,nid,imax,jmax,kmax,
     X    temp_array,data_format)

	Implicit none

	Include 'common1.h'
	Include 'common2.h'
	Include 'common3.h'

	Integer id,nid,imax,jmax,kmax,i,j,k,m,field
	Integer data_pos(4),data_format
	Real temp_array(imax,jmax)

	Open (unit=602,file="data.out",status="unknown")

C  ORDER OF P3 DATA
C  1=U (horizontal wind)
C  2=V (vertical wind)
C  3=W (vertical velocity)
C  4=Z (Reflectivity)
C  5=D (Adjusted divergence)

C Figure out the position in the data file and where to store it in
C the array

	IF (data_format.EQ.1) THEN
     	  DO i=1,4
    	   IF (fld_name(1,i).EQ."U") THEN
    	     data_pos(i)=1
    	   ELSEIF (fld_name(1,i).EQ."V") THEN
    	     data_pos(i)=2
    	   ELSEIF (fld_name(1,i).EQ."W") THEN
    	     data_pos(i)=3
    	   ELSEIF (fld_name(1,i).EQ."Z") THEN
    	     data_pos(i)=4
    	   ELSEIF (fld_name(1,i).EQ."D") THEN
    	     data_pos(i)=5
    	   ENDIF
    	  ENDDO
	  DO k=1,kmax
C Read the array
	    DO m=1,5
	     IF (m.GE.1.AND.m.LT.5) THEN
	       Read (54,11),temp_array
	     ELSE
	       Read (54,12),temp_array
	     ENDIF
C Store the array in fld_data
             IF (fix_axis.EQ.'Z'.OR.fix_axis.EQ.'z') THEN
	        DO field=1,4
	          IF (m.EQ.data_pos(field).AND.k.EQ.level) THEN
	            DO j=1,jmax
	              DO i=1,imax
	                fld_data(i,j,field)=temp_array(i,j)
	              ENDDO
	            ENDDO
	          ENDIF
	        ENDDO
             ELSEIF (fix_axis.EQ.'Y'.OR.fix_axis.EQ.'y') THEN
               DO field=1,4
                 IF (m.EQ.data_pos(field)) THEN
		   DO i=1,imax
		      fld_data(i,k,field)=temp_array(i,level)
		   ENDDO
	         ENDIF
               ENDDO
             ELSEIF (fix_axis.EQ.'X'.OR.fix_axis.EQ.'x') THEN
               DO field=1,4
                 IF (m.EQ.data_pos(field)) THEN
		    DO j=1,jmax
		       fld_data(j,k,field)=temp_array(level,j)
		    ENDDO
	         ENDIF
               ENDDO
             ENDIF
	    ENDDO
	  ENDDO

	ELSEIF (data_format.EQ.3) THEN
     	  DO i=1,4
    	   IF (fld_name(1,i).EQ."U") THEN
    	     data_pos(i)=1
    	   ELSEIF (fld_name(1,i).EQ."V") THEN
    	     data_pos(i)=2
    	   ELSEIF (fld_name(1,i).EQ."W") THEN
    	     data_pos(i)=3
    	   ELSEIF (fld_name(1,i).EQ."Z") THEN
    	     data_pos(i)=4
    	   ELSEIF (fld_name(1,i).EQ."P") THEN
    	     data_pos(i)=5
    	   ELSEIF (fld_name(1,i).EQ."T") THEN
    	     data_pos(i)=6
    	   ENDIF
    	  ENDDO
	  DO k=1,kmax
*C Read the array
	    DO m=1,6
	     Read (54,*)
             DO j=1,jmax
              read (54,11),( temp_array(i,j),i=1,imax)
             ENDDO
C Store the array in fld_data
             IF (fix_axis.EQ.'Z'.OR.fix_axis.EQ.'z') THEN
	       DO field=1,4
	         IF (m.EQ.data_pos(field).AND.k.EQ.level) THEN
	           DO j=1,jmax
	             DO i=1,imax
	               fld_data(i,j,field)=temp_array(i,j)
	             ENDDO
	           ENDDO
	         ENDIF
	       ENDDO
             ELSEIF (fix_axis.EQ.'Y'.OR.fix_axis.EQ.'y') THEN
               DO field=1,4
                 IF (m.EQ.data_pos(field)) THEN
		   DO i=1,imax
		      fld_data(i,k,field)=temp_array(i,level)
		   ENDDO
	         ENDIF
               ENDDO
             ELSEIF (fix_axis.EQ.'X'.OR.fix_axis.EQ.'x') THEN
               DO field=1,4
                 IF (m.EQ.data_pos(field)) THEN
		    DO j=1,jmax
		       fld_data(j,k,field)=temp_array(level,j)
		    ENDDO
	         ENDIF
               ENDDO
             ENDIF
	    ENDDO
	  ENDDO
  	ENDIF

10	Format(75f8.2)
11	Format(10f8.3)
12	Format(75f12.6)

	Return
	End
**************************************************
	Subroutine Calc_Stats(imax,jmax,kmax)

	Implicit none
	Include 'common1.h'
	Include 'common2.h'
	Include 'common3.h'

	Integer imax,jmax,kmax,i,j,k
	Integer begx1,endx1,begy1,endy1
	Integer begx2,endx2,begy2,endy2
	Integer u_num,v_num,w_num,div_num
	Real u_av,v_av,w_av,div_av
	Real u_std,v_std,w_std,div_std
	Real u_sum,v_sum,w_sum,div_sum

C Initialize values
	u_num=0
	v_num=0
	w_num=0
	div_num=0
	u_sum=0.0
	v_sum=0.0
	w_sum=0.0
	div_sum=0.0
    	u_av=0.0
    	v_av=0.0
    	w_av=0.0
    	div_av=0.0
    	u_std=0.0
    	v_std=0.0
    	w_std=0.0
    	div_std=0.0

	begx1=41
	endx1=61
	begy1=28
	endy1=41
	begx2=21
	endx2=48
	begy2=34
	endy2=48

	DO k=1,4
	  DO j=1,jmax
	    DO i=1,imax
	      IF (fld_data(i,j,k).GT.-100) THEN
  	       u_sum=u_sum+fld_data(i,j,k)
	       u_num=u_num+1
	      ELSEIF (fld_data(i,j,k).GT.-100) THEN
  	       v_sum=v_sum+fld_data(i,j,k)
	       v_num=v_num+1
	      ELSEIF (fld_data(i,j,k).GT.-100) THEN
  	       w_sum=w_sum+fld_data(i,j,k)
	       w_num=w_num+1
	      ELSEIF (fld_data(i,j,k).GT.-100) THEN
  	       div_sum=div_sum+fld_data(i,j,k)
	       div_num=div_num+1
	      ENDIF
	    ENDDO
	  ENDDO
	ENDDO

	Return
	End
**************************************************
	Subroutine WenChau(id,nid,panel)

	Implicit none

	Include 'common1.h'
	Include 'common2.h'
	Include 'common3.h'
c	Include 'structure.h'

        Integer nid,id(nid),panel,i,j,k,m,levnum,azimuth
	Integer numfield,numlev,numaz,size,num
        Integer TRUE
        Integer FALSE
        Integer datafill(4)
	Character*8 field
	Character match
	Real array(512)

        TRUE=1
        FALSE=0

	Open (unit=54,file=data_file,status="unknown")

C READ THE ID HEADER ARRAY
	Read(54,*),id

C ASSIGN SCAN MODE
	call intswap(id(16),id(16))
	call intswap(id(17),id(17))
c	scan.id16=id(16)
c	scan.id17=id(17)
        scan_mode(1:1) = char(id(16))
	scan_mode(2:2) = char(id(16)/256)
        scan_mode(3:3) = char(id(17))
	scan_mode(4:4) = char(id(17)/256)
c	write(scan_mode,'(i2)')id(16),id(17)
c	print*,scan_mode,id(16),id(17)
	Print*, 'Processing panel ', panel
	IF (scan_mode.EQ.'POLA') THEN
10	   Print*, 'Is data in math coordinates?? [Y/N]'
	   Read*, math_flag
	   IF (math_flag.EQ.'y') math_flag = 'Y'
	   IF (math_flag.EQ.'n') math_flag = 'N'
	   IF (math_flag.NE.'Y'.AND.math_flag.NE.'N') go to 10
C CALCULATE THE CENTER OF THE STORM IN RELATIONSHIP TO THE ORIGIN
           IF (math_flag.EQ.'N') THEN
              xc = real(id(309) / id(68))
              yc = real(id(310) / id(68))
           ENDIF
	ENDIF
C CALCULATE THE LEVEL
        IF (fix_axis.EQ.'Z'.OR.fix_axis.EQ.'z') THEN
           fix_beg=id(170)/float(1000) !convert to km
           fix_inc=id(173)/float(1000) !convert to km
        ELSEIF (fix_axis.EQ.'Y'.OR.fix_axis.EQ.'y') THEN
	   IF (scan_mode.EQ.'POLA') THEN
              fix_beg=id(165)/float(id(69))  !angle scale factor
           ELSE
              fix_beg=id(165)/float(id(68))  !general scale factor
	   ENDIF
           fix_inc=id(168)/float(1000) !convert to km
        ELSEIF (fix_axis.EQ.'X'.OR.fix_axis.EQ.'x') THEN
           fix_beg=id(160)/float(id(68))  !general scale factor
           fix_inc=id(163)/float(1000) !convert to km
        ENDIF

        IF (level_flag.EQ.'D'.OR.level_flag.EQ.'d') THEN
           level=nint(((plots(panel)-fix_beg)/fix_inc)+1)
	ENDIF

    	numlev=id(172)
	numaz=id(167)
	numfield=id(175)
	size=id(162)
	DO i=1,numlev
	   Read(54,20),levnum
	   DO j=1,numaz
              DO m=1,4
	         datafill(m)=FALSE
	      ENDDO
	      Read(54,21),azimuth
c              print *, azimuth, levnum
	      DO k=1,numfield
	         Read(54,22),field
		 match='N'
		 num=1
*11		 IF (match.EQ.'N'.AND.num.LE.4) THEN
11		 IF (num.LE.4) THEN
		    IF (field(1:2).EQ.fld_name(1,num).AND.
     $	 	        field(3:4).EQ.fld_name(2,num).AND.
     $			field(5:6).EQ.fld_name(3,num).AND.
     $			field(7:8).EQ.fld_name(4,num).AND.
     $                  datafill(num).NE.TRUE) THEN
			   IF (match.EQ.'N') THEN
 	                      Call GetData(array,size)
			   ENDIF
 			   match='Y'
     			   datafill(num)=TRUE
C			   IF ( (fix_axis.EQ.'Z'.AND.levnum.EQ.level)
C     $  			 .OR.fix_axis.EQ.'Y'
C     $				 .OR.fix_axis.EQ.'X') THEN
C		 	      scalefld(num)=id(180+(5*(k-1)))
C			      Call FillArray(id,nid,array,size,azimuth,
C     $					     levnum,num)
C			   ENDIF
			   IF ( fix_axis.EQ.'Z'.AND.levnum.EQ.level ) THEN
		 	      scalefld(num)=id(180+(5*(k-1)))
			      Call FillArray(id,nid,array,size,azimuth,
     $					     levnum,num)
			   ELSEIF ( fix_axis.EQ.'Y'.AND.azimuth.EQ.level ) THEN
		 	      scalefld(num)=id(180+(5*(k-1)))
			      Call FillArray(id,nid,array,size,azimuth,
     $					     levnum,num)
			   ELSEIF ( fix_axis.EQ.'X' ) THEN
		 	      scalefld(num)=id(180+(5*(k-1)))
			      Call FillArray(id,nid,array,size,azimuth,
     $					     levnum,num)
			   ENDIF
 		    ELSE
 		       num=num+1
 		    ENDIF
 		    go to 11
		 ENDIF
 		 IF (match.EQ.'N') THEN
 	            Call GetData(array,size)
 		 ENDIF
	      ENDDO
	   ENDDO
	ENDDO

20	Format(5x,i2)
21	Format(7x,i3)
22	Format(A8)
23	Format(8E10.3)

	Close(unit = 54)

	Return
	End
**************************************************
	Subroutine GetData(array,size)

	Integer size,i
	Real array(size)

	Read(54,10),array

10	Format(8E10.3)

	Return
	End
**************************************************
	Subroutine FillArray(id,nid,array,numx,y,z,fieldnum)

	Implicit none

	Include 'common1.h'
	Include 'common2.h'
	Include 'common3.h'

        Integer nid,id(nid),fieldnum,x,y,z,lev,numx
	Real array(numx)

C FIXED AXIS=Z
	IF (fix_axis.EQ.'Z'.OR.fix_axis.EQ.'z') THEN
	      DO X=1,numx
	         fld_data(x,y,fieldnum)=array(x)
	      ENDDO
C FIXED AXIS=Y
	ELSEIF (fix_axis.EQ.'Y'.OR.fix_axis.EQ.'y') THEN
	   DO X=1,numx
	      fld_data(x,z,fieldnum)=array(x)
	   ENDDO
C FIXED AXIS=X
	ELSEIF (fix_axis.EQ.'X'.OR.fix_axis.EQ.'x') THEN
           fld_data(y,z,fieldnum)=array(level)
	ENDIF

	Return
	End

      subroutine intswap(oldint,newint)
      implicit none
      integer oldint,int1,int2,newint
      int1 = mod(oldint,256)
      int2 = (oldint - int1)/256
      newint = int1*256 + int2
      return
      end


*
*     -------------------------------------------------------------
*       C A L C U L
*     -------------------------------------------------------------
*                                                                  *
*     Written by G. Gaigalas,                                      *
*     Vanderbilt University,  Nashville           September 1997   *
*
      SUBROUTINE CALCUL(NPAIR)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      LOGICAL rel,vok
      COMMON /DEBUG/IBUG1,IBUG2,IBUG3,NBUG6,NBUG7,IFULL
      COMMON /INOUT/IREAD,IWRITE,ISCW,iuc(2),iuw(2),iul(2),iuj(2)
      COMMON /MEDEFN/IHSH,NJ(16),LJ(16),NOSH1(16),NOSH2(16),J1QN1(31,3),
     :J1QN2(31,3),IJFUL(16)
      COMMON /EMS/IEM(4),IFL,JI,JF,LAM,REL,VOK
      COMMON /STATE/QET1,QLBL1,QWT1,QJV1,QET2,QLBL2,QWT2,QJV2,NJV(2),
     : NVC(2),LGTH(2),NCF(2),QCFG1,QCFG2
      POINTER(QET1,ET1(1)),(QLBL1,LBL1(1)),(QWT1,WT1(1)),(QJV1,JV1(1)),
     :       (QET2,ET2(1)),(QLBL2,LBL2(1)),(QWT2,WT2(1)),(QJV2,JV2(1)),
     :       (QCFG1,CFG1(8,1)),(QCFG2,CFG2(8,1))
      COMMON /MULT/QSL,QSV,QIL,QIR,QJVL,QJVR
      POINTER(QSL,SL(1)),(QSV,SV(1)),(QIL,IL(1)),(QIR,IR(1)),
     :       (QJVL,JVL(1)),(QJVR,JVR(1))
      COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS
    5 FORMAT(//,' JI =',I4,'  JF =',I4)
      KA=LAM
      KB=0
      IREZ=1
      IF(IFL.EQ.3)IREZ=2
      DO 1 IIFLL=1,IREZ
        IF (IIFLL.EQ.2) THEN
          IFL=4
          KA=LAM-1
          KB=1
        ENDIF
        DO 2 JII=1,NCF(1)
	  JI=JII
          IF(MOD(JI,10).EQ.0) print*,' JA = ',JI
          DO 3 JFI=1,NCF(2)
	    JF=JFI
            if(npair.eq.0) then
              print*,' ji = ',ji,' jf = ',jf
              stop
            end if
            NCONTR = 0
            IF(NBUG6.NE.0) WRITE(IWRITE,5) JI,JF
            JFF = JF+NCF(1)
            CALL SETUP(JI,JFF)
*
* --- test selection rules delta(S)=0 for Ek and M1
*                          delta(L)=0 for M1
            N1=2*IHSH-1
            ITIK=1
            IF(ITTK(J1QN1(N1,2)-1,J1QN2(N1,2)-1,2*KA).EQ.0)ITIK=0
            IF(ITTK(J1QN1(N1,3)-1,J1QN2(N1,3)-1,2*KB).EQ.0)ITIK=0
	    IF(ITIK.NE.0) THEN
              CALL NONTRANS(KA,KB,CL2,CV2)
*
* --- calculate the contribution of <JI/ O /JF> to the line
*     strengths for the npair (J,J') found
              IF(DABS(CL2).GT.ZERO.OR.DABS(CV2).GT.ZERO) THEN
                do 4 k = 1,npair
                  kl=(il(k)-1)*ncf(1)+ji
                  kr=(ir(k)-1)*ncf(2)+jf
                  fww=fline(k)*wt1(kl)*wt2(kr)
                  sl(k) = sl(k) + cl2*fww
                  if(vok) sv(k) = sv(k) + cv2*fww
                  if(ibug1.ne.0) then
                    print*,' pair = ',k,
     :                   ' wt1 = ',wt1(kl),' wt2 = ',wt2(kr)
                    print*,'              sl(pair) = ',sl(k)
                  end if
    4           continue
              ENDIF
            ENDIF
    3     CONTINUE
    2   CONTINUE
    1 CONTINUE
      RETURN
      END