text:
      subroutine qinit(maxmx,maxmy,meqn,mbc,mx,my,
     &      xlower,ylower,dx,dy,q,maux,aux)

      implicit none

      integer meqn, mbc, mx, my, maux,maxmx,maxmy
      double precision xlower, ylower, dx, dy
      double precision q(1-mbc:mx+mbc, 1-mbc:my+mbc, meqn)
      double precision aux(1-mbc:mx+mbc, 1-mbc:my+mbc, maux)

      integer i,j
      double precision x,y,xp,yp,zp
      double precision gaussian_sum
      double precision r,hmax,b,c
      integer blockno, fc2d_clawpack46_get_block
      integer*8 cont, get_context

      cont = get_context()
      blockno = fc2d_clawpack46_get_block()

      do j = 1-mbc,my+mbc
         do i = 1-mbc,mx+mbc
            x = xlower + (i-1)*dx
            y = ylower + (j-1)*dy
            call fclaw2d_map_c2m(cont,blockno,x,y,xp,yp,zp)
            q(i,j,1) = gaussian_sum(xp,yp,zp) + 0.2d0
            q(i,j,2) = 0
            q(i,j,3) = 0
            q(i,j,4) = 0
         enddo
      enddo

      return
      end

ext: f

max_stars_repo_name: ECLAIRWaveS/ForestClaw

max_issues_repo_name: ECLAIRWaveS/ForestClaw

max_forks_repo_name: ECLAIRWaveS/ForestClaw


subroutine evalqlim(sval,pbc,rval)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    evalqlim
!   prgmmr: tremolet
!
! abstract: Computes Jq component
!
! program history log:
!   2007-03-01  tremolet
!   2008-12-8   todling - updated to GSI-May08
!   2009-01-15  todling - carry summation in quadruple precision
!   2009-08-14  lueken  - update documentation
!   2010-03-23  derber - made consistent with stplimq and intlimq (but not checked)
!   2010-05-05  derber - omp commands removed
!   2010-05-13  todling - udpate to use gsi_bundle; interface change
!   2019-03-05  martin - update to weight factqmin/max by latitude
!
!   input argument list:
!    sq
!    rq
!    pbc
!
!   output argument list:
!    rq
!    pbc
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
  use kinds, only: r_kind,i_kind,r_quad
  use constants, only: zero,one,zero_quad
  use gridmod, only: lat1,lon1,nsig,istart,wgtfactlats
  use jfunc, only: factqmin,factqmax
  use derivsmod, only: qgues,qsatg
  use mpl_allreducemod, only: mpl_allreduce
  use gsi_bundlemod, only: gsi_bundle
  use gsi_bundlemod, only: gsi_bundlegetpointer
  use mpimod, only: mype
  implicit none

! Declare passed variables
  type(gsi_bundle),intent(in   ) :: sval
  type(gsi_bundle),intent(inout) :: rval
  real(r_quad)      ,intent(inout) :: pbc

! Declare local variables
  integer(i_kind) i,j,k,ier,istatus,ii,mm1
  real(r_quad) :: zbc(2)
  real(r_kind) :: q,term
  real(r_kind),pointer,dimension(:,:,:) :: sq
  real(r_kind),pointer,dimension(:,:,:) :: rq

  pbc=zero_quad
  if (factqmin==zero .and. factqmax==zero) return

! Retrieve pointers
! Simply return if any pointer not found
  ier=0
  call gsi_bundlegetpointer(sval,'q',sq,istatus);ier=istatus+ier
  call gsi_bundlegetpointer(rval,'q',rq,istatus);ier=istatus+ier
  if(ier/=0)return

  mm1 = mype+1

  zbc=zero_quad
! Loop over interior of subdomain
  do k = 1,nsig
     do j = 2,lon1+1
        do i = 2,lat1+1
           ii=istart(mm1)+i-2
!          Value for q
           q = qgues(i,j,k) + sq(i,j,k)
!          Compute penalty for neg q
           if (q<zero) then
              term = (factqmin*wgtfactlats(ii))*q&
                     /(qsatg(i,j,k)*qsatg(i,j,k))
              zbc(1) = zbc(1) + term*q
!             Adjoint
              rq(i,j,k) = rq(i,j,k) + term
           endif
!          Compute penalty for excess q
           if (q>qsatg(i,j,k)) then
              term=(factqmax*wgtfactlats(ii))*(q-qsatg(i,j,k))&
                   /(qsatg(i,j,k)*qsatg(i,j,k))
              zbc(2) = zbc(2) + term*(q-qsatg(i,j,k))
!             Adjoint
              rq(i,j,k) = rq(i,j,k) + term
           endif
        end do
     end do
  end do

! Reduce on all procs
  call mpl_allreduce(2,qpvals=zbc)
  pbc=pbc+zbc(1)+zbc(2)

  return
end subroutine evalqlim


    PROGRAM Testo
     USE Integer_Complex_Arithmetic
      IMPLICIT NONE

       PRINT*, "REAL(3,4)"
       PRINT*, REAL(INTCOMPLEX(3,4))
       PRINT*, "INT(3,4)"
       PRINT*, INT(INTCOMPLEX(3,4))
       PRINT*, "AIMAG(3,4)"
       PRINT*, AIMAG(INTCOMPLEX(3,4))
       PRINT*, "CONJG(3,4)"
       PRINT*, CONJG(INTCOMPLEX(3,4))
       PRINT*, "ABS(3,4)"
       PRINT*, ABS(INTCOMPLEX(3,4))

    END PROGRAM Testo


text:
! { dg-do compile }
! { dg-options "-fmax-errors=1000" }

program failme

  integer :: i, j, array(20)
  integer(kind=4) :: i4
  integer(kind=8) :: i8
  character(kind=1,len=20) :: s1, t1
  character(kind=4,len=20) :: s4, t4

  call ctime (i8, s1)
  call ctime (i8, s4) ! { dg-error "must be of kind" }

  call chdir (s1)
  call chdir (s1, i)
  call chdir (s4) ! { dg-error "must be of kind" }
  call chdir (s4, i) ! { dg-error "must be of kind" }

  call chmod (s1, t1)
  call chmod (s1, t4) ! { dg-error "must be of kind" }
  call chmod (s4, t1) ! { dg-error "must be of kind" }
  call chmod (s4, t4) ! { dg-error "must be of kind" }
  call chmod (s1, t1, i)
  call chmod (s1, t4, i) ! { dg-error "must be of kind" }
  call chmod (s4, t1, i) ! { dg-error "must be of kind" }
  call chmod (s4, t4, i) ! { dg-error "must be of kind" }

  call fdate (s1)
  call fdate (s4) ! { dg-error "must be of kind" }

  call gerror (s1)
  call gerror (s4) ! { dg-error "must be of kind" }

  call getcwd (s1)
  call getcwd (s1, i)
  call getcwd (s4) ! { dg-error "must be of kind" }
  call getcwd (s4, i) ! { dg-error "must be of kind" }

  call getenv (s1, t1)
  call getenv (s1, t4) ! { dg-error "Type of argument" }
  call getenv (s4, t1) ! { dg-error "Type of argument" }
  call getenv (s4, t4) ! { dg-error "Type of argument" }

  call getarg (i, s1)
  call getarg (i, s4) ! { dg-error "must be of kind" }

  call getlog (s1)
  call getlog (s4) ! { dg-error "must be of kind" }

  call fgetc (j, s1)
  call fgetc (j, s1, i)
  call fgetc (j, s4) ! { dg-error "must be of kind" }
  call fgetc (j, s4, i) ! { dg-error "must be of kind" }

  call fget (s1)
  call fget (s1, i)
  call fget (s4) ! { dg-error "must be of kind" }
  call fget (s4, i) ! { dg-error "must be of kind" }

  call fputc (j, s1)
  call fputc (j, s1, i)
  call fputc (j, s4) ! { dg-error "must be of kind" }
  call fputc (j, s4, i) ! { dg-error "must be of kind" }

  call fput (s1)
  call fput (s1, i)
  call fput (s4) ! { dg-error "must be of kind" }
  call fput (s4, i) ! { dg-error "must be of kind" }

  call hostnm (s1)
  call hostnm (s1, i)
  call hostnm (s4) ! { dg-error "must be of kind" }
  call hostnm (s4, i) ! { dg-error "must be of kind" }

  call link (s1, t1)
  call link (s1, t4) ! { dg-error "must be of kind" }
  call link (s4, t1) ! { dg-error "must be of kind" }
  call link (s4, t4) ! { dg-error "must be of kind" }
  call link (s1, t1, i)
  call link (s1, t4, i) ! { dg-error "must be of kind" }
  call link (s4, t1, i) ! { dg-error "must be of kind" }
  call link (s4, t4, i) ! { dg-error "must be of kind" }

  call perror (s1)
  call perror (s4) ! { dg-error "must be of kind" }

  call rename (s1, t1)
  call rename (s1, t4) ! { dg-error "must be of kind" }
  call rename (s4, t1) ! { dg-error "must be of kind" }
  call rename (s4, t4) ! { dg-error "must be of kind" }
  call rename (s1, t1, i)
  call rename (s1, t4, i) ! { dg-error "must be of kind" }
  call rename (s4, t1, i) ! { dg-error "must be of kind" }
  call rename (s4, t4, i) ! { dg-error "must be of kind" }

  call lstat (s1, array)
  call lstat (s1, array, i)
  call lstat (s4, array) ! { dg-error "must be of kind" }
  call lstat (s4, array, i) ! { dg-error "must be of kind" }

  call stat (s1, array)
  call stat (s1, array, i)
  call stat (s4, array) ! { dg-error "must be of kind" }
  call stat (s4, array, i) ! { dg-error "must be of kind" }

  call symlnk (s1, t1)
  call symlnk (s1, t4) ! { dg-error "must be of kind" }
  call symlnk (s4, t1) ! { dg-error "must be of kind" }
  call symlnk (s4, t4) ! { dg-error "must be of kind" }
  call symlnk (s1, t1, i)
  call symlnk (s1, t4, i) ! { dg-error "must be of kind" }
  call symlnk (s4, t1, i) ! { dg-error "must be of kind" }
  call symlnk (s4, t4, i) ! { dg-error "must be of kind" }

  call system (s1)
  call system (s1, i)
  call system (s4) ! { dg-error "Type of argument" }
  call system (s4, i) ! { dg-error "Type of argument" }

  call ttynam (i, s1)
  call ttynam (i, s4) ! { dg-error "must be of kind" }

  call unlink (s1)
  call unlink (s1, i)
  call unlink (s4) ! { dg-error "must be of kind" }
  call unlink (s4, i) ! { dg-error "must be of kind" }

end program failme

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


SUBROUTINE lubksb_sp(a,indx,b)
  use mo_nrtype
  use mo_nrutil, ONLY : assert_eq
  IMPLICIT NONE
  REAL(SP), DIMENSION(:,:), INTENT(IN) :: a
  INTEGER(I4), DIMENSION(:), INTENT(IN) :: indx
  REAL(SP), DIMENSION(:), INTENT(INOUT) :: b
  INTEGER(I4) :: i,n,ii,ll
  REAL(SP) :: summ
  n=assert_eq(size(a,1),size(a,2),size(indx),'lubksb')
  ii=0
  do i=1,n
     ll=indx(i)
     summ=b(ll)
     b(ll)=b(i)
     if (ii /= 0) then
        summ=summ-dot_product(a(i,ii:i-1),b(ii:i-1))
     else if (summ /= 0.0) then
        ii=i
     end if
     b(i)=summ
  end do
  do i=n,1,-1
     b(i) = (b(i)-dot_product(a(i,i+1:n),b(i+1:n)))/a(i,i)
  end do
END SUBROUTINE lubksb_sp
SUBROUTINE lubksb_dp(a,indx,b)
  use mo_nrtype
  use mo_nrutil, ONLY : assert_eq
  IMPLICIT NONE
  REAL(DP), DIMENSION(:,:), INTENT(IN) :: a
  INTEGER(I4), DIMENSION(:), INTENT(IN) :: indx
  REAL(DP), DIMENSION(:), INTENT(INOUT) :: b
  INTEGER(I4) :: i,n,ii,ll
  REAL(DP) :: summ
  n=assert_eq(size(a,1),size(a,2),size(indx),'lubksb')
  ii=0
  do i=1,n
     ll=indx(i)
     summ=b(ll)
     b(ll)=b(i)
     if (ii /= 0) then
        summ=summ-dot_product(a(i,ii:i-1),b(ii:i-1))
     else if (summ /= 0.0) then
        ii=i
     end if
     b(i)=summ
  end do
  do i=n,1,-1
     b(i) = (b(i)-dot_product(a(i,i+1:n),b(i+1:n)))/a(i,i)
  end do
END SUBROUTINE lubksb_dp


text:
MODULE gram_schmidt_m_module

  use rgrid_module
  use wf_module
  use parallel_module

  implicit none

  PRIVATE
  PUBLIC :: gram_schmidt_m

#ifdef _DRSDFT_
  integer,parameter :: TYPE_MAIN=MPI_REAL8
  real(8) :: uu,vv
#else
  integer,parameter :: TYPE_MAIN=MPI_COMPLEX16
  complex(8) :: uu,vv
#endif

CONTAINS

  SUBROUTINE gram_schmidt_m(n0,n1,k,s)
    implicit none
    integer,intent(IN) :: n0,n1,k,s
    integer :: n,m,ierr
    real(8) :: c,d

    call gather_b_wf( k,s )

    do n=n0,n1
       do m=n0,n-1
#ifdef _DRSDFT_
          uu=sum( unk(:,m,k,s)*unk(:,n,k,s) )*dV
#else
          uu=sum( conjg(unk(:,m,k,s))*unk(:,n,k,s) )*dV
#endif
          call mpi_allreduce(uu,vv,1,TYPE_MAIN,MPI_SUM,comm_grid,ierr)
          unk(:,n,k,s)=unk(:,n,k,s)-unk(:,m,k,s)*vv
       end do
       c=sum(abs(unk(:,n,k,s))**2)*dV
       call mpi_allreduce(c,d,1,MPI_REAL8,MPI_SUM,comm_grid,ierr)
       c=1.d0/sqrt(d)
       unk(:,n,k,s)=c*unk(:,n,k,s)
    end do

  END SUBROUTINE gram_schmidt_m

END MODULE gram_schmidt_m_module

max_stars_repo_name: j-iwata/RSDFT

max_issues_repo_name: j-iwata/RSDFT

max_forks_repo_name: j-iwata/RSDFT


text:
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C   FFTPACK 5.0
C
C   Authors:  Paul N. Swarztrauber and Richard A. Valent
C
C   $Id$
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE MRFTF1 (M,IM,N,IN,C,CH,WA,FAC)
      REAL       CH(M,*) ,C(IN,*)  ,WA(N)   ,FAC(15)
C
      NF = FAC(2)
      NA = 1
      L2 = N
      IW = N
      DO 111 K1=1,NF
         KH = NF-K1
         IP = FAC(KH+3)
         L1 = L2/IP
         IDO = N/L2
         IDL1 = IDO*L1
         IW = IW-(IP-1)*IDO
         NA = 1-NA
         IF (IP .NE. 4) GO TO 102
         IX2 = IW+IDO
         IX3 = IX2+IDO
         IF (NA .NE. 0) GO TO 101
	 CALL MRADF4 (M,IDO,L1,C,IM,IN,CH,1,M,WA(IW),WA(IX2),WA(IX3))
         GO TO 110
  101    CALL MRADF4 (M,IDO,L1,CH,1,M,C,IM,IN,WA(IW),WA(IX2),WA(IX3))
         GO TO 110
  102    IF (IP .NE. 2) GO TO 104
         IF (NA .NE. 0) GO TO 103
	 CALL MRADF2 (M,IDO,L1,C,IM,IN,CH,1,M,WA(IW))
         GO TO 110
  103    CALL MRADF2 (M,IDO,L1,CH,1,M,C,IM,IN,WA(IW))
         GO TO 110
  104    IF (IP .NE. 3) GO TO 106
         IX2 = IW+IDO
         IF (NA .NE. 0) GO TO 105
	 CALL MRADF3 (M,IDO,L1,C,IM,IN,CH,1,M,WA(IW),WA(IX2))
         GO TO 110
  105    CALL MRADF3 (M,IDO,L1,CH,1,M,C,IM,IN,WA(IW),WA(IX2))
         GO TO 110
  106    IF (IP .NE. 5) GO TO 108
         IX2 = IW+IDO
         IX3 = IX2+IDO
         IX4 = IX3+IDO
         IF (NA .NE. 0) GO TO 107
         CALL MRADF5(M,IDO,L1,C,IM,IN,CH,1,M,WA(IW),WA(IX2),
     1                      WA(IX3),WA(IX4))
         GO TO 110
  107    CALL MRADF5(M,IDO,L1,CH,1,M,C,IM,IN,WA(IW),WA(IX2),
     1                      WA(IX3),WA(IX4))
         GO TO 110
  108    IF (IDO .EQ. 1) NA = 1-NA
         IF (NA .NE. 0) GO TO 109
	 CALL MRADFG (M,IDO,IP,L1,IDL1,C,C,C,IM,IN,CH,CH,1,M,WA(IW))
         NA = 1
         GO TO 110
  109    CALL MRADFG (M,IDO,IP,L1,IDL1,CH,CH,CH,1,M,C,C,IM,IN,WA(IW))
         NA = 0
  110    L2 = L1
  111 CONTINUE
      SN = 1./N
      TSN = 2./N
      TSNM = -TSN
      MODN = MOD(N,2)
      NL = N-2
      IF(MODN .NE. 0) NL = N-1
      IF (NA .NE. 0) GO TO 120
      M2 = 1-IM
      DO 117 I=1,M
         M2 = M2+IM
         C(M2,1) = SN*CH(I,1)
  117 CONTINUE
      DO 118 J=2,NL,2
      M2 = 1-IM
      DO 118 I=1,M
         M2 = M2+IM
	 C(M2,J) = TSN*CH(I,J)
	 C(M2,J+1) = TSNM*CH(I,J+1)
  118 CONTINUE
      IF(MODN .NE. 0) RETURN
      M2 = 1-IM
      DO 119 I=1,M
         M2 = M2+IM
         C(M2,N) = SN*CH(I,N)
  119 CONTINUE
      RETURN
  120 M2 = 1-IM
      DO 121 I=1,M
         M2 = M2+IM
         C(M2,1) = SN*C(M2,1)
  121 CONTINUE
      DO 122 J=2,NL,2
      M2 = 1-IM
      DO 122 I=1,M
         M2 = M2+IM
	 C(M2,J) = TSN*C(M2,J)
	 C(M2,J+1) = TSNM*C(M2,J+1)
  122 CONTINUE
      IF(MODN .NE. 0) RETURN
      M2 = 1-IM
      DO 123 I=1,M
         M2 = M2+IM
         C(M2,N) = SN*C(M2,N)
  123 CONTINUE
      RETURN
      END

max_stars_repo_name: sbwhitecap/clocc-hg

max_issues_repo_name: sbwhitecap/clocc-hg

max_forks_repo_name: sbwhitecap/clocc-hg


text:
      subroutine GSMCAMRPOP(
     & phi
     & ,iphilo0,iphilo1
     & ,iphihi0,iphihi1
     & ,rhs
     & ,irhslo0,irhslo1
     & ,irhshi0,irhshi1
     & ,icoloredboxlo0,icoloredboxlo1
     & ,icoloredboxhi0,icoloredboxhi1
     & ,dx
     & ,alpha
     & ,beta
     & )
      implicit none
      integer*8 chiterations
      integer*8 chflops,chloads,chstores
      common /chiterations/ chiterations
      common /chflops/ chflops,chloads,chstores
      EXTERNAL CHCOMMON
      integer iphilo0,iphilo1
      integer iphihi0,iphihi1
      REAL*8 phi(
     & iphilo0:iphihi0,
     & iphilo1:iphihi1)
      integer irhslo0,irhslo1
      integer irhshi0,irhshi1
      REAL*8 rhs(
     & irhslo0:irhshi0,
     & irhslo1:irhshi1)
      integer icoloredboxlo0,icoloredboxlo1
      integer icoloredboxhi0,icoloredboxhi1
      REAL*8 dx
      REAL*8 alpha
      REAL*8 beta
      REAL*8 lambda, dxinv, sum_b, lphi
      integer i,j
      integer idir
      dxinv = (1.0d0)/(dx*dx)
      sum_b = 0.0
      do idir = 0, 2 -1
         sum_b = sum_b + (2.0d0)*dxinv
      enddo
      lambda = (1.0d0)/(alpha - beta*sum_b)
      chiterations=(1+icoloredBoxhi1-icoloredBoxlo1)*(1+icoloredBoxhi0-i
     &coloredBoxlo0)*1
      do j = icoloredBoxlo1,icoloredBoxhi1,2
      do i = icoloredBoxlo0,icoloredBoxhi0,2
        lphi =
     & ( phi(i+1,j )
     & + phi(i-1,j )
     $ -(2.0d0)*phi(i ,j ))
     $ +( phi(i ,j+1)
     & + phi(i ,j-1)
     $ -(2.0d0)*phi(i ,j ))
        lphi = lphi*dxinv
        phi(i,j) =
     $ phi( i,j) +
     & lambda*( rhs( i,j) - lphi)
      enddo
      enddo
!      chloads=chloads+chiterations*2*8
!      chstores=chstores+chiterations*8
!      chflops=chflops+chiterations*(3*2 +4)
      return
      end

max_stars_repo_name: ouankou/rose


text:
! This file is part of mctc-lib.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.

module test_write_genformat
   use mctc_env_testing, only : new_unittest, unittest_type, error_type, check
   use testsuite_structure, only : get_structure
   use mctc_io_write_genformat
   use mctc_io_read_genformat
   use mctc_io_structure
   use mctc_io_structure_info
   implicit none
   private

   public :: collect_write_genformat

contains

!> Collect all exported unit tests
subroutine collect_write_genformat(testsuite)

   !> Collection of tests
   type(unittest_type), allocatable, intent(out) :: testsuite(:)

   testsuite = [ &
      & new_unittest("valid1-gen", test_valid1_gen), &
      & new_unittest("valid2-gen", test_valid2_gen), &
      & new_unittest("valid3-gen", test_valid3_gen) &
      & ]

end subroutine collect_write_genformat

subroutine test_valid1_gen(error)

   !> Error handling
   type(error_type), allocatable, intent(out) :: error

   type(structure_type) :: struc
   integer :: unit, nat, nid

   call get_structure(struc, "mindless01")
   nat = struc%nat
   nid = struc%nid

   open(status='scratch', newunit=unit)
   call write_genformat(struc, unit)
   rewind(unit)

   call read_genformat(struc, unit, error)
   close(unit)
   if (allocated(error)) return

   call check(error, struc%nat, nat, "Number of atoms does not match")
   if (allocated(error)) return
   call check(error, struc%nid, nid, "Number of species does not match")
   if (allocated(error)) return

end subroutine test_valid1_gen

subroutine test_valid2_gen(error)

   !> Error handling
   type(error_type), allocatable, intent(out) :: error

   type(structure_type) :: struc
   integer :: unit, nat, nid

   call get_structure(struc, "x01")
   nat = struc%nat
   nid = struc%nid

   open(status='scratch', newunit=unit)
   call write_genformat(struc, unit)
   rewind(unit)

   call read_genformat(struc, unit, error)
   close(unit)
   if (allocated(error)) return

   call check(error, struc%nat, nat, "Number of atoms does not match")
   if (allocated(error)) return
   call check(error, struc%nid, nid, "Number of species does not match")
   if (allocated(error)) return

end subroutine test_valid2_gen

subroutine test_valid3_gen(error)

   !> Error handling
   type(error_type), allocatable, intent(out) :: error

   type(structure_type) :: struc
   type(structure_info) :: info
   integer :: unit, nat, nid

   call get_structure(struc, "x02")
   nat = struc%nat
   nid = struc%nid
   info = structure_info(cartesian=.false.)
   struc%info = info

   open(status='scratch', newunit=unit)
   call write_genformat(struc, unit)
   rewind(unit)

   call read_genformat(struc, unit, error)
   close(unit)
   if (allocated(error)) return

   call check(error, struc%nat, nat, "Number of atoms does not match")
   if (allocated(error)) return
   call check(error, struc%nid, nid, "Number of species does not match")
   if (allocated(error)) return

end subroutine test_valid3_gen

end module test_write_genformat

max_stars_repo_name: loriab/mctc-lib

max_issues_repo_name: loriab/mctc-lib

max_forks_repo_name: loriab/mctc-lib


text:
C This file is part of PREPRO.
C
C    Author: Dermott (Red) Cullen
C Copyright: (C) International Atomic Energy Agency
C
C PREPRO is free software; you can redistribute it and/or modify it
C under the terms of the MIT License; see LICENSE file for more details.

C=======================================================================
C
C     PROGRAM ACTIVATE
C     ================
C     VERS. 2000-1 (APRIL 2000)   *INITIAL VERSION.
C     VERS. 2002-1 (MAY 2002)     *OPTIONAL INPUT PARAMETERS
C     VERS. 2004-1 (JAN. 2004)    *CORRECTED ERROR - FIRST RECORD AFTER
C                                  MF=10 WAS MISSING.
C                                 *ADDED INCLUDE TO DEFINE COMMON
C                                 *INCREASED MAX. POINTS FROM 100,000
C                                  TO 1,000,000.
C     VERS. 2007-1 (JAN. 2007)    *CHECKED AGAINST ALL ENDF/B-VII
C     VERS. 2007-2 (DEC. 2007)    *72 CHARACTER FILE NAMES.
C     VERS. 2010-1 (Apr. 2010)    *General update based on user feedback
C     VERS. 2012-1 (Aug. 2012)    *Added CODENAME
C                                 *Added ERROR stop
C                                 *32 and 64 bit Compatible
C     VERS. 2015-1 (Jan. 2015)    *Corrected ERROR for missing or extra
C                                  SEND and MEND lines.
C                                 *Changed MF=8 pointer from MF=9 to 10.
C                                 *INCREASED MAX. POINTS to 3,000,000.
C                                 *Added Consistency checks, e.g.,
C                                  Any MT in MF=9 requires data in MF=3.
C                                 *Extended OUT9 - OUT10 is not used.
C                                 *Only processes ONE ENDF Tape - this
C                                  restriction is necessary to insure
C                                  compatibility with ALL PREPRO codes.
C                                 *Changed to current ENDF sequence
C                                  number convention, e.g., reset number
C                                  for each section (MAT/MF/MT).
C                                 *Replaced ALL 3 way IF statements.
C     VERS. 2017-1 (May  2017)    *Increased MAX. POINTS to 6,000,000.
C                                 *Do not create MF=10 for any MT that
C                                  already has MF=10 data = copy MF=10
C                                  data in its original form.
C                                 *Message for every MF=7 output,
C                                  whether created or copied from input.
C     VERS. 2018-1 (Jan. 2018)    *Updated based on user feedback.
C                                 *Added on-line output for ALL ENDERROR
C     VERS. 2020-1 (Mar. 2020)    *Additional Interpolation Law Tesrs
C                                 *Checked consistency of Maximum
C                                  tabulated energy for MF=3 and 9 data
C                                  to be compbined - print WARNING if
C                                  inconsistent.
C                                 *Added Target Isomer State
C     VERS. 2021-1 (Jan. 2021)    *Updated for FORTRAN 2018
C
C     Acknowledgement 2015
C     --------------------
C     Currently almost all improvements to this code are based upon
C     feedback from code users who report problems. This feedback
C     benefits ALL users of this code, and ALL users are encouraged
C     to report problems.
C
C     Improvements on the 2015 version of this code based on user
C     feedback, including IMPORTANT feedback from Andrej Trkov, up
C     to and including Feb. 2015.
C
C     OWNED, MAINTAINED AND DISTRIBUTED BY
C     ------------------------------------
C     THE NUCLEAR DATA SECTION
C     INTERNATIONAL ATOMIC ENERGY AGENCY
C     P.O. BOX 100
C     A-1400, VIENNA, AUSTRIA
C     EUROPE
C
C     ORIGINALLY WRITTEN BY
C     ------------------------------------
C     Dermott E. Cullen
C
C     PRESENT CONTACT INFORMATION
C     ---------------------------
C     Dermott E. Cullen
C     1466 Hudson Way
C     Livermore, CA 94550
C     U.S.A.
C     Telephone  925-443-1911
C     E. Mail    RedCullen1@Comcast.net
C     Website    RedCullen1.net/HOMEPAGE.NEW
C
C
C     AUTHORS MESSAGE
C     ---------------
C     THE REPORT DESCRIBED ABOVE IS THE LATEST PUBLISHED DOCUMENTATION
C     FOR THIS PROGRAM. HOWEVER, THE COMMENTS BELOW SHOULD BE CONSIDERED
C     THE LATEST DOCUMENTATION INCLUDING ALL RECENT IMPROVEMENTS. PLEASE
C     READ ALL OF THESE COMMENTS BEFORE IMPLEMENTATION.
C
C     AT THE PRESENT TIME WE ARE ATTEMPTING TO DEVELOP A SET OF COMPUTER
C     INDEPENDENT PROGRAMS THAT CAN EASILY BE IMPLEMENTED ON ANY ONE
C     OF A WIDE VARIETY OF COMPUTERS. IN ORDER TO ASSIST IN THIS PROJECT
C     IT WOULD BE APPECIATED IF YOU WOULD NOTIFY THE AUTHOR OF ANY
C     COMPILER DIAGNOSTICS, OPERATING PROBLEMS OR SUGGESTIONS ON HOW TO
C     IMPROVE THIS PROGRAM. HOPEFULLY, IN THIS WAY FUTURE VERSIONS OF
C     THIS PROGRAM WILL BE COMPLETELY COMPATIBLE FOR USE ON YOUR
C     COMPUTER.
C
C     PURPOSE
C     -------
C     THIS PROGRAM IS DESIGNED TO CREATE FILE 10 ACTIVATION CROSS
C     SECTIONS BY COMBINING FILE 3 CROSS SECTIONS AND FILE 9 MULTIPLIERS
C
C     IN THE FOLLOWING DISCUSSION FOR SIMPLICITY THE ENDF TERMINOLOGY
C     ---ENDF TAPE---WILL BE USED. IN FACT THE ACTUAL MEDIUM MAY BE
C     TAPE, CARDS, DISK OR ANY OTHER MEDIUM.
C
C     ASSUMPTIONS
C     -----------
C     IT IS ASSUMED THAT THE FILE 3 AND 9 DATA HAVE BEEN LINEARIZED
C     BEFORE THIS CODE IS USED - FILE 3 AND 9 DATA CAN BE LINEARIZED
C     USING PROGRAM LINEAR.
C
C     IT IS ASSUMED THAT THE FILE 9 MULTIPLIERS ARE FAIRLY SMOOTH VERSUS
C     ENERGY, AND THAT THE ACTIVATION CROSS SECTIONS FOR FILE 10 CAN BE
C     DEFINED AT EXACTLY THE SAME ENERGIES AS THE FILE 3 CROSS SECTIONS,
C     AND THAT THESE NEED MERELY BE MULTIPLIED BY THE FILE 9 TO DEFINE
C     THE FILE 10 ACTIVATION CROSS SECTIONS.
C
C     ENDF FORMAT
C     -----------
C     THIS PROGRAM ONLY USES THE ENDF BCD OR CARD IMAGE FORMAT (AS
C     OPPOSED TO THE BINARY FORMAT) AND CAN HANDLE DATA IN ANY VERSION
C     OF THE ENDF FORMAT (I.E., ENDF-1, 2, 3, 4, 5 OR 6 FORMAT).
C
C     IT IS ASSUMED THAT THE DATA IS CORRECTLY CODED IN THE ENDF
C     FORMAT AND NO ERROR CHECKING IS PERFORMED. IN PARTICULAR IT IS
C     ASSUMED THAT THE MAT, MF AND MT ON EACH LINE IS CORRECT. SEQUENCE
C     NUMBERS (COLUMNS 76-80) ARE IGNORED ON INPUT, BUT WILL BE
C     CORRECTLY OUTPUT ON ALL LINES. THE FORMAT OF SECTION MF=1, MT=451
C     AND ALL SECTIONS OF MF=3 MUST BE CORRECT. THE PROGRAM COPIES ALL
C     OTHER SECTION OF DATA AS HOLLERITH AND AS SUCH IS INSENSITIVE TO
C     THE CORRECTNESS OR INCORRECTNESS OF ALL OTHER SECTIONS.
C
C     OUTPUT FORMAT
C     -------------
C     ALL ENERGIES WILL BE OUTPUT IN F (INSTEAD OF E) FORMAT IN ORDER
C     TO ALLOW ENERGIES TO BE WRITTEN WITH UP TO 9 DIGITS OF ACCURACY.
C     COMPARISON OF THE NORMAL ENDF CONVENTION OF 6 DIGITS TO THE 9
C     DIGIT OUTPUT FROM THIS PROGRAM DEMONSTRATED THAT FAILURE TO USE
C     THE 9 DIGIT OUTPUT CAN LEAD TO LARGE ERRORS IN THE DATA DUE TO
C     TRUNCATION OF ENERGIES TO 6 DIGITS DURING OUTPUT.
C
C     CONTENTS OF OUTPUT
C     ------------------
C     ENTIRE EVALUATIONS ARE OUTPUT, NOT JUST THE PROCESSED DATA, E.G.,
C     ANGULAR AND ENERGY DISTRIBUTIONS ARE ALSO INCLUDED.
C
C     DOCUMENTATION
C     -------------
C     THE FACT THAT THIS PROGRAM HAS OPERATED ON THE DATA IS DOCUMENTED
C     BY THE ADDITION OF 3 COMMENT LINES AT THE END OF EACH HOLLERITH
C     SECTION IN THE FORM
C
C     ***************** PROGRAM ACTIVATE (2021-1) ****************
C     FILE 10 ACTIVATION CROSS SECTIONS HAVE BEEN DEFINED BY COMBINING
C     FILE 3 CROSS SECTIONS AND FILE 9 MULTIPLIERS. FILE 9 DELETED.
C
C     THE ORDER OF SIMILAR COMMENTS (FROM RECENT, SIGMA1 AND GROUPIE)
C     REPRESENTS A COMPLETE HISTORY OF ALL OPERATIONS PERFORMED ON
C     THE DATA BY THESE PROGRAMS.
C
C     THESE COMMENT LINES ARE ONLY ADDED TO EXISTING HOLLERITH SECTIONS,
C     I.E., THIS PROGRAM WILL NOT CREATE A HOLLERITH SECTION. THE FORMAT
C     OF THE HOLLERITH SECTION IN ENDF-5 DIFFERS FROM THE THAT OF
C     EARLIER VERSIONS OF ENDF. BY READING AN EXISTING MF=1, MT=451
C     IT IS POSSIBLE FOR THIS PROGRAM TO DETERMINE WHICH VERSION OF
C     THE ENDF FORMAT THE DATA IS IN. WITHOUT HAVING A SECTION OF
C     MF=1, MT=451 PRESENT IT IS IMPOSSIBLE FOR THIS PROGRAM TO
C     DETERMINE WHICH VERSION OF THE ENDF FORMAT THE DATA IS IN, AND
C     AS SUCH IT IS IMPOSSIBLE FOR THE PROGRAM TO DETERMINE WHAT FORMAT
C     SHOULD BE USED TO CREATE A HOLLERITH SECTION.
C
C     REACTION INDEX
C     --------------
C     THIS PROGRAM DOES NOT USE THE REACTION INDEX WHICH IS GIVEN IN
C     SECTION MF=1, MT=451 OF EACH EVALUATION.
C
C     THIS PROGRAM DOES NOT UPDATE THE REACTION INDEX IN MF=1, MT=451.
C     THIS CONVENTION HAS BEEN ADOPTED BECAUSE MOST USERS DO NOT
C     REQUIRE A CORRECT REACTION INDEX FOR THEIR APPLICATIONS AND IT WAS
C     NOT CONSIDERED WORTHWHILE TO INCLUDE THE OVERHEAD OF CONSTRUCTING
C     A CORRECT REACTION INDEX IN THIS PROGRAM. HOWEVER, IF YOU REQUIRE
C     A REACTION INDEX FOR YOUR APPLICATIONS, AFTER RUNNING THIS PROGRAM
C     YOU MAY USE PROGRAM DICTIN TO CREATE A CORRECT REACTION INDEX.
C
C     SECTION SIZE
C     ------------
C     SECTIONS OF MF=9 MULTIPLIERS ARE LIMITED TO A MAXIMUM OF 3,000,000
C     ENERGY POINTS.
C
C     THERE IS NO LIMIT ON THE NUMBER OF ENERGY POINTS IN MF=3 AND 10
C     TABLES = THIS DATA IS READ AS CHARACTERS, ONE LINE AT A TIME.
C
C     SELECTION OF DATA
C     -----------------
C     THE PROGRAM PROCESSES ALL ENDF DATA ON ONE ENDF TAPE.
C
C     2015 - IT NOW ONLY DOES ONE ENDF TAPE.
C
C     PROGRAM OPERATION
C     -----------------
C     PASS #1
C     -------
C     THE ENTIRE MAT IS COPIED TO A SCRATCH FILE IN THE ENDF ASCII
C     FORMAT AND WHILE COPYING IT TO SCRATCH MF=3, 9, AND 10 ARE ALSO
C     COPIED TO SEPERATE SCRATCH FILES, I.E., THERE ARE A TOTAL OF 4
C     SCRATCH FILES - SEE THEIR DEFINITIONS BELOW.
C
C     PASS #2
C     -------
C     IF NO MF=9 MULTIPLIERS ARE FOUND DURING PASS #1, THE ENTIRE MAT
C     IS COPIED FROM SCRATCH TO THE OUTPUT FILE, WITHOUT ANY CHECKS.
C
C     IF MF=9 MULTIPLIERS ARE FOUND THEY ARE USED WITH MF=3 CROSS
C     SECTIONS TO CREATE MF=10 ACTIVATION CROSS SECTIONS.
C
C     FOR ANY SECTION OF MF=10 DATA FOR WHICH NO MF=9 MULTIPLIERS ARE
C     FOUND, THE ORIGINAL MF=10 IS OUTPUT.
C
C     FOR CONSISTENCY ALL MF=9 MULTIPLIERS ARE DELETED, I.E., THEY ARE
C     NOT INCLUDED IN THE OUTPUT.
C
C     KEEP EVALUATED DATA POINTS
C     --------------------------
C     THE FILE 10 OUTPUT WILL BE AT EXACTLY THE SAME ENERGY POINTS AS
C     THE FILE 3 CROSS SECTIONS USED TO DEFINE THE FILE 10 ACTIVATION
C     CROSS SECTIONS.
C
C     INPUT FILES
C     -----------
C     UNIT  DESCRIPTION
C     ----  -----------
C        2  INPUT LINES (BCD - 80 CHARACTERS/RECORD)
C       10  ORIGINAL ENDF DATA (BCD - 80 CHARACTERS/RECORD)
C
C     OUTPUT FILES
C     ------------
C     UNIT  DESCRIPTION
C     ----  -----------
C        3  OUTPUT REPORT (BCD - 120 CHARACTERS/RECORD)
C       11  FINAL ENDF DATA (BCD - 80 CHARACTERS/RECORD)
C
C     SCRATCH FILES
C     -------------
C     UNIT  DESCRIPTION
C     ----  -----------
C       12  SCRATCH FILE FOR ALL MAT (BCD - 80 CHARACTERS/RECORD)
C       14  SCRATCH FILE FOR MF=3 DATA (BCD - 80 CHARACTERS/RECORD)
C       15  SCRATCH FILE FOR MF=9 DATA (BCD - 80 CHARACTERS/RECORD)
C       16  SCRATCH FILE FOR MF=10 DATA (BCD - 80 CHARACTERS/RECORD)
C
C     OPTIONAL STANDARD FILE NAMES (SEE SUBROUTINE FILEIO)
C     ----------------------------------------------------
C     UNIT  FILE NAME
C     ----  ----------
C       2   ACTIVATE.INP
C       3   ACTIVATE.LST
C      10   ENDFB.IN
C      11   ENDFB.OUT
C      12   (SCRATCH)
C      14   (SCRATCH)
C      15   (SCRATCH)
C
C     INPUT PARAMETERS
C     ----------------
C
C     LINE  COLS.  DESCRIPTION
C     ----  -----  -----------
C        1   1-72  ENDF INPUT DATA FILENAME
C                  (STANDARD OPTION = ENDFB.IN)
C        2   1-72  ENDF OUTPUT DATA FILENAME
C                  (STANDARD OPTION = ENDFB.OUT)
C
C     ONE PAIR OF INPUT LINES MAY BE USED, TO PROCESS ANY ENDF TAPE.
C
C     2015 - NOW ONLY DOES ONE ENDF TAPE.
C
C     EXAMPLE INPUT NO. 1
C     -------------------
C     PROCESS ENDF TAPE NAMED ACTIVATE.IN AND NAME THE OUTPUT FILE
C     ACTIVATE.OUT.
C
C     IN THIS CASE THE FOLLOWING 2 INPUT LINES ARE REQUIRED
C
C ACTIVATE.IN
C ACTIVATE.OUT
C
C     EXAMPLE INPUT NO. 2
C     -------------------
C     SAME AS THE ABOVE CASE, EXCEPT THAT IN THIS CASE THE ORIGINAL
C     TAPE IS IN A DIRECTORY NAMED \ENDFB6\ORIGINAL, AND THE
C     RESULTS WILL BE WRITTEN INTO A DIRECTORY NAMED \ENDFB6\ACTIVATE.
C
C     IN THIS CASE THE FOLLOWING 6 INPUT LINES ARE REQUIRED
C
C \ENDFB6\ORIGINAL\ACTIVATE.IN
C \ENDFB6\ACTIVATE\ACTIVATE.OUT
C
C     EXAMPLE INPUT NO. 3
C     -------------------
C     IF THERE IS NO ACTIVATE.INP FILE, OR THE FILENAMES ARE BLANK
C     THIS CODE WILL USE THE DEFAULT NAMES,
C
C ENDFB.IN
C ENDFB.OUT
C
C=======================================================================
      INCLUDE 'implicit.h'
      INCLUDE 'activate.h'
      INTEGER OUTP,OTAPE
      CHARACTER*1 ZABCD
      CHARACTER*1 LINE66
      CHARACTER*4 CARD
C-----08/08/2012 DEFINE CODE NAME
      CHARACTER*8 CODENAME
      COMMON/NAMECODE/CODENAME
      COMMON/BCDZA/ZABCD(12)
      COMMON/ENDFIO/INP,OUTP,ITAPE,OTAPE
      COMMON/IOSTATUS/ISTAT1,ISTAT2
      COMMON/UNITS/ISCR1,ISCR2,ISCR3,ISCR4
      COMMON/HEADER/C1H,C2H,L1H,L2H,N1H,N2H,MATH,MFH,MTH,NOSEQ
      COMMON/COPC/CARD(17)
      COMMON/COPI/MFIELD(3)
      COMMON/COUNTS/IZANOW,MATNOW,N2MATI,N2MATO,N2TOTI,N2TOTO
      COMMON/LISOCOM/LISO
      COMMON/LSTCOM/LSTIZA,LSTMAT,LSTMF
      COMMON/CLINE66/LINE66(66)
c-----2014/2/20 - if MF=8, change flag MF=9 to MF=10
      character*1 mt9(11),mt10(11)
      data mt9 /' ',' ',' ',' ',' ',' ',' ',' ',' ',' ','9'/
      data mt10/' ',' ',' ',' ',' ',' ',' ',' ',' ','1','0'/
C-----08/08/2012 DEFINE CODE NAME
      CODENAME = 'ACTIVATE'
C-----INITIALIZE TIMER
      CALL TIMER
C-----------------------------------------------------------------------
C
C     DEFINE ALL I/O UNITS AND OPTIONALLY DEFINE FILE NAMES.
C
C-----------------------------------------------------------------------
      CALL FILEIO
C-----SAVE ENDF INPUT FILE NUMBER
      ISAVE = ITAPE
C-----WRITE OUTPUT TITLE.
      WRITE(OUTP,250)
      WRITE(*   ,250)
C-----------------------------------------------------------------------
C
C     READ INPUT PARAMETERS = filenames of ENDF input and output data.
C
C-----------------------------------------------------------------------
      CALL READIN
C-----------------------------------------------------------------------
C
C     COPY TAPE LABEL AND INITIALIZE CUMULATIVE COUNTS.
C
C-----------------------------------------------------------------------
C-----COPY TAPE LABEL RECORD TO LINEARIZED FILE.
      CALL COPYL
C-----LIST TAPE LABEL.
      WRITE(OUTP,230) CARD,MFIELD(1)
      WRITE(*   ,230) CARD,MFIELD(1)
C-----INITIALIZE TOTAL POINTS READ AND WRITTEN.
      N2TOTI=0
      N2TOTO=0
C-----INITIALIZE LAST MAT READ.
      MATNOW = 0
      LSTMAT = -9999
      LSTMF  = -99
      IMALL10= 0     ! Flag to indicate MF=10 data already exists
      LISO    = 0
C-----------------------------------------------------------------------
C
C     LOOP OVER MATS
C     ==============
C     PASS #1: COPY NEXT MAT TO SCRATCH, AND DETERMINE IF THERE ARE ANY
C     MF = 9 MULTIPLIERS.
C
C-----------------------------------------------------------------------
C-----INITIALIZE MT TABLE AND MF=9 SECTION AND POINT COUNTS.
   10 IMFILE9  = 0
      N2MATI   = 0
      N2MATO   = 0
      LISO     = 0
      DO K=1,MAXMT
      MTTAB3(K)  = 0
      MTTAB9(K)  = 0
      MTTAB10(K) = 0
      ENDDO
C-----COPY ENTIRE MAT.
      REWIND ISCR1
      ITAPE = ISAVE
      LISIN = 0   ! MF/MT line counter
      LISO  = 0   ! Target isomer flag
C-----------------------------------------------------------------------
c
c     Next line is start of next MAT or TEND.
c
C-----------------------------------------------------------------------
      READ(ITAPE,210) LINE66,MATH,MFH,MTH
      IF(MATH.LT.0) GO TO 190                   ! TEND if MATH < 0
c-----translate ZA and save MAT
      MATNOW = MATH
      LISO   = 0
      LISIN  = 0
      call IN9(ZAX,LINE66(1))
      IZANOW = ZAX
      MATNOW = MATH
c-----2020/3/21 - Added LISO = Target State  Number
      CALL ZAHOLM(IZANOW,LISO,ZABCD)
c-----2019/3/9 - Initialize MT table for next MAT
      CALL MAXIE0
C-----------------------------------------------------------------------
C
C     Not TEND - assume next MAT - COPY TO SCRATCH.
C
C-----------------------------------------------------------------------
C
C     KEEP TRACK OF MT # FROM MF=3, 9, AND 10.
C     Switch MF=8 pointers from MF=9 to MF=10.
C
C-----------------------------------------------------------------------
   20 IF(MTH.LE.0) GO TO 30
C-----MF=3?
      IF(MFH.EQ.3) THEN
      MTTAB3(MTH) = 1
      ENDIF
C-----MF=9?
      IF(MFH.EQ.9) THEN
      IMFILE9 = IMFILE9 + 1
      MTTAB9(MTH) = 1
      ENDIF
C-----MF=10?
      IF(MFH.EQ.10) THEN
      MTTAB10(MTH) = 1
      ENDIF
C-----MF=8? Change flag from MF=9 to MF=10.
      IF(MFH.EQ.8) THEN
c-----If L1H = 9, Replace by L1H = 10
      do i=1,11
      if(LINE66(i+22).ne.mt9(i)) go to 30
      enddo
      do i=1,11
      LINE66(i+22) = mt10(i)
      enddo
      ENDIF
   30 WRITE(ISCR1,210) LINE66,MATH,MFH,MTH
c-----------------------------------------------------------------------
c
c     Define LISO target isomer flag
c
c     WARNING - This only works for ENDFB-6 format - where
C               LISO, target isomer flag is L2 on second line
C               of MF/MT=1/451.
C
c-----------------------------------------------------------------------
      IF(MTH.eq.451) LISIN = LISIN + 1
      IF(LISIN.eq.2) then
      CALL IN9(XLISO,LINE66(34))
      LISO = XLISO
c-----2020/3/21 - Added LISO = Target State
      CALL ZAHOLM(IZANOW,LISO,ZABCD)
      ENDIF
c
c     Read next line
c
      READ(ITAPE,210) LINE66,MATH,MFH,MTH
      IF(MATH.GT.0) GO TO 20
c-----MEND = Entire MAT has been copied to scratch.
      WRITE(ISCR1,210) LINE66,MATH,MFH,MTH      ! Write MEND
      WRITE(ISCR1,220)                          ! Add TEND
      ENDFILE ISCR1
      REWIND ISCR1
C-----------------------------------------------------------------------
C
C     PASS #2: THE ENTIRE MAT IS NOW ON SCRATCH
C
C-----------------------------------------------------------------------
C
C     IGNORE (COPY) ANY MT THAT ALREADY HAS MF=10 DATA
C
C-----------------------------------------------------------------------
      IMFILE9 = 0
      MFPRINT = 10
      IMHERE  = 0
      do k=1,MAXMT
      if(MTTAB10(K).ne.0) then
      write(OUTP,40) ZABCD,MATNOW,MFPRINT,K
      write(*   ,40) ZABCD,MATNOW,MFPRINT,K
   40 format(1x,12A1,I5,I4,I4,
     1 ' WARNING - MF=10 data already exists - will copy MT.')
      MTTAB9(k) = 0
      MTTAB3(k) = 0
      IMHERE    = 1
      IMALL10   = 1
      else
      if(MTTAB9(k).gt.0) IMFILE9 = IMFILE9 + 1
      endif
      enddo
      if(IMHERE .gt.0) then
      if(IMFILE9.gt.0) then
      write(outp,50)
      write(*   ,50)
   50 format(1x,78('-'))
      endif
      endif
C-----------------------------------------------------------------------
C
C     IF NO MF=9 DATA - NOTHING TO DO - COPY ENTIRE MAT TO OUTPUT.
C
C-----------------------------------------------------------------------
      IF(IMFILE9.GT.0) GO TO 70
C-----READ/WRITE FIRST LINE TO FORCE OUTPUT REPORT FOR PRECEDING
C-----MAT, IF ANY.
      ITAPE = ISCR1
      CALL CONTI
      NOSEQ = 1
      CALL CONTOG
      ITAPE = ISAVE
   60 READ(ISCR1,210,END=180) LINE66,MATH,MFH,MTH
      IF(MATH.LE.0) go to 170      ! MEND = Finish Preceeding MAT
      IF(MTH.LE.0) THEN
      CALL OUTS(MATH,MFH)
      ELSE
      WRITE(OTAPE,210) LINE66,MATH,MFH,MTH,NOSEQ
      NOSEQ = NXTSEQ(NOSEQ)
      LSTMAT = MATH
      LSTMF  = MFH
      ENDIF
      GO TO 60
C-----------------------------------------------------------------------
C
C     PROCESS ALL MF=9 DATA, AND MERGE WITH REMAINING MF=10 DATA, IF ANY
C
C-----------------------------------------------------------------------
   70 ITAPE = ISCR1
C
C     LOOP OVER SECTIONS READ FROM SCRATCH
C
C-----FIND NEXT REQUESTED SECTION.
   80 CALL NEXTMT
C-----CHECK FOR END OF MATERIAL
      IF(MATH.LE.0) GO TO 160
C-----FIND FILE 1, SECTION 451 AND ADD COMMENTS TO INDICATE THAT
C-----THIS MATERIAL HAS BEEN PROCESSED.
      IF(MFH.NE.1.OR.MTH.NE.451) GO TO 90
C-----ADD COMMENTS.
      CALL CONTOG
      CALL FILE1
      GO TO 80
C-----COPY ALL OF MF=3, 9, AND 10 TO SCRATCH.
   90 IF(MFH.eq.3 ) go to 100    ! MF=3
      IF(MFH.eq.9 ) go to 110    ! MF=9
      IF(MFH.eq.10) go to 120   ! MF=10
      IF(MFH.lt.10) go to 130   ! Before MF=10 copy section.
      go to 140                 ! After MF=10 processing finished.
C-----COPY ALL OF MF=3 TO OUTPUT AND SCRATCH.
  100 CALL FILE3
      GO TO 80
C-----COPY ALL OF MF=9 TO SCRATCH.
  110 CALL FILE9
      GO TO 80
C-----IF ANY MF=9 DATA, COPY ALL OF MF=10 TO SCRATCH.
  120 IF(IMFILE9.EQ.0) GO TO 130
      CALL FILE10
      GO TO 80
C-----COPY SECTION.
  130 CALL CONTOG
      CALL COPYS
      GO TO 80
C-----------------------------------------------------------------------
C
C     PAST MF=10 - CREATE MF=10 DATA AND THEN COPY TO END OF MAT.
C
C-----------------------------------------------------------------------
C-----SAVE HEADER PARAMETERS
  140 C1HSAVE = C1H
      C2HSAVE = C2H
      L1HSAVE = L1H
      L2HSAVE = L2H
      N1HSAVE = N1H
      N2HSAVE = N2H
      MATHSAV = MATH
      MFHSAVE = MFH
      MTHSAVE = MTH
C-----CREATE FILE 10
      CALL CREATE10
C-----OUTPUT HEAD RECORD FOR NEXT FILE (ALREADR READ)
      C1H = C1HSAVE
      C2H = C2HSAVE
      L1H = L1HSAVE
      L2H = L2HSAVE
      N1H = N1HSAVE
      N2H = N2HSAVE
      MATH= MATHSAV
      MFH = MFHSAVE
      MTH = MTHSAVE
      CALL CONTOG
C-----------------------------------------------------------------------
C
C     MF=10 Finished - COPY TO END OF MAT
C
C-----------------------------------------------------------------------
  150 CALL NEXTMT
      IF(MATH.LE.0) then
      CALL OUTF(LSTMAT) ! Add FEND
      go to 170
      endif
      CALL CONTOG
      CALL COPYS
      GO TO 150
C-----------------------------------------------------------------------
C
C     AT THE END OF THE MATERIAL - CREATE MF=10 DATA.
C
C-----------------------------------------------------------------------
  160 CALL CREATE10
C-----------------------------------------------------------------------
C
C     Finish Preceding MAT - and Try for another MAT.
C
C-----------------------------------------------------------------------
  170 CALL REPORT
      CALL OUTM
      LSTMAT = 0
      LSTMF  = 0
      GO TO 10               ! Try for next MAT
C-----------------------------------------------------------------------
C
C     Finish Preceding MAT - end of ENDF TAPE.
C
C-----------------------------------------------------------------------
  180 CALL REPORT
      CALL OUTM
      LSTMAT = 0
      LSTMF  = 0
C-----------------------------------------------------------------------
C
C     THE END OF ENDF TAPE - PRINT SUMMARY - ONLY DO ONE ENDF TAPE.
C
C-----------------------------------------------------------------------
C-----END FILE ENDF FORMAT OUTPUT FILE
  190 MATH = -1
      MFH  = 0
      MTH  = 0
      CALL CONTOG
C-----WRITE POINT TOTALS FOR TAPE.
      WRITE(OUTP,240) N2TOTI,N2TOTO
      WRITE(*   ,240) N2TOTI,N2TOTO
      CLOSE(ITAPE)
      CLOSE(OTAPE)
C-----------------------------------------------------------------------
C
C     Print WARNING is MF=10 data already exists
c
C-----------------------------------------------------------------------
      if(IMALL10.gt.0) then
      write(OUTP,200)
      write(*   ,200)
  200 format(
     1 ' WARNING - The purpose of this code is to create MF=10 data'/
     2 '           if it does not already exist - if it does exist'/
     3 '           it is copied without checking whether or not it is'/
     4 '           consistent with MF=9 data. Be WARNED that for the'/
     1 '           MF=10 created here MF=9 and MF=10 are consistent.'/
     2 '           But for MF=10 that already existed there is no'/
     3 '           check that MF=9 and MF=10 are consistent.'/
     4 1X,78('-'))
      endif
c-----2019/3/7 - Final WARNING if Maximum Tabulated Energy Inconsistent.
      CALL MAXIE4(1)
C-----08/08/2012 - ONLY DO ONE ENDF FILE
      CALL ENDIT ! This ends execution, but some compilers do not like
      STOP       ! mains that end in a call - so this dummy STOP is
C                ! included here only avoid compiler ERROR Messages.
  210 FORMAT(66A1,I4,I2,I3,I5)
  220 FORMAT(66X,'  -1 0  0    0')
  230 FORMAT(1X,78('-')/
     1 ' ENDF Tape Label'/1X,78('-')/1X,16A4,A2,I4/1X,78('-')/
     2 '   Material    MAT  MF  MT  ENDF    ZAP Final',6X,'Q-Value',
     3 ' Points Points'/
     4 '                            Format      State',6X,'     eV',
     5 '     In    Out'/
     4 1X,78('-'))
  240 FORMAT(1X,78('-')/45X,'Tape Totals',2I7/1X,78('-'))
  250 FORMAT(' ENDF Activation Cross Sections',
     1 ' (ACTIVATE 2021-1)'/1X,78('-'))
      END
      SUBROUTINE CREATE10
C=======================================================================
C
C     CREATE MF=10 ACTIVATION CROSS SECTIONS.
C
C=======================================================================
      INCLUDE 'implicit.h'
      INCLUDE 'activate.h'
      INTEGER OUTP,OTAPE
      CHARACTER*1 LINE66
      COMMON/ENDFIO/INP,OUTP,ITAPE,OTAPE
      COMMON/UNITS/ISCR1,ISCR2,ISCR3,ISCR4
      COMMON/HEADER/C1H,C2H,L1H,L2H,N1H,N2H,MATH,MFH,MTH,NOSEQ
      COMMON/LEADER/C1,C2,L1,L2,N1,N2,MAT,MF,MT
c-----2019/1/5 - Increased to 100 from 50 = PREPRO Standard
      COMMON/NBTINT/NBT(100),INT(100)
      COMMON/LASTE/ELAST
      COMMON/CLINE66/LINE66(66)
C-----POSITION ALL SCRATCH FILES.
      REWIND ISCR2
      REWIND ISCR3
      REWIND ISCR4
C-----------------------------------------------------------------------
C
C     LOOP OVER SECTIONS (MT) TO OUTPUT
C
C-----------------------------------------------------------------------
C-----DEFINE I/O UNITS TO READ MF=9 DATA AS INPUT.
      ISAVE = ITAPE
      ITAPE = ISCR3
      DO 90 IMT=1,MAXMT
C-----------------------------------------------------------------------
C
C     MF=9 DATA?
C
C-----------------------------------------------------------------------
      IF(MTTAB9(IMT).LE.0) GO TO 60
C-----------------------------------------------------------------------
C
C     MF=9 data requires MF=3.
C
C-----------------------------------------------------------------------
      if(MTTAB3(IMT).le.0) then
      write(OUTP,140) IMT
      write(*   ,140) IMT
      CALL ENDERROR
      endif
C-----------------------------------------------------------------------
C
C     COMBINE MF=3 AND 9 DATA - OUTPUT MF=10
C
C-----------------------------------------------------------------------
C-----LOCATE MF=9 DATA.
      ITAPE = ISCR3
   10 CALL CONTI
      IF(MTH.LE.0) GO TO 10
      IF(MTH.eq.IMT) go to 20
      IF(MTH.gt.IMT) go to 110
      CALL SKIPS
      GO TO 10
   20 MFH = 10
      CALL CONTOG
C-----------------------------------------------------------------------
C
C     LOOP OVER MF=9 SECTIONS - MF=9 HAS MULTIPLE SECTIONS.
C
C-----------------------------------------------------------------------
      NS = N1H
      DO 50 IS=1,NS
C-----FIRST, LOAD MF=9 MULTIPLIERS
      ITAPE = ISCR3
      CALL INTLAW
C-----INSURE MULTIPLIERS WILL FIT IN MEMORY.
      N9 = N2
      IF(N9.LT.2.OR.N9.GT.MAXPOINT) THEN
      WRITE(OUTP,180) N9,MAXPOINT
      WRITE(*   ,180) N9,MAXPOINT
      CALL ENDERROR
      ENDIF
C-----READ AND CHECK MULTIPLIERS
      ELAST = 0.0d0
      CALL POINTI(X9(1),Y9(1),N9)
c-----2019/3/9 - Save mat/mf/mt for multiplicity (MF = 9)
      CALL MAXIE1(MATH,  9,MTH)                ! Note: MF9, not MFH
c-----2010/3/9 - Save Maximum Energy and Value
      CALL MAXIE2(X9(N9),Y9(N9))
C-----SAVE FOR OUTPUT IN MF=10
      C19 = C1
      C29 = C2
      L19 = L1
      L29 = L2
C-----------------------------------------------------------------------
C
C     NEXT, LOCATE MF=3 DATA
C
C-----------------------------------------------------------------------
      ITAPE = ISCR2
      REWIND ISCR2
   30 CALL CONTI
      IF(MTH.LE.0) GO TO 30
      IF(MTH.eq.IMT) go to 40
      IF(MTH.gt.IMT) go to 100
      CALL SKIPS
      GO TO 30
C-----READ AND CHECK INTERPOLATION LAW
   40 CALL INTLAW
C-----OUTPUT MF=10 LEADER AND INTERPLATION LAW
      C1 = C19
      C2 = C29
      L1 = L19
      L2 = L29
      MFH = 10
      CALL CARDO(C1,C2,L1,L2,N1,N2)
      CALL TERPO(NBT,INT,N1)
C-----COMBINE MF=3 AND 9 DATA
      CALL FILEX
   50 CONTINUE
C-----ADD SEND LINE.
      CALL OUTS(MATH,MFH)
      GO TO 90
C-----------------------------------------------------------------------
C
C     MF=10 DATA?
C
C-----------------------------------------------------------------------
   60 IF(MTTAB10(IMT).LE.0) GO TO 90
c-----Add FEND and ENDF if needed.
      MFH = 10
      CALL SYNCEND
C-----------------------------------------------------------------------
C
C     OUTPUT ORIGINAL MF=10 DATA
C
C-----------------------------------------------------------------------
c-----Find same MT
   70 READ(ISCR4,130,END=120) LINE66,MATH,MFH,MTH
      IF(MTH.eq.IMT) go to 80
      IF(MTH.gt.IMT) go to 120
      CALL SKIPS
      GO TO 70
c-----Copy section to Output.
   80 IF(MTH.LE.0) THEN
      CALL OUTS(MATH,MFH)
      ELSE
      WRITE(OTAPE,130) LINE66,MATH,MFH,MTH,NOSEQ
      NOSEQ = NXTSEQ(NOSEQ)
      ENDIF
c-----Continue to MT=0 (SEND)
      IF(MTH.LE.0) GO TO 90
      READ(ISCR4,130,END=120) LINE66,MATH,MFH,MTH
      GO TO 80
c-----END OF MT loop.
   90 CONTINUE
C-----------------------------------------------------------------------
C
C     MF=10 COMPLETED - ADD FEND AND RESTORE ENDF INPUT NUMBER
C
C-----------------------------------------------------------------------
      ITAPE = ISAVE
      RETURN
C-----------------------------------------------------------------------
C
C     ERROR READING MF=3 DATA.
C
C-----------------------------------------------------------------------
  100 WRITE(OUTP,170) IMT
      WRITE(*   ,170) IMT
      CALL ENDERROR
C-----------------------------------------------------------------------
C
C     ERROR READING MF=9 DATA.
C
C-----------------------------------------------------------------------
  110 WRITE(OUTP,150) IMT
      WRITE(*   ,150) IMT
      CALL ENDERROR
C-----------------------------------------------------------------------
C
C     ERROR READING MF=10 DATA.
C
C-----------------------------------------------------------------------
  120 WRITE(OUTP,160) IMT
      WRITE(*   ,160) IMT
      CALL ENDERROR
  130 FORMAT(66A1,I4,I2,I3,I5)
  140 FORMAT(' ERROR - MT=',I5,' MF=9 Data Required MF=3 Data')
  150 FORMAT(' ERROR - Cannot Locate MF=  9, MT=',I5,' Data')
  160 FORMAT(' ERROR - Cannot Locate MF= 10, MT=',I5,' Data')
  170 FORMAT(' ERROR - Cannot Locate MF=  3, MT=',I5,' Data')
  180 FORMAT(' ERROR - N2=',I8,' (MUST be 2 to ',I8,')'/
     1       ' Execution Terminated')
      END
      SUBROUTINE INTLAW
C=======================================================================
C
C     CHECK INTERPOLATION LAW
C
C=======================================================================
      INCLUDE 'implicit.h'
      CHARACTER*1 ZABCD
      INTEGER OUTP,OTAPE
      COMMON/ENDFIO/INP,OUTP,ITAPE,OTAPE
      COMMON/HEADER/C1H,C2H,L1H,L2H,N1H,N2H,MATH,MFH,MTH,NOSEQ
      COMMON/LEADER/C1,C2,L1,L2,N1,N2,MAT,MF,MT
c-----2019/1/5 - Increased to 100 from 50 = PREPRO Standard
      COMMON/NBTINT/NBT(100),INT(100)
      COMMON/BCDZA/ZABCD(12)
C-----------------------------------------------------------------------
C
C     READ AND CHECK SECTION LEADER LINE AND INTERPOLATION LAW. IF
C     INTERPOLATION LAW IS ILLEGAL (BAD INTERPOLATION TYPE OR IMPROPER
C     INTERPOLATION BOUNDARY) TERMINATE EXECUTION.
C
C-----------------------------------------------------------------------
      CALL CARDI(C1,C2,L1,L2,N1,N2)
      CALL TERPI(NBT,INT,N1)
c-----2019/1/3 - Additional Interpolation Law Tests
      CALL TERPTEST(NBT,INT,N1,N2,3)
      RETURN
      END
      SUBROUTINE FILEX
C=======================================================================
C
C     OUTPUT ALL SECTIONS OF MF=10 DATA USING,
C     1) A COMBINATION OF MF=3 AND 9, OR
C     2) ORIGINAL MF=10 DATA
C
C=======================================================================
      INCLUDE 'implicit.h'
      INCLUDE 'activate.h'
      INTEGER OUTP,OTAPE
      CHARACTER*1 ZABCD,FIELD
      CHARACTER*4 FMTHOL
      CHARACTER*1 LINE66
      COMMON/ENDFIO/INP,OUTP,ITAPE,OTAPE
      COMMON/UNITS/ISCR1,ISCR2,ISCR3,ISCR4
      COMMON/HEADER/C1H,C2H,L1H,L2H,N1H,N2H,MATH,MFH,MTH,NOSEQ
      COMMON/LEADER/C1,C2,L1,L2,N1,N2,MAT,MF,MT
      COMMON/HOLFMT/FMTHOL
      COMMON/FIELDC/FIELD(11,6)
      COMMON/COUNTS/IZANOW,MATNOW,N2MATI,N2MATO,N2TOTI,N2TOTO
      COMMON/LISOCOM/LISO
      COMMON/BCDZA/ZABCD(12)
      COMMON/CLINE66/LINE66(66)
C-----INITIALIZE TO AVOID COMPILER WARNING.
      DATA MF3/0/
      IF(MF3.eq.0) MF3 = 3    ! Avoid Freud WARNING
C-----DEFINE MATERIAL
      KZA = C1H
c-----2020/3/21 - Added LISO = Target State
      CALL ZAHOLM(KZA,LISO,ZABCD)
C-----SET OUTPUT FOR MF=10
      MFH = 10
      MTIN = MTH
C-----ORIGINAL AND FINAL POINT COUNTS ARE THE SAME = MF=3 POINTS.
      N2IN = N2
      N2OUT = N2
c-----2019/3/9 - save mat/mf/mt for cross section (MF = 3)
      CALL MAXIE1(MATH,  3,MTH)    ! Note: MF3, not MTH
C-----------------------------------------------------------------------
C
C     COPY MF=3 DATA, RE-NORMALIZING CROSS SECTIONS BY MF=9 MULTIPLIERS
C
C-----------------------------------------------------------------------
      I9=1
C-----LOOP OVER MF=3 LINES, 3 POINTS PER LINE.
      DO 60 I1=1,N2IN,3
      I2 = I1+2
      IF(I2.GT.N2IN) I2=N2IN
      K2 = (I2-I1)+1
      READ(ISCR2,90,END=80) LINE66,MATH,MF3,MTH
      KK=1
C-----DEFINE MF=3 ENERGY AND CROSS SECTIONS FOR EACH ENERGY POINT
C-----AND RE-NORMALIZE CROSS SECTION.
      DO 50 K1=1,K2
      CALL IN9( ENOW,LINE66(KK))
      CALL IN9(XCNOW,LINE66(KK+11))
C-----FIND MF=9 MULTIPLIER AT SAME ENERGY AS MF=3 CROSS SECTION
      DO K9=I9,N9
      IF(ENOW.lt.X9(K9)) go to 20
      IF(ENOW.eq.X9(K9)) go to 30
      ENDDO
   10 WRITE(OUTP,110) ENOW,X9(1),X9(N9),ENOW
      WRITE(*   ,110) ENOW,X9(1),X9(N9),ENOW
      XMULT = 0.0d0
      K9 = 1
      GO TO 40
C-----INTERPOLATE MULTIPLIER.
   20 IF(K9.LE.1) GO TO 10
      XMULT = TERPIT(ENOW,X9(K9-1),X9(K9),Y9(K9-1),Y9(K9),2)
      GO TO 40
C-----USE TABULATED MULTIPLER.
   30 XMULT = Y9(K9)
C-----RE-NORMALIZE MF=3 CROSS SECTION AND PUT BACK ON OUTPUT LINE
   40 I9 = K9
      XCNOW = XCNOW*XMULT
      CALL OUT9(XCNOW,LINE66(KK+11))
      KK=KK+22
   50 CONTINUE
C-----OUTPUT LINE OF UP TO 3 ENERGY POINTS
      WRITE(OTAPE,90) LINE66,MATH,MFH,MTH,NOSEQ
      NOSEQ = NXTSEQ(NOSEQ)
   60 CONTINUE
c-----2019/3/9 - Maximum tabulated MF=3 energy and value
      CALL MAXIE2(ENOW,XCNOW)
C-----------------------------------------------------------------------
C
C     PRINT SUMMARY OF SECTION
C
C-----------------------------------------------------------------------
      CALL OUT9(C2,FIELD(1,1))
      WRITE(OUTP,70) ZABCD,MATH,MFH,MTIN,FMTHOL,L1,L2,
     1 (FIELD(K,1),K=1,11),N2IN,N2OUT
      WRITE(*   ,70) ZABCD,MATH,MFH,MTIN,FMTHOL,L1,L2,
     1 (FIELD(K,1),K=1,11),N2IN,N2OUT
   70 FORMAT(1X,12A1,I5,I4,I4,3X,A2,I8,I6,2X,11A1,2I7)
c-----------------------------------------------------------------------
c
c     NOTE: ZAP=0 is o.k. = photon production.
C           It follows all others = not in incresasing ZAP order.
c
c-----------------------------------------------------------------------
C-----INCREMENT CUMULATIVE COUNTS
      N2MATI = N2MATI + N2IN
      N2MATO = N2MATO + N2OUT
      N2TOTI = N2TOTI + N2IN
      N2TOTO = N2TOTO + N2OUT
      RETURN
C-----------------------------------------------------------------------
C
C     ERROR READING MF=3 DATA
C
C-----------------------------------------------------------------------
   80 WRITE(OUTP,100)
      WRITE(*   ,100)
      CALL ENDERROR
   90 FORMAT(66A1,I4,I2,I3,I5)
  100 FORMAT(' ERROR - END of ENDF Data while Reading MF=3 Data')
  110 FORMAT(' WARNING - MF3 E=',1PD12.5,' Not in Energy Range of'/
     1       '           MF9 E=',1p2d12.5,' eV Data.'/
     2       '           Will Assume MF9 Data = 0 at E=',1PD12.5)
      END
      SUBROUTINE FILE1
C=======================================================================
C
C     ADD COMMENTS AT THE END OF FILE 1, SECTION 451 TO INDICATE
C     THAT THIS MATERIAL HAS BEEN PROCESSED BY PROGRAM LINEAR AND
C     TO SPECIFY THE ALLOWABLE ERROR.
C
C     DEFINE FORMAT TO BE ENDF-4, 5 OR 6.
C
C     THE ENDF FORMAT CAN BE DETERMINED FROM THE SECOND LINE.
C     ENDF-4  = N1 > 0, N2 = 0,LINE COUNT (POSITIVE)
C     ENDF-5  = N1 = N2 = 0
C     ENDF-6  =      N2 = VERSION NUMBER (6 OR MORE)
C
C     The First line has already been read.
C
C=======================================================================
      INCLUDE 'implicit.h'
      CHARACTER*1 PROGDOC1
      CHARACTER*4 FMTTAB,FMTHOL
      CHARACTER*66 PROGDOC
      COMMON/LEADER/C1,C2,L1,L2,N1,N2,MAT,MF,MT
      COMMON/HOLFMT/FMTHOL
      COMMON/LISOCOM/LISO
      DIMENSION FMTTAB(3),PROGDOC(3),PROGDOC1(66,3)
      EQUIVALENCE (PROGDOC(1),PROGDOC1(1,1))
C-----ENDF FORMAT VERSION
      DATA IVERSE/6/
      DATA FMTTAB/'4   ','5   ','6   '/
C-----DOCUMENTATION TO ADD TO ENDF OUTPUT - EACH LINE IS 66
C-----CHARACTERS LONG - FIELDS 12345678901 ARE FILLED IN WITH
C-----11 CHARACTERS DURING EXECUTION.
C               1         2         3         4         5         6
C       12345678901234567890123456789012345678901234567890123456789012
C       3456
      DATA PROGDOC/
     1 ' *************** PROGRAM ACTIVATE (VERSION 2021-1) ***********',
     2 ' MF=10 Activation Cross Sections Defined by Combining MF=3    ',
     3 ' Cross Section and MF=9 Multiplier. MF=9 Deleted/MF=8 Updated.'/
C-----FILL IN REMAINDER OF FIRST LINE.
      PROGDOC1(63,1) = '*'
      PROGDOC1(64,1) = '*'
      PROGDOC1(65,1) = '*'
      PROGDOC1(66,1) = '*'
c
c     Read Second Line
c
C-----HEAD LINE OF SECTION HAS BEEN READ AND WRITTEN. READ NEXT LINE
C-----AND DETERMINE IF THIS IS THE ENDF-4, 5 OR 6 FORMAT.
      CALL CARDI(C1,C2,L1,L2,N1,N2)
      IVERSE=4
      LISOX = L2         ! Save as potntial isomeric number
C-----CHECK FOR ENDF-4.
C-----IV N1 > 0, N2 = 0
      IF(N1.GT.0.AND.N2.EQ.0) GO TO 10
C-----NOT ENDF-4. READ THIRD LINE.
      N2X=N2
      CALL CARDO(C1,C2,L1,L2,N1,N2)
c
c     Read third Line
c
      CALL CARDI(C1,C2,L1,L2,N1,N2)
      IVERSE=5
C-----CHECK FOR ENDF-5 FORMAT.
      IF(N2X.LE.0) GO TO 10
C-----ENDF-6 FORMAT. READ FOURTH LINE.
      CALL CARDO(C1,C2,L1,L2,N1,N2)
c
c     Read fourth Line
c
      CALL CARDI(C1,C2,L1,L2,N1,N2)
      IVERSE=6
      LISO  = LISOX                 ! Isomer state number
C-----SET DERIVED MATERIAL FLAG.
      L1=1
C-----DEFINE ENDF FORMAT NUMBER.
   10 FMTHOL=FMTTAB(IVERSE-3)
C-----INCREASE COMMENT LINE COUNT AND COPY TO END OF HOLLERITH.
      N1OUT = N1+3
      CALL CARDO(C1,C2,L1,L2,N1OUT,N2)
      DO 20 N=1,N1
      CALL COPY1
   20 CONTINUE
C-----------------------------------------------------------------------
C
C     ADD COMMENTS TO DOCUMENT WHAT WAS DONE TO DATA.
C
C-----------------------------------------------------------------------
C-----OUTPUT PROGRAM NAME AND VERSION I.D.
      CALL HOLLYO(PROGDOC1(1,1))
      CALL HOLLYO(PROGDOC1(1,2))
      CALL HOLLYO(PROGDOC1(1,3))
C-----COPY TO END OF SECTION.
      CALL COPYS
      RETURN
      END
      SUBROUTINE FILE3
C=======================================================================
C
C     COPY ALL OF MF=3 TO OUTPUT FILE AND SCRATCH.
C
C=======================================================================
      INCLUDE 'implicit.h'
      INTEGER OUTP,OTAPE
      CHARACTER*1 LINE66
      COMMON/ENDFIO/INP,OUTP,ITAPE,OTAPE
      COMMON/UNITS/ISCR1,ISCR2,ISCR3,ISCR4
      COMMON/HEADER/C1H,C2H,L1H,L2H,N1H,N2H,MATH,MFH,MTH,NOSEQ
      COMMON/COUNTS/IZANOW,MATNOW,N2MATI,N2MATO,N2TOTI,N2TOTO
      COMMON/CLINE66/LINE66(66)
C-----------------------------------------------------------------------
C
C     INITIALIZE SCRATCH FILE
C
C-----------------------------------------------------------------------
      MATNOW = MATH
      REWIND ISCR2
      IO1 = OTAPE
      IO2 = ISCR2
C-----HEADER CARD HAS ALREADY BEEN READ - OUTPUT IT.
      NOSEQ = 1
      CALL CONTOG
C-----ALSO OUTPUT TO SCRATCH
      OTAPE = IO2
      CALL CONTO
      NOSEQ = 2     ! Reset NOSEQ due to above CONTO to Scratch.
      OTAPE = IO1
C-----COPY TO END OF MF=3
   10 READ(ISCR1,30) LINE66,MATH,MFH,MTH
      IF(MFH.LE.0) GO TO 20
      IF(MTH.LE.0) THEN
      CALL OUTS(MATH,MFH)
      ELSE
      WRITE(OTAPE,30) LINE66,MATH,MFH,MTH,NOSEQ
      NOSEQ = NXTSEQ(NOSEQ)
      ENDIF
      WRITE(ISCR2 ,30) LINE66,MATH,MFH,MTH
      GO TO 10
   20 ENDFILE ISCR2
      REWIND ISCR2
      RETURN
   30 FORMAT(66A1,I4,I2,I3,I5)
      END
      SUBROUTINE FILE9
C=======================================================================
C
C     COPY ALL OF MF=9 TO SCRATCH - NOT TO OUTPUT.
C
C=======================================================================
      INCLUDE 'implicit.h'
      INTEGER OUTP,OTAPE
      CHARACTER*1 LINE66
      COMMON/ENDFIO/INP,OUTP,ITAPE,OTAPE
      COMMON/UNITS/ISCR1,ISCR2,ISCR3,ISCR4
      COMMON/HEADER/C1H,C2H,L1H,L2H,N1H,N2H,MATH,MFH,MTH,NOSEQ
      COMMON/CLINE66/LINE66(66)
C-----------------------------------------------------------------------
C
C     INITIALIZE SCRATCH FILE
C
C-----------------------------------------------------------------------
C-----SAVE STARTING SEQUENCE NUMBER
      INSEQ = NOSEQ
      REWIND ISCR3
      IO1 = OTAPE
C-----HEADER CARD HAS ALREADY BEEN READ.
      OTAPE = ISCR3
      CALL CONTO
      OTAPE = IO1
C-----COPY TO END OF MF=9
   10 READ(ISCR1,20) LINE66,MATH,MFH,MTH
      WRITE(ISCR3 ,20) LINE66,MATH,MFH,MTH
      IF(MFH.GT.0) GO TO 10
      ENDFILE ISCR3
      REWIND ISCR3
C-----RESTORE STARTING SEQUENCE NUMBER
      NOSEQ = INSEQ
      RETURN
   20 FORMAT(66A1,I4,I2,I3,I5)
      END
      SUBROUTINE FILE10
C=======================================================================
C
C     COPY ALL OF MF=10 TO SCRATCH - NOT TO OUTPUT.
C
C=======================================================================
      INCLUDE 'implicit.h'
      INTEGER OUTP,OTAPE
      CHARACTER*1 LINE66
      COMMON/ENDFIO/INP,OUTP,ITAPE,OTAPE
      COMMON/UNITS/ISCR1,ISCR2,ISCR3,ISCR4
      COMMON/HEADER/C1H,C2H,L1H,L2H,N1H,N2H,MATH,MFH,MTH,NOSEQ
      COMMON/CLINE66/LINE66(66)
C-----------------------------------------------------------------------
C
C     INITIALIZE SCRATCH FILE
C
C-----------------------------------------------------------------------
C-----SAVE STARTING SEQUENCE NUMBER
      INSEQ = NOSEQ
      REWIND ISCR4
      IO1 = OTAPE
C-----HEADER CARD HAS ALREADY BEEN READ.
      OTAPE = ISCR4
      CALL CONTO
      OTAPE = IO1
C-----COPY TO END OF MF=10
   10 READ(ISCR1,20) LINE66,MATH,MFH,MTH
      WRITE(ISCR4,20) LINE66,MATH,MFH,MTH
      IF(MFH.GT.0) GO TO 10
      ENDFILE ISCR4
      REWIND ISCR4
C-----RESTORE STARTING SEQUENCE NUMBER
      NOSEQ = INSEQ
      RETURN
   20 FORMAT(66A1,I4,I2,I3,I5)
      END
      SUBROUTINE READIN
C=======================================================================
C
C     READ AND CHECK ALL INPUT PARAMETERS.
C
C=======================================================================
      INCLUDE 'implicit.h'
      INTEGER OUTP,OTAPE
      CHARACTER*72 NAMEIN,NAMEOUT
      COMMON/ENDFIO/INP,OUTP,ITAPE,OTAPE
      COMMON/IOSTATUS/ISTAT1,ISTAT2
      COMMON/NAMEX/NAMEIN,NAMEOUT
C-----------------------------------------------------------------------
C
C     READ FILENAMES - IF BLANK USE STANDARD FILENAMES
C
C-----------------------------------------------------------------------
C-----INPUT DATA - IF NO INPUT FILE, USE DEFAULT NAMES
      IF(ISTAT1.EQ.1) GO TO 20
      READ(INP,10,END=20,ERR=20) NAMEIN
   10 FORMAT(A72)
      IF(NAMEIN.EQ.' ') NAMEIN = 'ENDFB.IN'
C-----OUTPUT DATA.
      READ(INP,10,END=30,ERR=30) NAMEOUT
      IF(NAMEOUT.EQ.' ') NAMEOUT = 'ENDFB.OUT'
      GO TO 40
C-----------------------------------------------------------------------
C
C     USE DEFAULTS
C
C-----------------------------------------------------------------------
C-----USE DEFAULT FILENAMES
   20 NAMEIN  = 'ENDFB.IN'
   30 NAMEOUT = 'ENDFB.OUT'
      ISTAT1 = 1
C-----PRINT FINAL FILENAMES
   40 WRITE(OUTP,50) NAMEIN,NAMEOUT
      WRITE(*   ,50) NAMEIN,NAMEOUT
   50 FORMAT(
     1 ' ENDF Input and Output Data Filenames'/1X,78('-')/
     2 1X,A72/1X,A72)
C-----------------------------------------------------------------------
C
C     OPEN ENDF DATA FILES
C
C-----------------------------------------------------------------------
      CALL FILIO2
C-----------------------------------------------------------------------
C
C     TERMINATE IF ERROR OPENING ENDF DATAQ FILE
C
C-----------------------------------------------------------------------
      IF(ISTAT2.EQ.1) THEN
      WRITE(OUTP,60) NAMEIN
      WRITE(   *,60) NAMEIN
   60 FORMAT(//' ERROR - Opening ENDF data file'/1X,A72//)
      CALL ENDERROR
      ENDIF
      RETURN
      END
      SUBROUTINE NEXTMT
C=======================================================================
C
C     FIND NEXT REQUESTED MATERIAL BASED EITHER ON ZA OR MAT.
C
C=======================================================================
      INCLUDE 'implicit.h'
      CHARACTER*1 ZABCD
      CHARACTER*4 FMTHOL
      COMMON/COUNTS/IZANOW,MATNOW,N2MATI,N2MATO,N2TOTI,N2TOTO
      COMMON/HEADER/C1H,C2H,L1H,L2H,N1H,N2H,MATH,MFH,MTH,NOSEQ
      COMMON/HOLFMT/FMTHOL
      COMMON/LISOCOM/LISO
      COMMON/BCDZA/ZABCD(12)
C-----READ NEXT LINE AND CHECK FOR END OF ENDF TAPE.
   10 CALL CONTI
      IF(MTH.gt.0) go to 30
      IF(MATH.gt.0) go to 10
      IF(MATH.lt.0) go to 20
C-----------------------------------------------------------------------
C
C     END OF MAT
C
C-----------------------------------------------------------------------
      RETURN
C-----------------------------------------------------------------------
C
C     END OF DATA - OUTPUT SUMMARY OF PRECEDING MATERIAL, IF ANY.
C
C-----------------------------------------------------------------------
C-----RETURN NEGATIVE MATH AS END OF RUN INDICATOR.
   20 MATH  =-1
      MFH   =0
      MTH   =0
      NOSEQ =0
      N2MATI=0
      N2MATO=0
      RETURN
C-----------------------------------------------------------------------
C
C     THIS SECTION REQUESTED. IF NEW MF OR MAT ADD FEND AND MEND LINES
C     AS REQUIRED.
C
C-----------------------------------------------------------------------
   30 IF(MATNOW.EQ.MATH) GO TO 40
C-----INITIALIZE TO ENDF-6 FORMAT.
      FMTHOL='6   '
C-----SAVE CURRENT ZA, MAT.
   40 IZANOW = C1H
c-----2020/3/21 - Added LISO = Target State Number
      CALL ZAHOLM(IZANOW,LISO,ZABCD)
      MATNOW=MATH
      RETURN
      END
      SUBROUTINE CONTOG
C=======================================================================
C
C     WRITE ONE ENDF CONTROL RECORD.
C
C     FIRST ADD FEND AND MEND RECORDS IF NEEDED = IF MAT/MF CHANGE
C
C=======================================================================
      INCLUDE 'implicit.h'
C-----------------------------------------------------------------------
c
c     ADD FEND and MEND as needed.
c
C-----------------------------------------------------------------------
      CALL SYNCEND
C-----------------------------------------------------------------------
c
c     NORMAL OUTPUT LINE FOR NEXT SECTION.
c
C-----------------------------------------------------------------------
      CALL CONTO
      RETURN
      END
      SUBROUTINE SYNCEND
C=======================================================================
C
C     ADD FEND AND MEND RECORDS IF NEEDED.
C
C=======================================================================
      INCLUDE 'implicit.h'
      CHARACTER*1 ZABCD2
      INTEGER OUTP,OTAPE
      COMMON/ENDFIO/INP,OUTP,ITAPE,OTAPE
      COMMON/HEADER/C1H,C2H,L1H,L2H,N1H,N2H,MATH,MFH,MTH,NOSEQ
      COMMON/COUNTS/IZANOW,MATNOW,N2MATI,N2MATO,N2TOTI,N2TOTO
      COMMON/LSTCOM/LSTIZA,LSTMAT,LSTMF
      COMMON/LSTCOMC/ZABCD2(12)
      COMMON/LISOCOM/LISO
      IF(OTAPE.LE.0) RETURN
C-----------------------------------------------------------------------
c
c     ADD FEND AND MEND LINES AS NEEDED.
c
C-----------------------------------------------------------------------
      IF(LSTMAT.LE.0) GO TO 10
C-----ADD FEND LINE IF NEW MAT OR MF.
      IF(MATH.EQ.LSTMAT.AND.MFH.EQ.LSTMF) GO TO 10
      CALL OUTF(LSTMAT)
C-----PRINT SUMMARY OF PRECEDING MAT.
      IF(MATH.EQ.LSTMAT) GO TO 10
C-----------------------------------------------------------------------
C
C     PRINT SUMMARY OF PRECEDING MAT.
C
C-----------------------------------------------------------------------
      CALL REPORT
      N2MATI=0
      N2MATO=0
      CALL OUTM
      NOSEQ=1
C-----------------------------------------------------------------------
c
c     SAVE LAST ZA/MAT/MF FOR OUTPUT AT END OF CURRENT MAT.
c
C-----------------------------------------------------------------------
   10 LSTIZA = C1H
      LSTMAT = MATH
      LSTMF  = MFH
c-----2020/3/21 - Added LISO = Target State Number
      CALL ZAHOLM(LSTIZA,LISO,ZABCD2)
      RETURN
      END
      SUBROUTINE REPORT
C=======================================================================
C
C     PRINT SUMMARY OF PRECEDING MAT - IF ANY.
C
C=======================================================================
      INCLUDE 'implicit.h'
      CHARACTER*1 ZABCD2
      INTEGER OUTP,OTAPE
      COMMON/ENDFIO/INP,OUTP,ITAPE,OTAPE
      COMMON/HEADER/C1H,C2H,L1H,L2H,N1H,N2H,MATH,MFH,MTH,NOSEQ
      COMMON/COUNTS/IZANOW,MATNOW,N2MATI,N2MATO,N2TOTI,N2TOTO
      COMMON/LSTCOM/LSTIZA,LSTMAT,LSTMF
      COMMON/LSTCOMC/ZABCD2(12)
C-----SPECIAL MESSAGE IF NO MF=9 DATA.
      IF(N2MATI.GT.0.OR.N2MATO.GT.0) GO TO 10
      WRITE(OUTP,40) ZABCD2,LSTMAT
      WRITE(*   ,40) ZABCD2,LSTMAT
      GO TO 20
C-----WRITE POINT TOTAL FOR LAST MAT AND ADD TO TAPE TOTALS.
   10 WRITE(OUTP,30) N2MATI,N2MATO
      WRITE(*   ,30) N2MATI,N2MATO
c-----2019/3/7 - Check Maximum Tabulated Energy
   20 CALL MAXIE3(1)
C-----PRINT TIME
      CALL TIMEMAT
      RETURN
   30 FORMAT(1X,78('-')/45X,' MAT Totals',2I7/1X,78('-'))
   40 FORMAT(1X,12A1,I5,8x,' WARNING - No MF=10 to create -',
     1 ' will copy MAT')
      END
      SUBROUTINE FILEIO
C=======================================================================
C
C     DEFINE ALL I/O UNITS AND OPTIONAL DEFINE FILE NAMES.
C
C=======================================================================
      INCLUDE 'implicit.h'
      INTEGER OUTP,OTAPE
      CHARACTER*72 NAMEIN,NAMEOUT
      COMMON/ENDFIO/INP,OUTP,ITAPE,OTAPE
      COMMON/IOSTATUS/ISTAT1,ISTAT2
      COMMON/UNITS/ISCR1,ISCR2,ISCR3,ISCR4
      COMMON/NAMEX/NAMEIN,NAMEOUT
C-----DEFINE ALL UNIT NUMBERS.
      INP=2
      OUTP=3
      ITAPE=10
      OTAPE=11
      ISCR1=12
      ISCR2=14
      ISCR3=15
      ISCR4=16
C-----DEFINE ALL FILE NAMES.
      OPEN(OUTP,FILE='ACTIVATE.LST',STATUS='UNKNOWN')
      OPEN(ISCR1,STATUS='SCRATCH')
      OPEN(ISCR2,STATUS='SCRATCH')
      OPEN(ISCR3,STATUS='SCRATCH')
      OPEN(ISCR4,STATUS='SCRATCH')
      OPEN(INP,FILE='ACTIVATE.INP',STATUS='OLD',ERR=10)
      ISTAT1 = 0
      RETURN
   10 ISTAT1 = 1   ! NO INPUT PARAMETERS = USE STANDARD FILENAMES.
      RETURN
      ENTRY FILIO2
C=======================================================================
C
C     DEFINE ENDF DATA FILE NAMES.
C
C=======================================================================
      OPEN(ITAPE,FILE=NAMEIN ,STATUS='OLD',ERR=20)
      OPEN(OTAPE,FILE=NAMEOUT,STATUS='UNKNOWN')
      ISTAT2 = 0
      RETURN
   20 ISTAT2 = 1 ! NO ENDF INPUT DATA
      RETURN
      END

max_stars_repo_name: IAEA-NDS/PREPRO

max_issues_repo_name: IAEA-NDS/PREPRO

max_forks_repo_name: IAEA-NDS/PREPRO


text: #redirect California Animal Health and Food Safety Lab

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
      subroutine set_ptrk(resflag, lstep, cur_part)
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
C***********************************************************************
CD1
CD1  PURPOSE
CD1
CD1  This subroutine sets up the starting nodes and times for particle
CD1  tracking, activated with macro ptrk.  It is called only once, the
CD1  first time the particle tracker is invoked.
CD1
C***********************************************************************
CD2
CD2  REVISION HISTORY
CD2
CD2 $Log:   /pvcs.config/fehm90/src/set_ptrk.f_a  $
!D2
!D2    Rev 2.5   06 Jan 2004 10:43:52   pvcs
!D2 FEHM Version 2.21, STN 10086-2.21-00, Qualified October 2003
!D2
!D2    Rev 2.4   29 Jan 2003 09:15:10   pvcs
!D2 FEHM Version 2.20, STN 10086-2.20-00
!D2
!D2    Rev 2.3   14 Nov 2001 13:12:26   pvcs
!D2 FEHM Version 2.12, STN 10086-2.12-00
!D2
!D2    Rev 2.2   06 Jun 2001 13:26:30   pvcs
!D2 FEHM Version 2.11, STN 10086-2.11-00
!D2
!D2    Rev 2.1   30 Nov 2000 12:07:24   pvcs
!D2 FEHM Version 2.10, STN 10086-2.10-00
!D2
!D2    Rev 2.0   Fri May 07 14:45:16 1999   pvcs
!D2 FEHM Version 2.0, SC-194 (Fortran 90)
CD2
CD2    Rev 1.8   Wed Mar 27 11:35:48 1996   hend
CD2 Updated for ptrk output options
CD2
CD2    Rev 1.7   Tue Mar 05 16:20:20 1996   hend
CD2 Added initialization for p array
CD2
CD2    Rev 1.6   Fri Jan 12 17:56:26 1996   llt
CD2 changed mmgetblk agruments
CD2
CD2    Rev 1.5   Thu Jan 11 10:25:56 1996   hend
CD2 Added Prolog
CD2
CD2    Rev 1.4   08/07/95 11:39:40   awolf
CD2 Fixed for DPDP (n0 instead of neq). Also changed for
CD2 breakthrough output
CD2
CD2    Rev 1.3   05/08/95 12:49:10   robinson
CD2 Calls plotc1 to write coordinate info to .trc file
CD2
CD2    Rev 1.2   03/15/95 17:05:34   robinson
CD2 Added diffusion and dispersion to particle tracking model
CD2
CD2    Rev 1.1   02/02/95 15:22:50   llt
CD2 added pvcs log info
CD2
C***********************************************************************
CD3
CD3  REQUIREMENTS TRACEABILITY
CD3
CD3  2.3.5 Cell-based particle-tracking module
CD3
C***********************************************************************
CD4
CD4  SPECIAL COMMENTS AND REFERENCES
CD4
CD4 Requirements from SDN: 10086-RD-2.20-00
CD4   SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
CD4   FEHM Application Version 2.20
CD4
C***********************************************************************

      use combi
      use comci
      use comdi
      use comflow
      use compart
      use comdti
      use comai
      use davidi, only : irdof

      implicit none
      integer i,i2,cur_part,positive,num,split,nsizep,icode,resflag
      integer lstep
      real*8 inc, inflow, denom, sdum

c Set the initial node position and starting times for every particle. The
c manner in which these are set is dependent on the type of problem being
c run. Pcnsk must either be all positive or all negative. Positive
c indicates injecting according to source flow, while negative indicates
c evenly distributing the particles over the nodes. Pcnsk gives the
c relative factor to distribute -- i.e. a 2 indicates twice as many
c particles in this node or set of nodes.
      if( resflag .eq. 0 ) then
c make sure pcnsk is either always positive or always negative
         positive=3
         do i=1,n0
            if (pcnsk(i).gt.0.) then
               if (positive.eq.-1) goto 14
               positive=1
            else if (pcnsk(i).lt.0.) then
               if (positive.eq.1) goto 14
               positive=-1
            endif
         enddo
         goto 15

 14      write(ierr,*) 'ERROR: Pcnsk in ptrk must be either always '
         write(ierr,*) 'positive or always negative. '
         write(ierr,*) 'Code aborted in set_ptrk.f'
         if (iatty.ne.0) then
            write(iatty,*) 'ERROR: Pcnsk in ptrk must be either always '
            write(iatty,*) 'positive or always negative. '
            write(iatty,*) 'Code aborted in set_ptrk.f'
         endif
         stop

 15      continue

c     Take care of positive cnsk (apportion by source rate)

         if (positive.eq.1) then
            inflow=0
c     Liquid only and isothermal air-water
            if ((trak_type(1).eq.1).and.(ico2.lt.0)) then
               do i=1,n0
                  if ((pcnsk(i).gt.0.).and.(sk(i).lt.0.)) then
                     inflow=inflow+abs(sk(i))*pcnsk(i)
                  endif
               enddo
               do i=1,n0
                  if ((pcnsk(i).gt.0.).and.(sk(i).lt.0.)) then
                     num=int(num_particles(1)*abs(sk(i))*
     2                    pcnsk(i)/inflow)
                     if(num.gt.0) then
                        inc=(t2sk(i)-t1sk(i))/num
                     end if
                     do i2=1,num
                        box(cur_part,1)=i
                        start_time(cur_part,1)=86400.*(t1sk(i)+
     2                       inc*(i2-1))
                        cur_part=cur_part+1
                     enddo
                  endif
               enddo
c     else if vapor only and isothermal air-water
            else if ((trak_type(1).eq.2).and.(ico2.lt.0)) then
               do i=1,n0
                  if ((pcnsk(i).gt.0.).and.(qh(i).lt.0.)) then
                     inflow=inflow+abs(qh(i))*pcnsk(i)
                  endif
               enddo
               do i=1,n0
                  if ((pcnsk(i).gt.0.).and.(qh(i).lt.0.)) then
                     num=int(num_particles(1)*abs(qh(i))*
     2                    pcnsk(i)/inflow)
                     if(num.gt.0) then
                        inc=(t2sk(i)-t1sk(i))/num
                     end if
                     do i2=1,num
                        box(cur_part,1)=i
                        start_time(cur_part,1)=86400.*
     2                       (t1sk(i)+inc*(i2-1))
                        cur_part=cur_part+1
                     enddo
                  endif
               enddo
c     else if liquid only and not isothermal air-water
            else if ((trak_type(1).eq.1).and.(ico2.ge.0)) then
               do i=1,n0
                  if (irdof .ne. 13 .or. ifree .ne. 0) then
                     sdum = s(i)
                  else
                     sdum = 1.
                  end if
                  if ((pcnsk(i).gt.0.).and.(sk(i)*sdum.lt.0.)) then
                     inflow=inflow+abs(sk(i))*pcnsk(i)
                  endif
               enddo
               do i=1,n0
                  if (irdof .ne. 13 .or. ifree .ne. 0) then
                     sdum = s(i)
                  else
                     sdum = 1.
                  end if
                  if ((pcnsk(i).gt.0.).and.(sk(i)*sdum.lt.0.)) then
                     num=int(num_particles(1)*abs(sk(i))*
     2                    sdum*pcnsk(i)/inflow)
                     if(num.gt.0) then
                        inc=(t2sk(i)-t1sk(i))/num
                     end if
                     do i2=1,num
                        box(cur_part,1)=i
                        start_time(cur_part,1)=86400.*
     2                       (t1sk(i)+inc*(i2-1))
                        cur_part=cur_part+1
                     enddo
                  endif
               enddo
c     else if vapor only and not isothermal air-water
            else if ((trak_type(1).eq.2).and.(ico2.ge.0)) then
               do i=1,n0
                  if ((pcnsk(i).gt.0.).and.(sk(i)*(1-s(i)).lt.0.)) then
                     inflow=inflow+abs(sk(i))*pcnsk(i)
                  endif
               enddo
               do i=1,n0
                  if ((pcnsk(i).gt.0.).and.(sk(i)*(1-s(i)).lt.0.)) then
                     num=int(num_particles(1)*abs(sk(i))*
     2                    (1-s(i))*pcnsk(i)/inflow)
                     if(num.gt.0) then
                        inc=(t2sk(i)-t1sk(i))/num
                     end if
                     do i2=1,num
                        box(cur_part,1)=i
                        start_time(cur_part,1)=86400.*(t1sk(i)+
     2                       inc*(i2-1))
                        cur_part=cur_part+1
                     enddo
                  endif
               enddo

            endif

c     Take care of negative pcnsk
         else

            split=0
            do i=1,n0
               split=split-pcnsk(i)
            enddo
            do i=1,n0
               num=int(num_particles(1)*(-pcnsk(i))/split)
               if(num.gt.0) then
                 inc=(t2sk(i)-t1sk(i))/num
                 do i2=1,num
                   box(cur_part,1)=i
                   start_time(cur_part,1)=86400.*(t1sk(i)+inc*(i2-1))
                   cur_part=cur_part+1
                 enddo
	       endif
            end do
         endif

         num_particles(1)=cur_part-1
c     nsport needs to be set here because the number of particles
c     is not computed until this point
         nsport(2) = num_particles(1)

c     Option 5 has particle concentrations

         if(pout.eq.5) then
            do i = 1, num_particles(1)
               partconc(i) = nodepconc(box(i,1))
            end do
         end if

         do i2 = 1, num_particles(1)
            frac_done(i2,1) = 0.
         end do
      end if
      if (idpdp.eq.0) then
         nsizep = nelm(neq+1) - neq - 1
      else
         nsizep = (nelm(neq+1)-neq-1)*2
      endif
c      call mmgetblk ("p","compart",ipp,
c     +     nsizep,2,icode)
	if(.not. allocated(p)) then
           allocate(p(nsizep))
        end if
        p = -5

      if (pout.eq. -7) then
         write(istrc,100)
      else if (pout.lt.0) then
      write(istrc,*) 'Node Number, Time A Particle Left This Node (sec)'
      else
         call plotc1(0,0)
      endif
 100  format (2x, 'Particle #', 4x, 'Node Number', 5x, 'Zone', 2x,
     &     'Time in node', 3x, 'Current time (sec)')

      if (pout.eq.0) then
         if (trak_type(1).eq.1) then
            do i2=1,num_particles(1)
               if (irdof .ne. 13 .or. ifree .ne. 0) then
                  denom = (rolf(box(i2,1))*ps(box(i2,1))
     2                 *s(box(i2,1))*sx1(box(i2,1)))
                  if(denom .ne. 0.) then
                     an(box(i2,1))=an(box(i2,1))+1/denom
                  else
                     an(box(i2,1)) = 0
                  end if
                  anv(box(i2,1))=an(box(i2,1))
               else
                  sdum = 1.
                  denom = (rolf(box(i2,1))*ps(box(i2,1))
     2                 *sdum*sx1(box(i2,1)))
                  if(denom .ne. 0.) then
                     an(box(i2,1))=an(box(i2,1))+1/denom
                  else
                     an(box(i2,1)) = 0
                  end if
               end if
            enddo
         else
            do i2=1,num_particles(1)
               denom = (rovf(box(i2,1))*ps(box(i2,1))
     2              *(1-s(box(i2,1)))*sx1(box(i2,1)))
               if(denom .ne. 0.) then
                  an(box(i2,1))=an(box(i2,1))+1/denom
               else
                  an(box(i2,1)) = 0.
               end if
               anv(box(i2,1))=an(box(i2,1))
            enddo
         endif
      endif

      return
      end

max_stars_repo_name: satkarra/FEHM

max_issues_repo_name: satkarra/FEHM

max_forks_repo_name: satkarra/FEHM


text:
 module Mod_nsc_ComputeTaus
   use typre
   use Mod_nsc_BaseElmope
   implicit none
   private
   public SetPointersComputeTaus, timom_static

   !External Procedures
   procedure() :: NULLSUB

   !TransientSubgridScales
   real(rp) :: timom_static(3)

   integer(ip), allocatable :: kfl_IsSet

contains

   !----------------------------------------------------------------------------
   !Setting Pointers

   subroutine SetPointersComputeTaus(itask)
      implicit none
      integer(ip) :: itask

      select case (itask)

      case(0)
         allocate(kfl_IsSet)
         call a%Memor%allocObj(0,'kfl_IsSet','InitProcedurePointer',1)
         kfl_IsSet = -1

      case(1)
         if (kfl_IsSet == -1) then
            kfl_IsSet = 1

            !Taus are computed as usual
            ProcHook_nsc_ComputeTaus => ComputeTaus

            if (a%kfl_tacsg == 1) then
               call ConcatenateProcedures(ProcHook_nsc_ComputeTaus,TransientTaus)
            endif

            !Sources Exists
            if (a%kfl_sourc == 1) then
               call ConcatenateProcedures(ProcHook_nsc_ComputeTaus,SourcesTaus)
            endif

         endif
      case(100)
         deallocate(kfl_IsSet)
         call a%Memor%deallocObj(0,'kfl_IsSet','InitProcedurePointer',1)

      end select
   end subroutine

   !-------------------------------------------------------------------
   !Compute Tau values
   subroutine ComputeTaus
     implicit none

     call nsc_ComputeTau(e,gpspd,acvis*invgpd,actco*invgpd/accph,gpmno*invgpd,a%staco,chale,timom)

   end subroutine

   !Computes the transient stabilization parameter
   subroutine TransientTaus
     !timom is the transient one, the static one goes to timom_static
     timom_static = timom
     call ComputeTransientTau(ReferenceDtinv,1.0_rp,timom_static(1),timom(1))
     call ComputeTransientTau(ReferenceDtinv,1.0_rp,timom_static(2),timom(2))
     call ComputeTransientTau(ReferenceDtinv,1.0_rp,timom_static(3),timom(3))
   end subroutine

   subroutine SourcesTaus

     call nsc_ComputeSourcesTau(e,gpspd,acvis*invgpd,actco*invgpd/accph,gpmno*invgpd,a%grnor,a%srce,a%staco,chale,timom)

   end subroutine
end module

max_stars_repo_name: ciaid-colombia/InsFEM

max_issues_repo_name: ciaid-colombia/InsFEM

max_forks_repo_name: ciaid-colombia/InsFEM


text:
! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! DART $Id: dart_to_parflow.f90 Wed Apr 11 20:26:43 CEST 2018 $

program dart_to_parflow

!----------------------------------------------------------------------
! method: Read DART state vector and overwrite values in the parflow restart file.
!         If the DART state vector has an 'advance_to_time' present, a
!         file called "dart_posterior_times.txt" is created to help
!         parflow to advance to the requested time.
!
!         The dart_to_pfb_nml namelist setting for advance_time_present
!         determines whether or not the input file has an 'advance_to_time'.
!         Typically, only temporary files like 'assim_model_state_ic' have
!         an 'advance_to_time'.
!----------------------------------------------------------------------

use        types_mod, only : r8

use    utilities_mod, only : initialize_utilities, finalize_utilities, &
                             find_namelist_in_file, check_namelist_read, &
                             logfileunit, open_file, close_file, E_ERR, E_MSG, &
                             error_handler

use  assim_model_mod, only : open_restart_read, aread_state_restart, close_restart

use time_manager_mod, only : time_type, print_time, print_date, operator(-), &
                             get_time, get_date

use        model_mod, only : static_init_model, write_parflow_file, &
                             get_parflow_id, PRESSURE_HEAD, SATURATION,  &
                             get_model_size, get_state_vector, write_state_times

implicit none

! version controlled file description for error handling, do not edit
character(len=*), parameter :: source   = "$URL: dart_to_parflow.f90 $"
character(len=*), parameter :: revision = "$Revision: Bonn $"
character(len=*), parameter :: revdate  = "$Date: Wed Apr 11 2018 $"

character(len=512) :: string1, string2, string3

!------------------------------------------------------------------
! The namelist variables
!------------------------------------------------------------------

character(len=256) :: pfb_restart_filename   = 'model_restartfile'
character(len=256) :: dart_to_pfb_input_file = 'dart_restart'
logical            :: advance_time_present   = .false.
logical            :: verbose                = .false.

namelist /dart_to_pfb_nml/  dart_to_pfb_input_file, &
                            advance_time_present,   &
                            pfb_restart_filename,   &
                            verbose

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

integer               :: iunit, io, x_size
type(time_type)       :: model_time, adv_to_time, base_time
real(r8), allocatable :: statevector(:)
real(r8), allocatable :: pfb_state(:)
integer               :: pfid, jpfb

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

call initialize_utilities(progname='dart_to_parflow')

! model_mod:static_init_model() reads the model namelist and set grid sizes, etc.

call static_init_model()

x_size = get_model_size()
allocate(statevector(1:x_size))

! Read the namelist to get the input filename.

call find_namelist_in_file("input.nml", "dart_to_pfb_nml", iunit)
read(iunit, nml = dart_to_pfb_nml, iostat = io)
call check_namelist_read(iunit, io, "dart_to_pfb_nml")

!----------------------------------------------------------------------
! Reads the valid time, the state, and the target time.
!----------------------------------------------------------------------

iunit = open_restart_read(dart_to_pfb_input_file)

if ( advance_time_present ) then
   call aread_state_restart(model_time, statevector, iunit, adv_to_time)
else
   call aread_state_restart(model_time, statevector, iunit)
endif
call close_restart(iunit)

call print_date( model_time,' dart_to_parflow model date')
call print_time( model_time,' dart_to_parflow model time')
call print_date( model_time,' dart_to_parflow model date',logfileunit)
call print_time( model_time,' dart_to_parflow model time',logfileunit)

!----------------------------------------------------------------------
! update the current model state vector
! Convey the amount of time to integrate the model ...
! time_manager_nml: stop_option, stop_count increments
!----------------------------------------------------------------------

allocate( pfb_state(1:x_size) )

pfid = get_parflow_id()

!>@todo I do not understand why we switch ... don't we always update the pressure
if (pfid .eq. PRESSURE_HEAD) then
   jpfb               = SATURATION
   write(string3,'(A)')'SATURATION'
elseif (pfid .eq. SATURATION) then
   jpfb               = PRESSURE_HEAD
   write(string3,'(A)')'PRESSURE_HEAD'
endif

write(string1,'(A)')'converting DART file "'//trim(dart_to_pfb_input_file)//'"'
write(string2,'(A)')'using parflow state "'//trim(string3)//'"'
write(string3,'(A)')'updating "'//trim(pfb_restart_filename)//'"'
call error_handler(E_MSG,'dart_to_parflow',string1,text2=string2,text3=string3)

call get_state_vector(pfb_state, jpfb)

call write_parflow_file(statevector, pfb_state, &
             dart_to_pfb_input_file, pfb_restart_filename)

!>@todo ... dart_posterior_times.txt and dart_prior_time.txt will always
!>          have the same information ...

iunit = open_file('dart_posterior_times.txt', action='write')
call write_state_times(iunit, model_time)
call close_file(iunit)

!----------------------------------------------------------------------
! Log what we think we're doing, and exit.
!----------------------------------------------------------------------

!>@ the adv_to_time is never used ... we can skip this if need be ...

if ( advance_time_present ) then
call print_time(adv_to_time,' dart_to_parflow advance_to time')
call print_date(adv_to_time,' dart_to_parflow advance_to date')
call print_time(adv_to_time,' dart_to_parflow advance_to time',logfileunit)
call print_date(adv_to_time,' dart_to_parflow advance_to date',logfileunit)
endif

call finalize_utilities(progname='dart_to_parflow')

end program dart_to_parflow

max_stars_repo_name: niklaswr/TSMP

max_issues_repo_name: niklaswr/TSMP

max_forks_repo_name: niklaswr/TSMP


text:
program datatype_struct
  use mpi
  implicit none
  type particle
     real :: coords(3)
     integer :: charge
     character(len=2) :: label
  end type particle
  integer, parameter :: n = 1000
  integer :: i, ierror,  myid,  ntasks, tag
  type(particle) :: particles(n)

  integer, parameter :: cnt=3
  integer:: particle_mpi_type, temp_type
  integer:: types(cnt),blocklen(cnt)
  integer(KIND=MPI_ADDRESS_KIND) :: disp(cnt)
  integer(KIND=MPI_ADDRESS_KIND) :: lb, extent
  real(8) :: t1,t2

  call MPI_INIT(ierror)
  call MPI_COMM_RANK(MPI_COMM_WORLD, myid, ierror)
  call MPI_COMM_SIZE(MPI_COMM_WORLD, ntasks, ierror)

  ! insert some data for the particle struct
  if(myid == 0) then
    do i = 1, n
      call random_number(particles(i)%coords)
      particles(i)%charge = 54
      particles(i)%label = 'Xe'
    end do
  end if

  ! define the datatype for type particle
  types=(/ MPI_REAL, MPI_INTEGER, MPI_CHARACTER  /)
  blocklen=(/ 3,1,2 /)
  call MPI_GET_ADDRESS(particles(1)%coords, disp(1), ierror)
  call MPI_GET_ADDRESS(particles(1)%charge, disp(2), ierror)
  call MPI_GET_ADDRESS(particles(1)%label, disp(3), ierror)
  do i = cnt, 1, -1
    disp(i)=disp(i)-disp(1)
  end do
  call MPI_TYPE_CREATE_STRUCT(cnt, blocklen, &
      disp,types, particle_mpi_type,ierror)
  call MPI_TYPE_COMMIT(particle_mpi_type, ierror)

  ! Check extent.
  ! (Not really neccessary on most systems.)
  call MPI_TYPE_GET_EXTENT(particle_mpi_type,lb,extent,ierror)
  call MPI_GET_ADDRESS(particles(1),disp(1),ierror)
  call MPI_GET_ADDRESS(particles(2),disp(2),ierror)
  ! resize the particle_mpi_type
  if(extent /= disp(2)-disp(1)) then
    temp_type=particle_mpi_type
    lb=0
    extent=disp(2)-disp(1)
    call MPI_TYPE_CREATE_RESIZED(temp_type,lb,extent,particle_mpi_type,ierror)
    call MPI_TYPE_COMMIT(particle_mpi_type,ierror)
    call MPI_TYPE_free(temp_type,ierror)
  end if

  t1=MPI_WTIME()
  if(myid == 0) then
     do i=1,1000
        call MPI_SEND(particles, n, particle_mpi_type, 1, i, &
                      MPI_COMM_WORLD,ierror)
     end do
  else if(myid == 1) then
     do i=1, 1000
        call MPI_RECV(particles, n, particle_mpi_type, 0, i, &
                      MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierror)
     end do
  end if
  t2=MPI_WTIME()

  write(*,*) "Time: ", myid, (t2-t1) / 1000d0
  write(*,*) "Check:", myid, particles(n)%label, particles(n)%coords(1), &
                       particles(n)%coords(2), particles(n)%coords(3)

  call MPI_TYPE_free(particle_mpi_type, ierror)
  call MPI_FINALIZE(ierror)

end program datatype_struct

max_stars_repo_name: mrgransky/advanced-parallel-prog

max_issues_repo_name: mrgransky/advanced-parallel-prog

max_forks_repo_name: mrgransky/advanced-parallel-prog


text:
! { dg-do compile }
! PR 33229
implicit none
intrinsic cpu_time  ! { dg-error "attribute conflicts with" }
real :: time
print *, CPU_TIME(TIME)  ! { dg-error "is not a function" }
end


text:
submodule (filesystem) find_filesystem
!! procedures that find files

implicit none (type, external)

contains

module procedure get_filename

character(:), allocatable :: path1, suff(:)
integer :: i

if(present(suffixes)) then
  suff = suffixes
else
  suff = [character(4) :: '.h5', '.nc', '.dat']
endif

get_filename = trim(path)  !< first to avoid undefined return

if(len(get_filename) == 0) return

if(present(name)) then
  if(index(get_filename, name, back=.true.) == 0) then
    !> assume we wish to append stem to path
    get_filename = get_filename // '/' // name
  elseif(index(get_filename, '.', back=.true.) > 4) then
    !> it's a stem-matching full path with a suffix
    if(.not. is_file(get_filename)) get_filename = ''
    return
  endif
endif

if(is_file(get_filename)) return

path1 = get_filename

do i = 1, size(suff)
  get_filename = path1 // trim(suff(i))
  if (is_file(get_filename)) return
enddo

get_filename = ''
if(present(name)) then
  write(stderr,*) 'filesystem:get_filename: ',name,' not found in ', path
else
  write(stderr,*) 'filesystem:get_filename: file not found: ',path
endif

end procedure get_filename

module procedure make_absolute

character(:), allocatable :: p

p = expanduser(path)
if (is_absolute(p)) then
  make_absolute = p
else
  make_absolute = expanduser(top_path) // '/' // p
endif

end procedure make_absolute

end submodule find_filesystem

max_stars_repo_name: scivision/fortran-pathlib

max_issues_repo_name: scivision/fortran-filesystem

max_forks_repo_name: scivision/fortran-filesystem