diff options
| author | stainer_t <thomas.stainer@oecd-nea.org> | 2025-09-08 13:48:49 +0200 |
|---|---|---|
| committer | stainer_t <thomas.stainer@oecd-nea.org> | 2025-09-08 13:48:49 +0200 |
| commit | 7dfcc480ba1e19bd3232349fc733caef94034292 (patch) | |
| tree | 03ee104eb8846d5cc1a981d267687a729185d3f3 /Trivac/src | |
Initial commit from Polytechnique Montreal
Diffstat (limited to 'Trivac/src')
217 files changed, 59999 insertions, 0 deletions
diff --git a/Trivac/src/ALBEIGS.f90 b/Trivac/src/ALBEIGS.f90 new file mode 100755 index 0000000..de3a1c5 --- /dev/null +++ b/Trivac/src/ALBEIGS.f90 @@ -0,0 +1,465 @@ +! +!---------------------------------------------------------------------------- +! +!Purpose: +! Find a few eigenvalues and eigenvectors for the standard eigenvalue problem +! A*x = lambda*x using the implicit restarted Arnoldi method (IRAM). +! +!Copyright: +! Copyright (C) 2020 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): A. Hebert +! +!Reference: +! J. Baglama, "Augmented Block Householder Arnoldi Method," +! Linear Algebra Appl., 429, Issue 10, 2315-2334 (2008). +! +!Parameters: input +! atv function pointer for the matrix-vector product returning Ab +! where b is input. The format for atv is "x=atv(b,n,blsz,iter,...)" +! n order of matrix A. +! blsz block size of the Arnoldi Hessenberg matrix (blsz=3 recommended) +! K_org number of desired eigenvalues +! maxit maximum number of iterations +! tol tolerance used for convergence (tol=1.0d-6 recommended) +! impx print parameter: =0: no print; =1: minimum printing. +! iptrk L_TRACK pointer to the tracking information +! ipsys L_SYSTEM pointer to system matrices +! ipflux L_FLUX pointer to the solution +! +!Parameters: output +! iter actual number of iterations +! V eigenvector matrix +! D eigenvalue diagonal matrix +! +!---------------------------------------------------------------------------- +! +subroutine ALBEIGS(atv,n,blsz,K_org,maxit,tol,impx,iter,V,D,iptrk,ipsys,ipflux) + use GANLIB + implicit complex(kind=8)(a-h,o-z) + !---- + ! Subroutine arguments + !---- + interface + function atv(b,n,blsz,iter,iptrk,ipsys,ipflux) result(x) + use GANLIB + integer, intent(in) :: n,blsz,iter + complex(kind=8), dimension(n,blsz), intent(in) :: b + complex(kind=8), dimension(n,blsz) :: x + type(c_ptr) iptrk,ipsys,ipflux + end function atv + end interface + integer, intent(in) :: n,blsz,K_org,maxit,impx + real(kind=8), intent(in) :: tol + integer, intent(out) :: iter + complex(kind=8), dimension(n,K_org), intent(inout) :: V + complex(kind=8), dimension(K_org,K_org), intent(out) :: D + type(c_ptr) iptrk,ipsys,ipflux + !---- + ! Local variables + !---- + integer :: Hsz_n,Hsz_m,Tsz_m,H_sz1,H_sz2,adjust + real(kind=8) :: tol2 + integer, parameter :: nbls_init=10 ! Maximum number of Arnoldi vectors. + integer, parameter :: iunout=6 + real(kind=8), parameter :: eps=epsilon(tol) + complex(kind=8), dimension(1,1) :: onebyone + complex(kind=8), dimension(2,2) :: twobytwo + logical :: eig_conj + character(len=1) :: conv + character(len=131) :: hsmg + !---- + ! Allocatable arrays + !---- + integer, allocatable, dimension(:) :: vadjust,iset + real(kind=8), allocatable, dimension(:) :: residuals,tau + real(kind=8), allocatable, dimension(:,:) :: work2d_r,w,QR,T_Schur + complex(kind=8), allocatable, dimension(:) :: V_sign,work1d + complex(kind=8), allocatable, dimension(:,:) :: T_blk,H_R,DD,Q,R,work2d + complex(kind=8), pointer, dimension(:) :: DH_eig + complex(kind=8), pointer, dimension(:,:) :: T,T_old,H,H_old,VC,VC_old,H_eig,H_eigv + + ! Resize Krylov subspace if blsz*nbls (i.e. number of Arnoldi vectors) + ! is larger than n (i.e. the size of the matrix A). + if(impx > 1) write(iunout,'(/23H ALBEIGS: IRAM solution)') + nbls = nbls_init + if(blsz*nbls >= n) then + nbls = floor(real(n)/real(blsz)) + write(6,'(26h ALBEIGS: Changing nbls to,i5)') nbls + endif + + ! Increase the number of desired values to help increase convergence. + ! Set K_org+adjust(1) to be next multiple of blsz > K_org. + allocate(vadjust(blsz)) + do i=1,blsz + vadjust(i)=mod(K_org+i-1,blsz) + enddo + adjust=findlc(vadjust,0) + deallocate(vadjust) + K = K_org + adjust + allocate(VC(n,blsz), T(blsz,blsz)) + + ! Check for input errors in the structure array. + if(K <= 0) call XABORT('ALBEIGS: K must be a positive value.') + if(K > n) call XABORT('ALBEIGS: K is too large.') + if(blsz <= 0) call XABORT('ALBEIGS: blsz must be a positive value.') + if(blsz > K_org) call XABORT('ALBEIGS: blsz <= K_org expected.') + + ! Automatically adjust Krylov subspace to accommodate larger values of K. + if(blsz*(nbls-1) - blsz - K - 1 < 0) then + nbls = ceiling((K+1)/blsz+2.1) + write(6,'(26h ALBEIGS: Changing nbls to,i5)') nbls + endif + if(blsz*nbls >= n) then + nbls = floor(n/blsz-0.1) + write(6,'(26h ALBEIGS: Changing nbls to,i5)') nbls + endif + if(blsz*(nbls-1) - blsz - K - 1 < 0) call XABORT('ALBEIGS: K is too large.') + VC(:n,:blsz) = V(:n,:blsz) ! set initial eigenvector estimate + + tol2 = tol + if(tol < eps) tol2 = eps ! Set tolerance to machine precision if tol < eps. + + allocate(tau(n),residuals(K_org)) + ! allocate adjustable T matrix in the WY representation of the Householder + ! products. + m = blsz ! Current number of columns in the matrix VC. + nullify(DH_eig, H_eig, H_eigv) + allocate(H(blsz,0)) + iter = 0 ! Main loop iteration count. + do + iter = iter+1 + if(iter > maxit) then + call XABORT('ALBEIGS: maximum number of IRAM iterations reached') + endif + allocate(T_blk(blsz,blsz)); T_blk(:blsz,:blsz)=0.0d0; + ! Compute the block Householder Arnoldi decomposition. + if(blsz*(nbls+1) > n) nbls = floor(real(n)/real(blsz))-1 + + ! Begin of main iteration loop for the Augmented Block Householder Arnoldi + ! decomposition. + do + if(m > blsz*(nbls+1)) exit + allocate(work2d_r(n-m+blsz,blsz)) + work2d_r(:n-m+blsz,:blsz) = real(VC(m-blsz+1:n,m-blsz+1:m)) + call ALST2F(n-m+blsz,n-m+blsz,blsz,work2d_r(:,:),tau) + VC(m-blsz+1:n,m-blsz+1:m) = work2d_r(:n-m+blsz,:blsz) + deallocate(work2d_r) + if(m > blsz) then + H_old => H + allocate(H(m,m-blsz)); H(:m,:m-blsz) = 0.0d0; + H(:m-blsz,:m-2*blsz) = H_old(:,:) + deallocate(H_old) + H(:m-blsz,m-2*blsz+1:m-blsz) = VC(:m-blsz,m-blsz+1:m) + do i=m-blsz+1,m + H(i,i-blsz:m-blsz) = VC(i,i:m) + enddo + endif + m2 = 2*m + if(m2 > n) m2=n + do j=1,blsz + VC(1:m-blsz+j,m-blsz+j) = 0.0d0 + enddo + do i=m-blsz+1,m + VC(i,i)=1.0d0 + enddo + onebyone=matmul(tcg(VC(:,m-blsz+1:m-blsz+1)),VC(:,m-blsz+1:m-blsz+1)) + T_blk(1,1) = -2.0d0/onebyone(1,1) + do i=2,blsz + T_blk(:i,i:i) = tcg(matmul(tcg(VC(:,m-blsz+i:m-blsz+i)),VC(:,m-blsz+1:m-blsz+i))) + T_blk(i,i) = -2.0d0/T_blk(i,i) + T_blk(:i-1,i) = T_blk(i,i)*matmul(T_blk(:i-1,:i-1),T_blk(:i-1,i)) + enddo + + ! Matrix T expansion + if(m == blsz) then + T(:m,:m) = T_blk(:m,:m) + else + T_old => T + allocate(T(m,m)) + T(:m-blsz,:m-blsz) = T_old(:m-blsz,:m-blsz); T(m-blsz+1:m,:m-blsz) = 0.0d0; + T(:m-blsz,m-blsz+1:m) = matmul(matmul(T_old,tcg(matmul(tcg(VC(:,m-blsz+1:m)),VC(:,1:m-blsz)))),T_blk) + T(m-blsz+1:m,m-blsz+1:m) = T_blk(:blsz,:blsz) + deallocate(T_old) + endif + + ! Resize and reactualize VC + if(m <= blsz*nbls) then + VC_old => VC + allocate(VC(n,m+blsz)) + do j=1,m + VC(:n,j) = VC_old(:n,j) + enddo + deallocate(VC_old) + VC(:,m+1:m+blsz) = matmul(VC(:,:m),matmul(T,tcg(VC(m-blsz+1:m,:m)))) + do i=1,blsz + VC(i+m-blsz,i+m) = VC(i+m-blsz,i+m) + 1.0d0 + enddo + VC(:,m+1:m+blsz) = atv(VC(:,m+1:m+blsz),n,blsz,iter,iptrk,ipsys,ipflux) + allocate(work2d(n,blsz)) + work2d(:,:) = matmul(VC(:,:m),tcg(matmul(matmul(tcg(VC(:,m+1:m+blsz)),VC(:,:m)),T))) + VC(:,m+1:m+blsz) = VC(:,m+1:m+blsz) + work2d(:,:) + deallocate(work2d) + endif + m = m + blsz + enddo + deallocate(T_blk) + + ! Determine the size of the block Hessenberg matrix H. Possible truncation may occur + ! if an invariant subspace has been found. + Hsz_n = size(H,1); Hsz_m = size(H,2); + + ! Compute the eigenvalue decomposition of the block Hessenberg H(:Hsz_m,:). + if(associated(H_eigv)) deallocate(H_eigv,H_eig,DH_eig) + allocate(H_eigv(Hsz_m,Hsz_m), H_eig(Hsz_m,Hsz_m), DH_eig(Hsz_m)) + allocate(work2d_r(Hsz_m, Hsz_m)) + work2d_r(:Hsz_m,:Hsz_m)=real(H(:Hsz_m,:Hsz_m)) + call ALHQR(Hsz_m, Hsz_m, work2d_r, 200, jter, H_eigv, H_eig) + deallocate(work2d_r) + do i=1,Hsz_m + DH_eig(i) = H_eig(i,i) + enddo + + ! Check the accuracy of the computation of the eigenvalues of the + ! Hessenberg matrix. This is used to monitor balancing. + conv = 'F'; ! Boolean to determine if all desired eigenpairs have converged. + + ! Sort the eigenvalue and eigenvector arrays. + allocate(iset(Hsz_m),work1d(Hsz_m),work2d(Hsz_m,Hsz_m)) + call ALINDX(Hsz_m, DH_eig(:), iset) + do i=1,Hsz_m + work1d(i) = DH_eig(iset(i)) + work2d(:Hsz_m,i) = H_eigv(:Hsz_m,iset(i)) + enddo + DH_eig(:Hsz_m) = work1d(:Hsz_m); H_eigv(:Hsz_m,:Hsz_m) = work2d(:Hsz_m,:Hsz_m) + deallocate(work2d,work1d,iset) + + ! Compute the residuals for the K_org Ritz values. + residuals(:K_org) = sqrt(sum(abs(matmul(H(Hsz_n-blsz+1:Hsz_n,Hsz_m-blsz+1:Hsz_m), & + H_eigv(Hsz_m-blsz+1:Hsz_m,:K_org)))**2, 1)) + if(impx > 1) write(iunout,200) iter,residuals(:K_org) + + ! Check for convergence. + conv = 'T' + do i=1,K_org + if(residuals(i) >= tol2*abs(DH_eig(i))) conv = 'F' + enddo + + ! Adjust K to include more vectors as the number of vectors converge. + K = K_org + adjust + do i=1,K_org + if(residuals(i) < eps*abs(DH_eig(i))) K = K+1 + enddo + if(K > Hsz_m - 2*blsz-1) K = Hsz_m - 2*blsz-1 + + ! Determine if K splits a conjugate pair. If so replace K with K + 1. + if(aimag(DH_eig(K)) /= 0.0d0) then + eig_conj = .true. + if(K < Hsz_m) then + if(abs(aimag(DH_eig(K)) + aimag(DH_eig(K+1))) < sqrt(eps)) then + K = K + 1 + eig_conj = .false. + endif + endif + if(K > 1 .and. eig_conj) then + if(abs(aimag(DH_eig(K)) + aimag(DH_eig(K-1))) < sqrt(eps)) then + eig_conj = .false. + endif + endif + if(eig_conj) then + write(hsmg,'(9h ALBEIGS:,i5,25h-th conjugate pair split.)') K + call XABORT(hsmg) + endif + endif + + ! If all desired Ritz values converged then exit main loop. + if(conv == 'T') exit + + ! Compute the QR factorization of H_eigv(:,:K). + allocate(iset(Hsz_m)) + nset=0 + do i=1,Hsz_m + if(abs(aimag(DH_eig(i))) > 1.0d-10) then + nset=nset+1 + iset(nset)=i + endif + enddo + allocate(Q(Hsz_m,K)) + if(nset == 0) then + Q(:,:) = H_eigv(:,:K) + else + ! Convert the complex eigenvectors of the eigenvalue decomposition of H + ! to real vectors and convert the complex diagonal matrix to block diagonal. + allocate(work2d(Hsz_m,Hsz_m)); work2d(:Hsz_m,:Hsz_m) = 0.0d0; + do i=1,Hsz_m + work2d(i,i) = 1.0d0 + enddo + twobytwo(1,1) = cmplx(1.0d0, 0.0d0, kind=8); twobytwo(2,1) = cmplx(0.0d0, 1.0d0, kind=8); + twobytwo(1,2) = cmplx(1.0d0, 0.0d0, kind=8); twobytwo(2,2) = -cmplx(0.0d0, 1.0d0, kind=8); + do i=1,Hsz_m + ii=findlc(iset(:nset),i) + if(mod(ii-1,2)+1.eq.1) then + if(conjg(DH_eig(i)) /= DH_eig(i+1)) call XABORT('ALBEIGS: invalid diagonal') + work2d(i:i+1,i:i+1) = twobytwo; + endif + enddo + call ALINVC(Hsz_m,work2d,Hsz_m,ier) + if(ier /= 0) call XABORT('ALBEIGS: singular matrix(1)') + Q(:,:) = matmul(H_eigv(:,:Hsz_m),work2d(:Hsz_m,:K)) + deallocate(work2d) + endif + deallocate(iset) + allocate(work2d_r(Hsz_m,K)) + do i=1,Hsz_m + work2d_r(i,:K) = real(Q(i,:K)) + enddo + deallocate(Q) + call ALST2F(Hsz_m,Hsz_m,K,work2d_r(:,:K),tau) + allocate(QR(Hsz_m,K)); QR(:Hsz_m,:K) = 0.0d0; + do i=1,K + QR(i,i) = 1.0d0 + enddo + do j = K,1,-1 + allocate(w(Hsz_m-j+1,1)) + w(:,:) = reshape((/1.0d0, work2d_r(j+1:Hsz_m,j)/), (/Hsz_m-j+1, 1/)) + QR(j:Hsz_m,:) = QR(j:Hsz_m,:)+tau(j)*matmul(w,matmul(transpose(w),QR(j:Hsz_m,:))) + deallocate(w) + enddo + deallocate(work2d_r) + + ! The Schur matrix for H. + allocate(T_Schur(K,K)) + T_Schur = matmul(matmul(transpose(QR),real(H(:Hsz_m,:))),QR) + do i=3,K + T_Schur(i,:i-2) = 0.0d0 + enddo + + ! Compute the starting vectors and the residual vectors from the Householder + ! WY form. The starting vectors will be the first K Schur vectors and the + ! residual vectors are stored as the last blsz vectors in the Householder WY form. + Tsz_m = size(T,1) + VC(:,Hsz_n-blsz+1:Hsz_n)= matmul(VC(:,:Tsz_m),matmul(T,tcg(VC(Tsz_m-blsz+1:Tsz_m,:Tsz_m)))) + do i=Tsz_m-blsz+1,Tsz_m-blsz+blsz + VC(i,i) = VC(i,i) + 1.0d0 + enddo + allocate(work2d(n,K)) + do j=1,K + work2d(:,j) = matmul(VC(:,:Hsz_m),matmul(T(:Hsz_m,:Hsz_m),matmul(tcg(VC(:Hsz_m,:Hsz_m)),QR(:,j)))) + enddo + do j=1,K + VC(:,j) = work2d(:,j) + VC(:Hsz_m,j) = QR(:Hsz_m,j) + VC(:Hsz_m,j) + enddo + deallocate(work2d) + + ! Set the size of the large matrix VC and move the residual vectors. + m = K + 2*blsz; VC(:,K+1:K+blsz) = VC(:,Hsz_n-blsz+1:Hsz_n); + + ! Set the new starting vector(s) to be the desired vectors VC(:,:K) with the + ! residual vectors VC(:,Hsz_n-blsz+1:Hsz_n). Place all vectors in the compact + ! WY form of the Householder product. Compute the next set of vectors by + ! computing A*VC(:,Hsz_n-blsz+1:Hsz_n) and store this in VC(:,Hsz_n+1:Hsz_n+blsz). + m2=m-blsz + allocate(R(m2,m2), V_sign(m2), DD(m2,m2)) + R(:m2,:m2) = 0.0d0; V_sign(:m2) = 1.0d0; DD(:m2,:m2) = 0.0d0; + deallocate(T) + allocate(T(m2,m2)) + T = VC(:m2,:m2) + VC(:,m2+1:m) = atv(VC(:,m2-blsz+1:m2),n,blsz,iter,iptrk,ipsys,ipflux) + do i =1,m2 + V_sign(i) = VC(i,i)/abs(VC(i,i)) + if(VC(i,i) == 0.0d0) V_sign(i)=1.0d0 + R(i,i) = -V_sign(i) + Vdot = 1.0d0 + V_sign(i)*VC(i,i) ! Dot product of Householder vectors. + VC(i,i) = VC(i,i) + V_sign(i) ! Reflection to the ith axis. + DD(i,i) = 1.0d0/VC(i,i) ! Used for scaling. Note: VC(i,i) >= 1. + VC(:m2,i+1:m2) = VC(:m2,i+1:m2) - (V_sign(i)/Vdot)*matmul(VC(:m2,i:i),VC(i:i,i+1:m2)) + enddo + VC(:m2,:m2) = matmul(VC(:m2,:m2),DD) + deallocate(DD, V_sign) + VC(:,m2+1:m) = matmul(VC(:,m2+1:m),R(m2-blsz+1:m2,m2-blsz+1:m2)) + T = matmul(T,R) + do i=1,m2 + VC(i,i+1:m2) = 0.0d0 + T(i,i) = T(i,i) - 1.0d0 + enddo + allocate(H_R(m2,m2)) + H_R(:m2,:m2) = tcg(VC(:m2,:m2)) + call ALINVC(m2,H_R,m2,ier) + if(ier /= 0) call XABORT('ALBEIGS: singular matrix(2)') + T(:m2,:m2) = matmul(T, H_R) + H_R(:m2,:m2) = VC(:m2,:m2) + call ALINVC(m2,H_R,m2,ier) + if(ier /= 0) call XABORT('ALBEIGS: singular matrix(3)') + T(:m2,:m2) = matmul(H_R, T) + do i=2,m2 + T(i,:i-1) = 0.0d0 + enddo + H_R(:m2,:m2) = matmul(T,tcg(VC(:m2,:m2))) + call ALINVC(m2,H_R,m2,ier) + if(ier /= 0) call XABORT('ALBEIGS: singular matrix(4)') + allocate(work2d(n-m2,m2)) + do j=1,m2 + work2d(:n-m2,j) = matmul(VC(m2+1:n,:m2),matmul(R(:m2,:m2),H_R(:m2,j))) + enddo + do j=1,m2 + VC(m2+1:n,j) = work2d(:n-m2,j) + enddo + deallocate(work2d, H_R) + VC(:,m2+1:m) = VC(:,m2+1:m) + matmul(VC(:,:m2),tcg(matmul(matmul(tcg(VC(:,m2+1:m)),VC(:,:m2)),T))) + + ! Compute the first K columns and K+blsz rows of the matrix H, used in augmenting. + allocate(H_R(blsz,blsz)) + H_R(:blsz,:blsz) = H(Hsz_n-blsz+1:Hsz_n,Hsz_m-blsz+1:Hsz_m) + deallocate(H) + allocate(H(K+blsz,K)); H(:K+blsz,:K)=0.0d0; + H(:K,:K) = matmul(R(:K,:K),matmul(T_Schur(:K,:K),R(:K,:K))) + H(K+1:K+blsz,:K) = matmul(R(K+1:K+blsz,K+1:K+blsz),matmul(H_R, & + matmul(QR(Hsz_m-(blsz-1):Hsz_m,:K),R(:K,:K)))) + deallocate(T_Schur, H_R, R, QR) + enddo + deallocate(residuals,tau) + + ! Truncated eigenvalue and eigenvector arrays to include only desired eigenpairs. + Tsz_m = size(T,1); H_sz1 = size(H_eigv,1); H_sz2 = size(H_eigv,2); + do j=1,H_sz2 + VC(:,j) = matmul(VC(:,:Tsz_m),matmul(T,matmul(tcg(VC(:H_sz1,:Tsz_m)),H_eigv(:H_sz1,j)))) + enddo + VC(:H_sz1,:H_sz2) = H_eigv + VC(:H_sz1,:H_sz2) + + ! Set the first K_org eigensolutions + D(:K_org,:K_org)=0.0d0 + do i=1,K_org + V(:,i) = VC(:,i) + D(i,i) = DH_eig(i) + enddo + deallocate(H_eigv,H_eig,DH_eig,VC) + return + ! + 200 format(25h ALBEIGS: outer iteration,i4,12h residuals=,1p,10e12.4/(41x,10e12.4)) + + contains + function tcg(ac) result(bc) + ! function emulating complex conjugate transpose in Matlab + complex(kind=8), dimension(:,:), intent(in) :: ac + complex(kind=8), dimension(size(ac,2),size(ac,1)) :: bc + bc(:,:)=transpose(conjg(ac(:,:))) + end function tcg + function findlc(iset,itest) result(ii) + ! function emulating the findloc function in Fortran 2008 + integer, dimension(:), intent(in) :: iset + integer, intent(in) :: itest + integer :: ii + ii=0 + do j=1,size(iset) + if(iset(j) == itest) then + ii=j + exit + endif + enddo + end function findlc +end subroutine ALBEIGS diff --git a/Trivac/src/BIVA01.f b/Trivac/src/BIVA01.f new file mode 100755 index 0000000..78b4818 --- /dev/null +++ b/Trivac/src/BIVA01.f @@ -0,0 +1,195 @@ +*DECK BIVA01 + SUBROUTINE BIVA01(ITY,MAXKN,SGD,CYLIND,NREG,LL4,NBMIX,IIMAX,XX, + 1 YY,DD,MAT,KN,QFR,VOL,MU,LC,R,RS,Q,QS,SYS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Assembly of a within-group (leakage and removal) or out-of-group +* system matrix in mesh corner finite difference or finite element +* diffusion approximation (Cartesian geometry). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* ITY type of assembly: =0: leakage-removal matrix assembly; +* =1: cross section matrix assembly. +* MAXKN dimension of array KN. +* SGD nuclear properties. SGD(:,1) and SGD(:,2) are diffusion +* coefficients. SGD(:,3) are removal macroscopic cross sections. +* CYLIND cylinderization flag (=.true. for cylindrical geometry). +* NREG number of elements in BIVAC. +* LL4 order of matrix SYS. +* NBMIX number of macro-mixtures. +* IIMAX allocated dimension of array SYS. +* XX X-directed mesh spacings. +* YY Y-directed mesh spacings. +* DD value used with a cylindrical geometry. +* MAT mixture index per region. +* KN element-ordered unknown list. +* QFR element-ordered boundary conditions. +* VOL volume of regions. +* MU indices used with compressed diagonal storage mode matrix SYS. +* LC number of polynomials in a complete 1-D basis. +* R Cartesian mass matrix. +* RS cylindrical mass matrix. +* Q Cartesian stiffness matrix. +* QS cylindrical stiffness matrix. +* +*Parameters: output +* SYS system matrix. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER ITY,MAXKN,NREG,LL4,NBMIX,IIMAX,MAT(NREG),KN(MAXKN), + 1 MU(LL4),LC + REAL SGD(NBMIX,3),XX(NREG),YY(NREG),DD(NREG),QFR(4*NREG), + 1 VOL(NREG),R(LC,LC),RS(LC,LC),Q(LC,LC),QS(LC,LC),SYS(IIMAX) + LOGICAL CYLIND +*---- +* LOCAL VARIABLES +*---- + INTEGER IJ1(25),IJ2(25),ISR(4,5) + REAL Q2DP1(25,25),Q2DP2(25,25),R2DP(25,25),Q2DC1(25,25), + 1 Q2DC2(25,25),R2DC(25,25) +*---- +* COMPUTE VECTORS IJ1, IJ2 AND MATRIX ISR. +*---- + LL=LC*LC + DO 10 I=1,LL + IJ1(I)=1+MOD(I-1,LC) + IJ2(I)=1+(I-IJ1(I))/LC + 10 CONTINUE + DO 20 I=1,LC + ISR(1,I)=(I-1)*LC+1 + ISR(2,I)=I*LC + ISR(3,I)=I + ISR(4,I)=LL-LC+I + 20 CONTINUE +*---- +* COMPUTE THE CARTESIAN 2-D MASS AND STIFFNESS MATRICES FROM TENSORIAL +* PRODUCTS OF 1-D MATRICES. +*---- + DO 40 I=1,LL + I1=IJ1(I) + I2=IJ2(I) + DO 30 J=1,LL + J1=IJ1(J) + J2=IJ2(J) + Q2DP1(I,J)=Q(I1,J1)*R(I2,J2) + Q2DP2(I,J)=R(I1,J1)*Q(I2,J2) + R2DP(I,J)=R(I1,J1)*R(I2,J2) + Q2DC1(I,J)=QS(I1,J1)*R(I2,J2) + Q2DC2(I,J)=RS(I1,J1)*Q(I2,J2) + R2DC(I,J)=RS(I1,J1)*R(I2,J2) + 30 CONTINUE + 40 CONTINUE +*---- +* ASSEMBLY OF A SYSTEM MATRIX. +*---- + IF(ITY.EQ.0) THEN +* LEAKAGE-REMOVAL SYSTEM MATRIX ASSEMBLY. + NUM1=0 + NUM2=0 + DO 110 K=1,NREG + L=MAT(K) + IF(L.EQ.0) GO TO 110 + IF(VOL(K).EQ.0.0) GO TO 100 + DX=XX(K) + DY=YY(K) + DO 60 I=1,LL + IND1=KN(NUM1+I) + IF(IND1.EQ.0) GO TO 60 + KEY1=MU(IND1)-IND1 + DO 50 J=1,LL + IND2=KN(NUM1+J) + IF((IND2.EQ.0).OR.(IND2.GT.IND1)) GO TO 50 + IF(CYLIND) THEN + QQX=(Q2DP1(I,J)+Q2DC1(I,J)*DX/DD(K))/(DX*DX) + QQY=(Q2DP2(I,J)+Q2DC2(I,J)*DX/DD(K))/(DY*DY) + RR=R2DP(I,J)+R2DC(I,J)*DX/DD(K) + ELSE + QQX=Q2DP1(I,J)/(DX*DX) + QQY=Q2DP2(I,J)/(DY*DY) + RR=R2DP(I,J) + ENDIF + IF((QQX.EQ.0.0).AND.(QQY.EQ.0.0).AND.(RR.EQ.0.0)) GO TO 50 + KEY=KEY1+IND2 + SYS(KEY)=SYS(KEY)+(QQX*SGD(L,1)+QQY*SGD(L,2)+RR*SGD(L,3)) + 1 *VOL(K) + 50 CONTINUE + 60 CONTINUE + DO 90 IC=1,4 + QFR1=QFR(NUM2+IC) + IF(QFR1.EQ.0.0) GO TO 90 + DO 80 I1=1,LC + IND1=KN(NUM1+ISR(IC,I1)) + IF(IND1.EQ.0) GO TO 80 + KEY1=MU(IND1)-IND1 + DO 70 J1=1,LC + IND2=KN(NUM1+ISR(IC,J1)) + IF((IND2.EQ.0).OR.(IND2.GT.IND1)) GO TO 70 + IF(CYLIND) THEN + CRZ=0.0 + IF(IC.EQ.1) THEN + CRZ=-0.5*R(I1,J1) + ELSE IF(IC.EQ.2) THEN + CRZ=0.5*R(I1,J1) + ELSE IF(IC.EQ.3) THEN + CRZ=RS(I1,J1) + ELSE IF(IC.EQ.4) THEN + CRZ=RS(I1,J1) + ENDIF + RR=R(I1,J1)+CRZ*DX/DD(K) + ELSE + RR=R(I1,J1) + ENDIF + IF(RR.EQ.0.0) GO TO 70 + KEY=KEY1+IND2 + SYS(KEY)=SYS(KEY)+RR*QFR1 + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + 100 NUM1=NUM1+LL + NUM2=NUM2+4 + 110 CONTINUE + ELSE +* CROSS SECTION SYSTEM MATRIX ASSEMBLY. + NUM1=0 + DO 150 K=1,NREG + L=MAT(K) + IF(L.EQ.0) GO TO 150 + IF(VOL(K).EQ.0.0) GO TO 140 + DX=XX(K) + DO 130 I=1,LL + IND1=KN(NUM1+I) + IF(IND1.EQ.0) GO TO 130 + KEY1=MU(IND1)-IND1 + DO 120 J=1,LL + IND2=KN(NUM1+J) + IF((IND2.EQ.0).OR.(IND2.GT.IND1)) GO TO 120 + IF(CYLIND) THEN + RR=R2DP(I,J)+R2DC(I,J)*DX/DD(K) + ELSE + RR=R2DP(I,J) + ENDIF + IF(RR.EQ.0.0) GO TO 120 + KEY=KEY1+IND2 + SYS(KEY)=SYS(KEY)+RR*SGD(L,1)*VOL(K) + 120 CONTINUE + 130 CONTINUE + 140 NUM1=NUM1+LL + 150 CONTINUE + ENDIF + RETURN + END diff --git a/Trivac/src/BIVA02.f b/Trivac/src/BIVA02.f new file mode 100755 index 0000000..da999ea --- /dev/null +++ b/Trivac/src/BIVA02.f @@ -0,0 +1,210 @@ +*DECK BIVA02 + SUBROUTINE BIVA02(ITY,SGD,CYLIND,IELEM,ICOL,NREG,LL4,NBMIX,IIMAX, + 1 XX,YY,DD,MAT,KN,QFR,VOL,MU,LC,R,V,SYS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Assembly of a within-group (leakage and removal) or out-of-group +* system matrix in mixed-dual finite element diffusion approximation +* (Cartesian geometry). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* ITY type of assembly: =0: leakage-removal matrix assembly; +* =1: cross section matrix assembly. +* SGD nuclear properties. SGD(:,1) and SGD(:,2) are diffusion +* coefficients. SGD(:,3) are removal macroscopic cross sections. +* CYLIND cylinderization flag (=.true. for cylindrical geometry). +* IELEM degree of the Lagrangian finite elements: =1 (linear); +* =2 (parabolic); =3 (cubic); =4 (quartic). +* ICOL type of quadrature: =1 (analytical integration); +* =2 (Gauss-Lobatto); =3 (Gauss-Legendre). +* NREG number of elements in BIVAC. +* LL4 number of unknowns per group in BIVAC. +* NBMIX number of macro-mixtures. +* IIMAX allocated dimension of array SYS. +* XX X-directed mesh spacings. +* YY Y-directed mesh spacings. +* DD value used used with a cylindrical geometry. +* MAT mixture index per region. +* KN element-ordered unknown list. +* QFR element-ordered boundary conditions. +* VOL volume of regions. +* MU indices used with compressed diagonal storage mode matrix SYS. +* LC number of polynomials in a complete 1-D basis. +* R cartesian mass matrix. +* V nodal coupling matrix. +* +*Parameters: output +* SYS system matrix. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER ITY,IELEM,ICOL,NREG,LL4,NBMIX,IIMAX,MAT(NREG),KN(5*NREG), + 1 MU(LL4),LC + REAL SGD(NBMIX,3),XX(NREG),YY(NREG),DD(NREG),QFR(4*NREG), + 1 VOL(NREG),R(LC,LC),V(LC,LC-1),SYS(IIMAX) + LOGICAL CYLIND +*---- +* LOCAL VARIABLES +*---- + REAL QQ(5,5) +* + IF((CYLIND).AND.((IELEM.GT.1).OR.(ICOL.NE.2))) + 1 CALL XABORT('BIVA02: TYPE OF DISCRETIZATION NOT IMPLEMENTED.') +*---- +* ASSEMBLY OF A SYSTEM MATRIX. +*---- + IF(ITY.EQ.0) THEN +* LEAKAGE-REMOVAL SYSTEM MATRIX ASSEMBLY. + DO 12 I0=1,IELEM + DO 11 J0=1,IELEM + QQ(I0,J0)=0.0 + DO 10 K0=2,IELEM + QQ(I0,J0)=QQ(I0,J0)+V(K0,I0)*V(K0,J0)/R(K0,K0) + 10 CONTINUE + 11 CONTINUE + 12 CONTINUE + NUM1=0 + NUM2=0 + DO 80 K=1,NREG + L=MAT(K) + IF(L.EQ.0) GO TO 80 + VOL0=VOL(K) + IF(VOL0.EQ.0.0) GO TO 70 + DX=XX(K) + DY=YY(K) + IF(CYLIND) THEN + DIN=1.0-0.5*DX/DD(K) + DOT=1.0+0.5*DX/DD(K) + ELSE + DIN=1.0 + DOT=1.0 + ENDIF +* + DO 60 I0=1,IELEM + INX1=ABS(KN(NUM1+2))+I0-1 + INX2=ABS(KN(NUM1+3))+I0-1 + INY1=ABS(KN(NUM1+4))+I0-1 + INY2=ABS(KN(NUM1+5))+I0-1 + DO 50 J0=1,IELEM + JND1=KN(NUM1+1)+(I0-1)*IELEM+J0-1 + KEY=MU(JND1) + SYS(KEY)=SYS(KEY)+VOL0*SGD(L,3) + DO 20 K0=1,J0 + IF(QQ(J0,K0).EQ.0.0) GO TO 20 + KND1=KN(NUM1+1)+(I0-1)*IELEM+K0-1 + KEY=MU(JND1)-JND1+KND1 + SYS(KEY)=SYS(KEY)+VOL0*QQ(J0,K0)*SGD(L,1)/(DX*DX) + 20 CONTINUE + IF(KN(NUM1+2).NE.0) THEN + IF(JND1.GT.INX1) KEY=MU(JND1)-JND1+INX1 + IF(JND1.LT.INX1) KEY=MU(INX1)-INX1+JND1 + SG=REAL(SIGN(1,KN(NUM1+2))) + SYS(KEY)=SYS(KEY)+SG*(VOL0/DX)*DIN*V(1,J0) + ENDIF + IF(KN(NUM1+3).NE.0) THEN + IF(INX2.GT.JND1) KEY=MU(INX2)-INX2+JND1 + IF(INX2.LT.JND1) KEY=MU(JND1)-JND1+INX2 + SG=REAL(SIGN(1,KN(NUM1+3))) + SYS(KEY)=SYS(KEY)+SG*(VOL0/DX)*DOT*V(IELEM+1,J0) + ENDIF + JND1=KN(NUM1+1)+(J0-1)*IELEM+I0-1 + DO 30 K0=1,J0 + IF(QQ(J0,K0).EQ.0.0) GO TO 30 + KND1=KN(NUM1+1)+(K0-1)*IELEM+I0-1 + KEY=MU(JND1)-JND1+KND1 + SYS(KEY)=SYS(KEY)+VOL0*QQ(J0,K0)*SGD(L,2)/(DY*DY) + 30 CONTINUE + IF(KN(NUM1+4).NE.0) THEN + IF(JND1.GT.INY1) KEY=MU(JND1)-JND1+INY1 + IF(JND1.LT.INY1) KEY=MU(INY1)-INY1+JND1 + SG=REAL(SIGN(1,KN(NUM1+4))) + SYS(KEY)=SYS(KEY)+SG*(VOL0/DY)*V(1,J0) + ENDIF + IF(KN(NUM1+5).NE.0) THEN + IF(INY2.GT.JND1) KEY=MU(INY2)-INY2+JND1 + IF(INY2.LT.JND1) KEY=MU(JND1)-JND1+INY2 + SG=REAL(SIGN(1,KN(NUM1+5))) + SYS(KEY)=SYS(KEY)+SG*(VOL0/DY)*V(IELEM+1,J0) + ENDIF + 50 CONTINUE + IF(KN(NUM1+2).NE.0) THEN + KEY=MU(INX1) + SYS(KEY)=SYS(KEY)-DIN*(VOL0*R(1,1)/SGD(L,1)+QFR(NUM2+1)) + ENDIF + IF(KN(NUM1+3).NE.0) THEN + KEY=MU(INX2) + SYS(KEY)=SYS(KEY)-DOT*(VOL0*R(IELEM+1,IELEM+1)/SGD(L,1) + 1 +QFR(NUM2+2)) + ENDIF + IF(KN(NUM1+4).NE.0) THEN + KEY=MU(INY1) + SYS(KEY)=SYS(KEY)-VOL0*R(1,1)/SGD(L,2)-QFR(NUM2+3) + ENDIF + IF(KN(NUM1+5).NE.0) THEN + KEY=MU(INY2) + SYS(KEY)=SYS(KEY)-VOL0*R(IELEM+1,IELEM+1)/SGD(L,2) + 1 -QFR(NUM2+4) + ENDIF + IF(ICOL.NE.2) THEN + IF((KN(NUM1+2).NE.0).AND.(KN(NUM1+3).NE.0)) THEN + IF(INX2.GT.INX1) KEY=MU(INX2)-INX2+INX1 + IF(INX2.LE.INX1) KEY=MU(INX1)-INX1+INX2 + SG=REAL(SIGN(1,KN(NUM1+2))*SIGN(1,KN(NUM1+3))) + IF(INX1.EQ.INX2) SG=2.0*SG + SYS(KEY)=SYS(KEY)-SG*VOL0*R(IELEM+1,1)/SGD(L,1) + ENDIF + IF((KN(NUM1+4).NE.0).AND.(KN(NUM1+5).NE.0)) THEN + IF(INY2.GT.INY1) KEY=MU(INY2)-INY2+INY1 + IF(INY2.LE.INY1) KEY=MU(INY1)-INY1+INY2 + SG=REAL(SIGN(1,KN(NUM1+4))*SIGN(1,KN(NUM1+5))) + IF(INY1.EQ.INY2) SG=2.0*SG + SYS(KEY)=SYS(KEY)-SG*VOL0*R(IELEM+1,1)/SGD(L,2) + ENDIF + ENDIF + 60 CONTINUE + 70 NUM1=NUM1+5 + NUM2=NUM2+4 + 80 CONTINUE + ELSE +* CROSS SECTION SYSTEM MATRIX ASSEMBLY. COMPONENTS WITH 1E-10 +* FACTORS ARE INTRODUCED TO MAKE THE MATRIX INVERTIBLE. + NUM1=0 + DO 110 K=1,NREG + L=MAT(K) + IF(L.EQ.0) GO TO 110 + VOL0=VOL(K) + IF(VOL0.EQ.0.0) GO TO 100 + DO 95 I0=1,IELEM + INX1=ABS(KN(NUM1+2))+I0-1 + INX2=ABS(KN(NUM1+3))+I0-1 + INY1=ABS(KN(NUM1+4))+I0-1 + INY2=ABS(KN(NUM1+5))+I0-1 + IF(KN(NUM1+2).NE.0) SYS(MU(INX1))=SYS(MU(INX1))+1.0E-30 + IF(KN(NUM1+3).NE.0) SYS(MU(INX2))=SYS(MU(INX2))+1.0E-30 + IF(KN(NUM1+4).NE.0) SYS(MU(INY1))=SYS(MU(INY1))+1.0E-30 + IF(KN(NUM1+5).NE.0) SYS(MU(INY2))=SYS(MU(INY2))+1.0E-30 + DO 90 J0=1,IELEM + JND1=KN(NUM1+1)+(I0-1)*IELEM+J0-1 + KEY=MU(JND1) + SYS(KEY)=SYS(KEY)+VOL0*SGD(L,1) + 90 CONTINUE + 95 CONTINUE + 100 NUM1=NUM1+5 + 110 CONTINUE + ENDIF + RETURN + END diff --git a/Trivac/src/BIVA03.f b/Trivac/src/BIVA03.f new file mode 100755 index 0000000..f9c3f71 --- /dev/null +++ b/Trivac/src/BIVA03.f @@ -0,0 +1,176 @@ +*DECK BIVA03 + SUBROUTINE BIVA03(ITY,MAXKN,MAXQF,SGD,NREG,LL4,ISPLH,NELEM,NBMIX, + 1 IIMAX,SIDE,MAT,KN,QFR,VOL,MU,R,RH,QH,RT,QT,SYS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Assembly of a within-group (leakage and removal) or out-of-group +* system matrix in mesh-corner finite-difference diffusion +* approximation (hexagonal geometry). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* ITY type of assembly: =0: leakage-removal matrix assembly; +* =1: cross section matrix assembly. +* MAXKN dimension of array KN. +* MAXQF dimension of array QFR. +* SGD nuclear properties. SGD(:,1) and SGD(:,2) are diffusion +* coefficients. SGD(:,3) are removal macroscopic cross sections. +* NREG number of hexagons in BIVAC. +* LL4 order of the matrix SYS. +* ISPLH hexagonal geometry flag: +* =1: hexagonal elements; >1: triangular elements. +* NELEM number of finite elements (hexagons or triangles) excluding +* the virtual elements. +* NBMIX number of macro-mixtures. +* IIMAX allocated dimension of array SYS. +* SIDE side of the hexagons. +* MAT mixture index per hexagon. +* KN element-ordered unknown list. +* QFR element-ordered information. +* VOL volume of the hexagons. +* MU indices used with the compressed diagonal storage mode matrix +* SYS. +* R unit matrix. +* RH unit matrix. +* QH unit matrix. +* RT unit matrix. +* QT unit matrix. +* +*Parameters: output +* SYS system matrix. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER ITY,MAXKN,MAXQF,NREG,LL4,ISPLH,NELEM,NBMIX,IIMAX, + 1 MAT(NREG),KN(MAXKN),MU(LL4) + REAL SGD(NBMIX,3),SIDE,QFR(MAXQF),VOL(NREG),R(2,2),RH(6,6), + 1 QH(6,6),RT(3,3),QT(3,3),SYS(IIMAX) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION RR,RRH,QQH + INTEGER ISR(6,2),ISRH(6,2),ISRT(3,2) + REAL RH2(6,6),QH2(6,6) + DATA ISRH/2,1,4,5,6,3,1,4,5,6,3,2/ + DATA ISRT/1,2,3,2,3,1/ +*---- +* RECOVER THE HEXAGONAL MASS (RH2) AND STIFFNESS (QH2) MATRICES. +*---- + IF(ISPLH.EQ.1) THEN +* HEXAGONAL BASIS. + LH=6 + DO 15 I=1,6 + DO 10 J=1,2 + ISR(I,J)=ISRH(I,J) + 10 CONTINUE + 15 CONTINUE + DO 25 I=1,6 + DO 20 J=1,6 + RH2(I,J)=RH(I,J) + QH2(I,J)=QH(I,J) + 20 CONTINUE + 25 CONTINUE + CONST=1.5*SQRT(3.0) + CONSB=2.0*SQRT(3.0)/3.0 + AA=SIDE + ELSE +* TRIANGULAR BASIS. + LH=3 + DO 35 I=1,3 + DO 30 J=1,2 + ISR(I,J)=ISRT(I,J) + 30 CONTINUE + 35 CONTINUE + DO 45 I=1,3 + DO 40 J=1,3 + RH2(I,J)=RT(I,J) + QH2(I,J)=QT(I,J) + 40 CONTINUE + 45 CONTINUE + CONST=0.25*SQRT(3.0) + CONSB=2.0*SQRT(3.0) + AA=SIDE/REAL(ISPLH-1) + ENDIF +*---- +* ASSEMBLY OF A SYSTEM MATRIX. +*---- + IF(ITY.EQ.0) THEN +* LEAKAGE-REMOVAL SYSTEM MATRIX ASSEMBLY. + NUM1=0 + DO 105 K=1,NELEM + KHEX=KN(NUM1+LH+1) + IF(VOL(KHEX).EQ.0.0) GO TO 100 + L=MAT(KHEX) + VOL0=QFR(NUM1+LH+1) + DO 60 I=1,LH + IND1=KN(NUM1+I) + IF(IND1.EQ.0) GO TO 60 + KEY1=MU(IND1)-IND1 + DO 50 J=1,LH + IND2=KN(NUM1+J) + IF((IND2.EQ.0).OR.(IND2.GT.IND1)) GO TO 50 + QQH=QH2(I,J)/(CONST*AA*AA) + RRH=RH2(I,J)/CONST + IF((QQH.EQ.0.0).AND.(RRH.EQ.0.0)) GO TO 50 + KEY=KEY1+IND2 + SYS(KEY)=SYS(KEY)+REAL(QQH*SGD(L,1)+RRH*SGD(L,3))*VOL0 + 50 CONTINUE + 60 CONTINUE + DO 90 IC=1,LH + QFR1=QFR(NUM1+IC) + IF(QFR1.EQ.0.0) GO TO 90 + DO 80 I1=1,2 + IND1=KN(NUM1+ISR(IC,I1)) + IF(IND1.EQ.0) GO TO 80 + KEY1=MU(IND1)-IND1 + DO 70 J1=1,2 + IND2=KN(NUM1+ISR(IC,J1)) + IF((IND2.EQ.0).OR.(IND2.GT.IND1)) GO TO 70 + RR=R(I1,J1) + IF(RR.EQ.0.0) GO TO 70 + KEY=KEY1+IND2 + SYS(KEY)=SYS(KEY)+REAL(RR)*QFR1 + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + 100 NUM1=NUM1+LH+1 + 105 CONTINUE + ELSE +* CROSS SECTION SYSTEM MATRIX ASSEMBLY + NUM1=0 + DO 135 K=1,NELEM + KHEX=KN(NUM1+LH+1) + IF(VOL(KHEX).EQ.0.0) GO TO 130 + L=MAT(KHEX) + VOL0=QFR(NUM1+LH+1) + DO 120 I=1,LH + IND1=KN(NUM1+I) + IF(IND1.EQ.0) GO TO 120 + KEY1=MU(IND1)-IND1 + DO 110 J=1,LH + IND2=KN(NUM1+J) + IF((IND2.EQ.0).OR.(IND2.GT.IND1)) GO TO 110 + RRH=RH2(I,J)/CONST + IF(RRH.EQ.0.0) GO TO 110 + KEY=KEY1+IND2 + SYS(KEY)=SYS(KEY)+REAL(RRH)*SGD(L,1)*VOL0 + 110 CONTINUE + 120 CONTINUE + 130 NUM1=NUM1+LH+1 + 135 CONTINUE + ENDIF + RETURN + END diff --git a/Trivac/src/BIVA04.f b/Trivac/src/BIVA04.f new file mode 100755 index 0000000..d80182a --- /dev/null +++ b/Trivac/src/BIVA04.f @@ -0,0 +1,122 @@ +*DECK BIVA04 + SUBROUTINE BIVA04(ITY,MAXKN,MAXQF,SGD,NREG,LL4,ISPLH,NBMIX,IIMAX, + 1 SIDE,MAT,KN,QFR,VOL,MU,SYS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Assembly of a within-group (leakage and removal) or out-of-group +* system matrix in mesh-centered finite-difference diffusion +* approximation (hexagonal geometry). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* ITY type of assembly: =0: leakage-removal matrix assembly; +* =1: cross section matrix assembly. +* MAXKN dimension of array KN. +* MAXQF dimension of array QFR. +* SGD nuclear properties. SGD(:,1) and SGD(:,2) are diffusion +* coefficients. SGD(:,3) are removal macroscopic cross sections. +* NREG number of hexagons in BIVAC. +* LL4 number of unknowns per group in BIVAC. Equal to the number +* of finite elements (hexagons or triangles) excluding the +* virtual elements. +* ISPLH type of hexagonal mesh-splitting: +* =1: hexagonal elements; >1: triangular elements. +* NBMIX number of macro-mixtures. +* IIMAX allocated dimension of array SYS. +* SIDE side of the hexagons. +* MAT mixture index per hexagon. +* KN element-ordered unknown list. +* QFR element-ordered information. +* VOL volume of hexagons. +* MU indices used with the compressed diagonal storage mode matrix +* SYS. +* +*Parameters: output +* SYS system matrix. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER ITY,MAXKN,MAXQF,NREG,LL4,ISPLH,NBMIX,IIMAX,MAT(NREG), + 1 KN(MAXKN),MU(LL4) + REAL SGD(NBMIX,3),SIDE,QFR(MAXQF),VOL(NREG),SYS(IIMAX) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION A1,DHARM,VAR1 + DHARM(X1,X2,DIF1,DIF2)=2.0D0*DIF1*DIF2/(X1*DIF2+X2*DIF1) +* + IF(ISPLH.EQ.1) THEN + DS=SQRT(3.0)*SIDE + FACT=2.0/(3.0*DS) + NSURF=6 + ELSE + DS=SIDE/(SQRT(3.0)*REAL(ISPLH-1)) + FACT=4.0/(3.0*DS) + NSURF=3 + ENDIF +*---- +* ASSEMBLY OF A SYSTEM MATRIX. +*---- + IF(ITY.EQ.0) THEN +* LEAKAGE-REMOVAL SYSTEM MATRIX ASSEMBLY. + NUM1=0 + DO 35 IND1=1,LL4 + KHEX=KN(NUM1+NSURF+1) + IF(VOL(KHEX).EQ.0.0) GO TO 30 + L=MAT(KHEX) + VOL0=QFR(NUM1+NSURF+1) + SIDEB=FACT*VOL0 + VAR1=0.0D0 + KEY0=MU(IND1)-IND1 + DO 20 IX=1,NSURF + IND2=KN(NUM1+IX) + A1=0.0 + IF(IND2.GT.0) THEN + LL=MAT(KN(IND2*(NSURF+1))) + A1=DHARM(DS,DS,SGD(L,1),SGD(LL,1))*SIDEB + ELSE IF(IND2.EQ.-1) THEN + A1=DHARM(DS,DS,SGD(L,1),DS*QFR(NUM1+IX)/2.0)*SIDEB + ELSE IF(IND2.EQ.-2) THEN + A1=0.0D0 + ELSE IF(IND2.EQ.-3) THEN + A1=2.0D0*DHARM(DS,DS,SGD(L,1),SGD(L,1))*SIDEB + ENDIF + VAR1=VAR1+A1 + IF(IND2.GT.0) THEN + IF(IND2.LT.IND1) THEN + KEY=KEY0+IND2 + SYS(KEY)=SYS(KEY)-REAL(A1) + ENDIF + ENDIF + 20 CONTINUE + KEY=KEY0+IND1 + SYS(KEY)=SYS(KEY)+REAL(VAR1)+SGD(L,3)*VOL0 + 30 NUM1=NUM1+NSURF+1 + 35 CONTINUE + ELSE +* CROSS SECTION SYSTEM MATRIX ASSEMBLY. + NUM1=0 + DO 45 IND1=1,LL4 + KHEX=KN(NUM1+NSURF+1) + IF(VOL(KHEX).EQ.0.0) GO TO 40 + L=MAT(KHEX) + KEY=MU(IND1) + SYS(KEY)=SYS(KEY)+SGD(L,1)*QFR(NUM1+NSURF+1) + 40 NUM1=NUM1+NSURF+1 + 45 CONTINUE + ENDIF + RETURN + END diff --git a/Trivac/src/BIVA05.f b/Trivac/src/BIVA05.f new file mode 100755 index 0000000..41997f9 --- /dev/null +++ b/Trivac/src/BIVA05.f @@ -0,0 +1,266 @@ +*DECK BIVA05 + SUBROUTINE BIVA05(ITY,SGD,IELEM,NBLOS,LL4,NBMIX,IIMAX,SIDE,MAT, + 1 IPERT,KN,QFR,MU,LC,R,V,H,SYS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Assembly of a within-group (leakage and removal) or out-of-group +* system matrix in a Thomas-Raviart-Schneider (dual) finite element +* diffusion approximation (hexagonal geometry). +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* ITY type of assembly: =0: leakage-removal matrix assembly; +* =1: cross section matrix assembly. +* SGD nuclear properties. SGD(:,1) and SGD(:,2) are diffusion +* coefficients. SGD(:,3) are removal macroscopic cross sections. +* IELEM degree of the Lagrangian finite elements: =1 (linear); +* =2 (parabolic); =3 (cubic); =4 (quartic). +* NBLOS number of lozenges per direction, taking into account +* mesh-splitting. +* LL4 number of unknowns per group in BIVAC. +* NBMIX number of macro-mixtures. +* IIMAX allocated dimension of array SYS. +* SIDE side of the hexagons. +* MAT mixture index per lozenge. +* IPERT mixture permutation index. +* KN element-ordered unknown list. +* QFR element-ordered boundary conditions. +* MU indices used with compressed diagonal storage mode matrix SYS. +* LC order of the unit matrices. +* R Cartesian mass matrix. +* V nodal coupling matrix. +* H Piolat (hexagonal) coupling matrix. +* +*Parameters: output +* SYS system matrix. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER ITY,IELEM,NBLOS,LL4,NBMIX,IIMAX,MAT(3,NBLOS),IPERT(NBLOS), + 1 KN(NBLOS,4+6*IELEM*(IELEM+1)),MU(LL4),LC + REAL SGD(NBMIX,3),SIDE,QFR(NBLOS,6),R(LC,LC),V(LC,LC-1), + 1 H(LC,LC-1),SYS(IIMAX) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(MAXIEL=3) + DOUBLE PRECISION CTRAN(MAXIEL*(MAXIEL+1),MAXIEL*(MAXIEL+1)) +*---- +* ASSEMBLY OF A SYSTEM MATRIX. +*---- + TTTT=0.5*SQRT(3.0)*SIDE*SIDE + IF(IELEM.GT.MAXIEL) CALL XABORT('BIVA05: MAXIEL OVERFLOW.') + IF(ITY.EQ.0) THEN +* COMPUTE THE TRANVERSE COUPLING PIOLAT UNIT MATRIX + CTRAN(:MAXIEL*(MAXIEL+1),:MAXIEL*(MAXIEL+1))=0.0D0 + CNORM=SIDE*SIDE/SQRT(3.0) + I=0 + DO 22 JS=1,IELEM + DO 21 JT=1,IELEM+1 + J=0 + I=I+1 + SSS=1.0 + DO 20 IT=1,IELEM + DO 10 IS=1,IELEM+1 + J=J+1 + CTRAN(I,J)=SSS*CNORM*H(IS,JS)*H(JT,IT) + 10 CONTINUE + SSS=-SSS + 20 CONTINUE + 21 CONTINUE + 22 CONTINUE +* +* LEAKAGE-REMOVAL SYSTEM MATRIX ASSEMBLY + NELEM=IELEM*(IELEM+1) + COEF=2.0*SIDE*SIDE/SQRT(3.0) + NUM=0 + DO 70 KEL=1,NBLOS + IF(IPERT(KEL).EQ.0) GO TO 70 + IBM=MAT(1,IPERT(KEL)) + IF(IBM.EQ.0) GO TO 70 + NUM=NUM+1 + DINV=1.0/SGD(IBM,1) + SIG=SGD(IBM,3) + DO 43 K4=0,1 + DO 42 K3=0,IELEM-1 + DO 41 K2=1,IELEM+1 + KNW1=KN(NUM,4+K4*NELEM+K3*(IELEM+1)+K2) + KNX1=KN(NUM,4+(K4+2)*NELEM+K3*(IELEM+1)+K2) + KNY1=KN(NUM,4+(K4+4)*NELEM+K3*(IELEM+1)+K2) + INW1=ABS(KNW1) + INX1=ABS(KNX1) + INY1=ABS(KNY1) + DO 30 K1=1,IELEM+1 + KNW2=KN(NUM,4+K4*NELEM+K3*(IELEM+1)+K1) + KNX2=KN(NUM,4+(K4+2)*NELEM+K3*(IELEM+1)+K1) + KNY2=KN(NUM,4+(K4+4)*NELEM+K3*(IELEM+1)+K1) + INW2=ABS(KNW2) + INX2=ABS(KNX2) + INY2=ABS(KNY2) + IF((KNW2.NE.0).AND.(KNW1.NE.0).AND.(INW1.GE.INW2)) THEN + L=MU(INW1)-INW1+INW2 + SG=REAL(SIGN(1,KNW1)*SIGN(1,KNW2)) + SYS(L)=SYS(L)-SG*COEF*DINV*R(K2,K1) + IF(INW1.EQ.INW2) THEN + IF((K1.EQ.1).AND.(K4.EQ.0)) SYS(L)=SYS(L)-QFR(NUM,1) + IF((K1.EQ.IELEM+1).AND.(K4.EQ.1)) SYS(L)=SYS(L)-QFR(NUM,2) + ENDIF + ENDIF + IF((KNX2.NE.0).AND.(KNX1.NE.0).AND.(INX1.GE.INX2)) THEN + L=MU(INX1)-INX1+INX2 + SG=REAL(SIGN(1,KNX1)*SIGN(1,KNX2)) + SYS(L)=SYS(L)-SG*COEF*DINV*R(K2,K1) + IF(INX1.EQ.INX2) THEN + IF((K1.EQ.1).AND.(K4.EQ.0)) SYS(L)=SYS(L)-QFR(NUM,3) + IF((K1.EQ.IELEM+1).AND.(K4.EQ.1)) SYS(L)=SYS(L)-QFR(NUM,4) + ENDIF + ENDIF + IF((KNY2.NE.0).AND.(KNY1.NE.0).AND.(INY1.GE.INY2)) THEN + L=MU(INY1)-INY1+INY2 + SG=REAL(SIGN(1,KNY1)*SIGN(1,KNY2)) + SYS(L)=SYS(L)-SG*COEF*DINV*R(K2,K1) + IF(INY1.EQ.INY2) THEN + IF((K1.EQ.1).AND.(K4.EQ.0)) SYS(L)=SYS(L)-QFR(NUM,5) + IF((K1.EQ.IELEM+1).AND.(K4.EQ.1)) SYS(L)=SYS(L)-QFR(NUM,6) + ENDIF + ENDIF + 30 CONTINUE + DO 40 K1=0,IELEM-1 + IF(V(K2,K1+1).EQ.0.0) GO TO 40 + IF(K4.EQ.0) THEN + SSS=(-1.0)**K1 + JND1=KN(NUM,1)+K3*IELEM+K1 + JND2=KN(NUM,2)+K3*IELEM+K1 + JND3=KN(NUM,3)+K3*IELEM+K1 + ELSE + SSS=1.0 + JND1=KN(NUM,2)+K1*IELEM+K3 + JND2=KN(NUM,3)+K1*IELEM+K3 + JND3=KN(NUM,4)+K1*IELEM+K3 + ENDIF + IF(KNW1.NE.0) THEN + L=MU(JND1)-JND1+INW1 + IF(JND1.LT.INW1) L=MU(INW1)-INW1+JND1 + SG=REAL(SIGN(1,KNW1)) + SYS(L)=SYS(L)+SG*SSS*SIDE*V(K2,K1+1) + ENDIF + IF(KNX1.NE.0) THEN + L=MU(JND2)-JND2+INX1 + IF(JND2.LT.INX1) L=MU(INX1)-INX1+JND2 + SG=REAL(SIGN(1,KNX1)) + SYS(L)=SYS(L)+SG*SSS*SIDE*V(K2,K1+1) + ENDIF + IF(KNY1.NE.0) THEN + L=MU(JND3)-JND3+INY1 + IF(JND3.LT.INY1) L=MU(INY1)-INY1+JND3 + SG=REAL(SIGN(1,KNY1)) + SYS(L)=SYS(L)+SG*SSS*SIDE*V(K2,K1+1) + ENDIF + 40 CONTINUE + 41 CONTINUE + 42 CONTINUE + 43 CONTINUE + ITRS=0 + DO I=1,NBLOS + IF(KN(I,1).EQ.KN(NUM,4)) THEN + ITRS=I + GO TO 45 + ENDIF + ENDDO + CALL XABORT('BIVA05: ITRS FAILURE.') + 45 DO 55 I=1,NELEM + KNW1=KN(ITRS,4+I) + KNX1=KN(NUM,4+2*NELEM+I) + KNY1=KN(NUM,4+4*NELEM+I) + INW1=ABS(KNW1) + INX1=ABS(KNX1) + INY1=ABS(KNY1) + DO 50 J=1,NELEM + KNW2=KN(NUM,4+NELEM+J) + KNX2=KN(NUM,4+3*NELEM+J) + KNY2=KN(NUM,4+5*NELEM+J) + INW2=ABS(KNW2) + INX2=ABS(KNX2) + INY2=ABS(KNY2) + IF((KNY2.NE.0).AND.(KNW1.NE.0).AND.(INW1.LT.INY2)) THEN + L=MU(INY2)-INY2+INW1 + SG=REAL(SIGN(1,KNW1)*SIGN(1,KNY2)) + SYS(L)=SYS(L)-SG*DINV*REAL(CTRAN(I,J)) ! y w + ELSE IF((KNY2.NE.0).AND.(KNW1.NE.0).AND.(INW1.GT.INY2)) THEN + L=MU(INW1)-INW1+INY2 + SG=REAL(SIGN(1,KNW1)*SIGN(1,KNY2)) + SYS(L)=SYS(L)-SG*DINV*REAL(CTRAN(I,J)) ! w y + ENDIF + IF((KNW2.NE.0).AND.(KNX1.NE.0).AND.(INW2.LT.INX1)) THEN + L=MU(INX1)-INX1+INW2 + SG=REAL(SIGN(1,KNX1)*SIGN(1,KNW2)) + SYS(L)=SYS(L)-SG*DINV*REAL(CTRAN(I,J)) ! x w + ELSE IF((KNW2.NE.0).AND.(KNX1.NE.0).AND.(INW2.GT.INX1)) THEN + L=MU(INW2)-INW2+INX1 + SG=REAL(SIGN(1,KNX1)*SIGN(1,KNW2)) + SYS(L)=SYS(L)-SG*DINV*REAL(CTRAN(I,J)) ! w x + ENDIF + IF((KNX2.NE.0).AND.(KNY1.NE.0).AND.(INX2.LT.INY1)) THEN + L=MU(INY1)-INY1+INX2 + SG=REAL(SIGN(1,KNY1)*SIGN(1,KNX2)) + SYS(L)=SYS(L)-SG*DINV*REAL(CTRAN(I,J)) ! y x + ELSE IF((KNX2.NE.0).AND.(KNY1.NE.0).AND.(INX2.GT.INY1)) THEN + L=MU(INX2)-INX2+INY1 + SG=REAL(SIGN(1,KNY1)*SIGN(1,KNX2)) + SYS(L)=SYS(L)-SG*DINV*REAL(CTRAN(I,J)) ! x y + ENDIF + 50 CONTINUE + 55 CONTINUE + DO 65 K2=0,IELEM-1 + DO 60 K1=0,IELEM-1 + JND1=KN(NUM,1)+K2*IELEM+K1 + JND2=KN(NUM,2)+K2*IELEM+K1 + JND3=KN(NUM,3)+K2*IELEM+K1 + L=MU(JND1) + SYS(L)=SYS(L)+TTTT*SIG + L=MU(JND2) + SYS(L)=SYS(L)+TTTT*SIG + L=MU(JND3) + SYS(L)=SYS(L)+TTTT*SIG + 60 CONTINUE + 65 CONTINUE + 70 CONTINUE + ELSE +* CROSS SECTION SYSTEM MATRIX ASSEMBLY + NUM=0 + DO 90 KEL=1,NBLOS + IF(IPERT(KEL).EQ.0) GO TO 90 + IBM=MAT(1,IPERT(KEL)) + IF(IBM.EQ.0) GO TO 90 + NUM=NUM+1 + SIG=SGD(IBM,1) + DO 85 K2=0,IELEM-1 + DO 80 K1=0,IELEM-1 + JND1=KN(NUM,1)+K2*IELEM+K1 + JND2=KN(NUM,2)+K2*IELEM+K1 + JND3=KN(NUM,3)+K2*IELEM+K1 + L=MU(JND1) + SYS(L)=SYS(L)+TTTT*SIG + L=MU(JND2) + SYS(L)=SYS(L)+TTTT*SIG + L=MU(JND3) + SYS(L)=SYS(L)+TTTT*SIG + 80 CONTINUE + 85 CONTINUE + 90 CONTINUE + ENDIF + RETURN + END diff --git a/Trivac/src/BIVACA.f b/Trivac/src/BIVACA.f new file mode 100755 index 0000000..eeb30a2 --- /dev/null +++ b/Trivac/src/BIVACA.f @@ -0,0 +1,212 @@ +*DECK BIVACA + SUBROUTINE BIVACA(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* BIVAC type (2-D) system matrix assembly operator. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1): create or modification type(L_SYSTEM); +* HENTRY(2): read-only type(L_MACROLIB); +* HENTRY(3): read-only type(L_TRACK). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*Comments: +* The BIVACA: calling specifications are: +* SYST := BIVACA: [ SYST} ] MACRO TRACK :: (bivaca\_data) ; +* where +* SYST : name of the \emph{lcm} object (type L\_SYSTEM) containing the +* system matrices. If SYST appears on the RHS, the system matrices +* previously stored in SYST} are kept. +* MACRO : name of the \emph{lcm} object (type L\_MACROLIB) containing the +* macroscopic cross sections and diffusion coefficients. +* TRACK : name of the \emph{lcm} object (type L\_BIVAC) containing the BIVAC +* \emph{tracking}. +* bivaca\_data : structure containing the data to module BIVACA:. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 + TYPE(C_PTR) KENTRY(NENTRY) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + CHARACTER TEXT4*4,HSIGN*12,TEXT12*12,HSMG*131,CNAM*12 + DOUBLE PRECISION DFLOTT + INTEGER IGP(NSTATE),IPAR(NSTATE),IBR(NSTATE) + LOGICAL LDIFF + TYPE(C_PTR) IPSYS,IPMACR,JPMACR,KPMACR,IPTRK + INTEGER, DIMENSION(:), ALLOCATABLE :: MAT + REAL, DIMENSION(:), ALLOCATABLE :: VOL,UN,VII,GAMMA +*---- +* PARAMETER VALIDATION. +*---- + IF(NENTRY.LE.2) CALL XABORT('BIVACA: THREE PARAMETERS EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('BIVACA: L' + 1 //'CM OBJECT EXPECTED AT LHS.') + IF((JENTRY(1).NE.0).AND.(JENTRY(1).NE.1)) CALL XABORT('BIVACA: E' + 1 //'NTRY IN CREATE OR MODIFICATION MODE EXPECTED.') + IF((JENTRY(2).NE.2).OR.((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2))) + 1 CALL XABORT('BIVACA: LCM OBJECT IN READ-ONLY MODE EXPECTED AT S' + 2 //'ECOND RHS.') + IF((JENTRY(3).NE.2).OR.((IENTRY(3).NE.1).AND.(IENTRY(3).NE.2))) + 1 CALL XABORT('BIVACA: LCM OBJECT IN READ-ONLY MODE EXPECTED AT F' + 2 //'IRST RHS.') + CALL LCMGTC(KENTRY(3),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_TRACK') THEN + TEXT12=HENTRY(3) + CALL XABORT('BIVACA: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_TRACK EXPECTED.') + ENDIF + CALL LCMGTC(KENTRY(3),'TRACK-TYPE',12,HSIGN) + IF(HSIGN.NE.'BIVAC') THEN + TEXT12=HENTRY(3) + CALL XABORT('BIVACA: TRACK-TYPE OF '//TEXT12//' IS '//HSIGN// + 1 '. BIVAC EXPECTED.') + ENDIF + HSIGN='L_SYSTEM' + IPSYS=KENTRY(1) + CALL LCMPTC(IPSYS,'SIGNATURE',12,HSIGN) + IPMACR=KENTRY(2) + IPTRK=KENTRY(3) + TEXT12=HENTRY(2) + CALL LCMPTC(IPSYS,'LINK.MACRO',12,TEXT12) + TEXT12=HENTRY(3) + CALL LCMPTC(IPSYS,'LINK.TRACK',12,TEXT12) +*---- +* RECOVER GENERAL TRACKING INFORMATION. +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',IGP) + NEL=IGP(1) + NLF=IGP(14) + ISCAT=IGP(16) + LDIFF=(ISCAT.LT.0) + ISCAT=ABS(ISCAT) + IF((NLF.NE.0).AND.(IGP(15).NE.1)) CALL XABORT('BIVACA: ONLY SPN ' + 1 //'DISCRETIZATIONS ARE ALLOWED.') + ALLOCATE(MAT(NEL),VOL(NEL)) + CALL LCMGET(IPTRK,'MATCOD',MAT) + CALL LCMGET(IPTRK,'VOLUME',VOL) +*---- +* RECOVER MACROLIB PARAMETERS. +*---- + CALL LCMGTC(IPMACR,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_MACROLIB') THEN + TEXT12=HENTRY(2) + CALL XABORT('BIVACA: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_MACROLIB EXPECTED.') + ENDIF + CALL LCMGET(IPMACR,'STATE-VECTOR',IPAR) + NGRP=IPAR(1) + NBMIX=IPAR(2) + NANI=IPAR(3) + NBFIS=IPAR(4) + NALBP=IPAR(8) + IF(IGP(4).GT.NBMIX) THEN + WRITE(HSMG,'(46HBIVACA: THE NUMBER OF MIXTURES IN THE TRACKING, + 1 2H (,I5,51H) IS GREATER THAN THE NUMBER OF MIXTURES IN THE MAC, + 2 7HROLIB (,I5,2H).)') IGP(4),NBMIX + CALL XABORT(HSMG) + ENDIF +* + IMPX=1 + IUNIT=0 + IOVEL=0 + 10 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.EQ.10) GO TO 40 + IF(INDIC.NE.3) CALL XABORT('BIVACA: CHARACTER DATA EXPECTED.') + IF(TEXT4.EQ.'EDIT') THEN + CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('BIVACA: INTEGER DATA EXPECTED(1).') + ELSE IF(TEXT4.EQ.'UNIT') THEN +* COMPUTE THE UNITARY WEIGHTING MATRIX. + IUNIT=1 + ALLOCATE(UN(NBMIX),GAMMA(NALBP)) + UN(:NBMIX)=1.0 + CALL BIVASM('RM',1,IPTRK,IPSYS,IMPX,NBMIX,NEL,0,1,0,MAT,VOL, + 1 GAMMA,UN) + DEALLOCATE(GAMMA,UN) + ELSE IF(TEXT4.EQ.'OVEL') THEN +* COMPUTE THE RECIPROCAL NEUTRON VELOCITIES MATRIX. + IOVEL=1 + JPMACR=LCMGID(IPMACR,'GROUP') + ALLOCATE(VII(NBMIX),GAMMA(NALBP)) + DO 30 IGR=1,NGRP + KPMACR=LCMGIL(JPMACR,IGR) + CALL LCMLEN(KPMACR,'OVERV',LENGT,ITYLCM) + IF(LENGT.EQ.0) THEN + CALL XABORT('BIVACA: NO ''VELOCITY'' INFORMATION.') + ELSE IF(LENGT.GT.NBMIX) THEN + CALL XABORT('BIVACA: INVALID LENGTH FOR ''VELOCITY'' IN' + 1 //'FORMATION.') + ENDIF + CALL LCMGET(KPMACR,'OVERV',VII) + WRITE(CNAM,'(1HV,2I3.3)') IGR,IGR + CALL BIVASM(CNAM,1,IPTRK,IPSYS,IMPX,NBMIX,NEL,0,1,0,MAT,VOL, + 1 GAMMA,VII) + 30 CONTINUE + DEALLOCATE(GAMMA,VII) + ELSE IF(TEXT4.EQ.';') THEN + GO TO 40 + ELSE + CALL XABORT('BIVACA: '//TEXT4//' IS AN INVALID KEY WORD.') + ENDIF + GO TO 10 +*---- +* SET THE STATE VECTOR FOR THE L_SYSTEM OBJECT +*---- + 40 IBR(:NSTATE)=0 + IBR(1)=NGRP + IBR(2)=IGP(11) + IBR(4)=1 + IF(NLF.GT.0) IBR(4)=11 + IF(IUNIT.EQ.1) IBR(5)=1 + IBR(7)=NBMIX + NAN=MIN(ISCAT,NANI) + IBR(8)=NLF + CALL LCMPUT(IPSYS,'STATE-VECTOR',NSTATE,1,IBR) +*---- +* BIVAC SYSTEM MATRIX ASSEMBLY. +*---- + IF(NLF.EQ.0) THEN +* DIFFUSION THEORY. + CALL BIVSYS(IPTRK,IPMACR,IPSYS,IMPX,NGRP,NEL,NBFIS,NALBP,MAT, + 1 VOL,NBMIX) + ELSE +* SIMPLIFIED PN THEORY. + CALL BIVSPS(IPTRK,IPMACR,IPSYS,IMPX,NGRP,NEL,NLF,NAN,NBFIS, + 1 NALBP,LDIFF,MAT,VOL,NBMIX) + ENDIF +* + IF(IMPX.GE.3) CALL LCMLIB(IPSYS) +*---- +* RELEASE GENERAL TRACKING INFORMATION. +*---- + DEALLOCATE(VOL,MAT) + RETURN + END diff --git a/Trivac/src/BIVACT.f b/Trivac/src/BIVACT.f new file mode 100755 index 0000000..cf4b74f --- /dev/null +++ b/Trivac/src/BIVACT.f @@ -0,0 +1,268 @@ +*DECK BIVACT + SUBROUTINE BIVACT(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* BIVAC type (2-D) tracking operator. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1): create or modification type(L_TRACK); +* HENTRY(2): read-only type(L_GEOM). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*Comments: +* The BIVACT: calling specifications are: +* TRACK := BIVACT: [ TRACK ] GEOM :: (bivact\_data) ; +* where +* TRACK : name of the \emph{lcm} object (type L\_BIVAC) containing the +* \emph{tracking} information. If TRACK appears on the RHS, the previous +* settings will be applied by default. +* GEOM : name of the \emph{lcm} object (type L\_GEOM) containing the +* geometry. +* bivact\_data : structure containing the data to module BIVACT:} +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 + TYPE(C_PTR) KENTRY(NENTRY) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40,IOUT=6) + CHARACTER TEXT4*4,TEXT12*12,TITLE*72,HSIGN*12 + DOUBLE PRECISION DFLOTT + LOGICAL LOG,LDIFF + INTEGER IGP(NSTATE),ISTATE(NSTATE),NCODE(6) +*---- +* PARAMETER VALIDATION +*---- + IF(NENTRY.LE.1) CALL XABORT('BIVACT: TWO PARAMETERS EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('BIVACT: L' + 1 //'CM OBJECT EXPECTED AT LHS.') + IF((JENTRY(1).NE.0).AND.(JENTRY(1).NE.1)) CALL XABORT('BIVACT: E' + 1 //'NTRY IN CREATE OR MODIFICATION MODE EXPECTED.') + IF((JENTRY(2).NE.2).OR.((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2))) + 1 CALL XABORT('BIVACT: LCM OBJECT IN READ-ONLY MODE EXPECTED AT R' + 2 //'HS.') + CALL LCMGTC(KENTRY(2),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_GEOM') THEN + TEXT12=HENTRY(2) + CALL XABORT('BIVACT: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_GEOM EXPECTED.') + ENDIF + HSIGN='L_TRACK' + CALL LCMPTC(KENTRY(1),'SIGNATURE',12,HSIGN) + HSIGN='BIVAC' + CALL LCMPTC(KENTRY(1),'TRACK-TYPE',12,HSIGN) + CALL LCMGET(KENTRY(2),'STATE-VECTOR',ISTATE) + ITYPE=ISTATE(1) + CALL LCMLEN(KENTRY(2),'BIHET',ILONG,ITYLCM) + IF(ILONG.NE.0) CALL XABORT('BIVACT: DOUBLE-HETEROGENEITY NOT SUP' + 1 //'PORTED.') +* + IMPX=1 + TITLE=' ' + IF(JENTRY(1).EQ.0) THEN + MAXPTS=ISTATE(6) + IELEM=1 + ICOL=2 + NLF=0 + ISPN=0 + ISCAT=0 + NVD=0 + CALL LCMGET(KENTRY(2),'NCODE',NCODE) + LOG=.FALSE. + DO 10 I=1,4 + LOG=LOG.OR.(NCODE(I).EQ.3) + 10 CONTINUE + IF(LOG) MAXPTS=2*MAXPTS + LDIFF=.FALSE. + ELSE + CALL LCMGTC(KENTRY(1),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_TRACK') THEN + TEXT12=HENTRY(1) + CALL XABORT('BIVACT: SIGNATURE OF '//TEXT12//' IS '//HSIGN + 1 //'. L_TRACK EXPECTED.') + ENDIF + CALL LCMGTC(KENTRY(1),'TRACK-TYPE',12,HSIGN) + IF(HSIGN.NE.'BIVAC') THEN + TEXT12=HENTRY(1) + CALL XABORT('BIVACT: TRACK-TYPE OF '//TEXT12//' IS '//HSIGN + 1 //'. BIVAC EXPECTED.') + ENDIF + CALL LCMGET(KENTRY(1),'STATE-VECTOR',IGP) + MAXPTS=IGP(1) + IELEM=IGP(8) + ICOL=IGP(9) + NLF=IGP(14) + ISPN=IGP(15) + ISCAT=IGP(16) + NVD=IGP(17) + CALL LCMLEN(KENTRY(1),'TITLE',LENGT,ITYLCM) + IF(LENGT.GT.0) CALL LCMGTC(KENTRY(1),'TITLE',72,TITLE) + LDIFF=(ISCAT.LT.0) + ENDIF + 15 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.EQ.10) GO TO 30 + 20 IF(INDIC.NE.3) CALL XABORT('BIVACT: CHARACTER DATA EXPECTED.') + IF(TEXT4.EQ.'EDIT') THEN + CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('BIVACT: INTEGER DATA EXPECTED(1).') + ELSE IF(TEXT4.EQ.'TITL') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TITLE,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('BIVACT: TITLE EXPECTED.') + ELSE IF(TEXT4.EQ.'MAXR') THEN + CALL REDGET(INDIC,MAXPTS,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('BIVACT: INTEGER DATA EXPECTED(2).') + ELSE IF(TEXT4.EQ.'PRIM') THEN +* MESH CORNER FINITE DIFFERENCES OR PRIMAL FINITE ELEMENTS. + IELEM=-1 + ICOL=2 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.EQ.1) THEN + IELEM=-NITMA + CALL REDGET(INDIC,ICOL,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('BIVACT: INTEGER DATA EXPECTED(' + 1 //'3).') + ELSE + GO TO 20 + ENDIF + ELSE IF(TEXT4.EQ.'MCFD') THEN +* MESH CENTERED FINITE DIFFERENCES IN HEXAGONAL GEOMETRY. + IF(ITYPE.NE.8) CALL XABORT('BIVACT: MCFD OPTION LIMITED TO HE' + 1 //'XAGONAL GEOMETRY.') + ICOL=4 + ELSE IF(TEXT4.EQ.'DUAL') THEN +* MESH CENTERED FINITE DIFFERENCES OR MIXED-DUAL FINITE ELEMENTS. + IELEM=1 + ICOL=2 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.EQ.1) THEN + IELEM=NITMA + CALL REDGET(INDIC,ICOL,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('BIVACT: INTEGER DATA EXPECTED(' + 1 //'6).') + ELSE + GO TO 20 + ENDIF + ELSE IF(TEXT4.EQ.'VOID') THEN + IF(NLF.EQ.0) CALL XABORT('BIVACT: SPN-RELATED OPTION.') + CALL REDGET(INDIC,NVD,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('BIVACT: INTEGER DATA EXPECTED(8).') + IF((NVD.LT.0).OR.(NVD.GT.2)) CALL XABORT('BIVACT: INVALID VAL' + 1 //'UE OF NVD (0, 1 OR 2 EXPECTED).') + ELSE IF(TEXT4.EQ.'PN') THEN + CALL REDGET(INDIC,NLF,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('BIVACT: INTEGER DATA EXPECTED(9).') + IF(MOD(NLF,2).EQ.0) CALL XABORT('BIVACT: ODD PN ORDER EXPECT' + 1 //'ED.') + IF(NLF.GT.0) NLF=NLF+1 + ISCAT=NLF + ISPN=0 + ELSE IF(TEXT4.EQ.'SPN') THEN + CALL REDGET(INDIC,NLF,FLOTT,TEXT4,DFLOTT) + IF((INDIC.EQ.3).AND.(TEXT4.EQ.'DIFF')) THEN + LDIFF=.TRUE. + CALL REDGET(INDIC,NLF,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('BIVACT: INTEGER DATA EXPECTED' + 1 //'(10).') + ELSE IF(INDIC.NE.1) THEN + CALL XABORT('BIVACT: INTEGER DATA OR DIFF KEYWORD EXPECTED.') + ENDIF + IF(NLF.EQ.0) THEN +* DIFFUSION THEORY. + ISCAT=0 + ISPN=0 + ELSE + IF(MOD(NLF,2).EQ.0) CALL XABORT('BIVACT: ODD SPN ORDER EXP' + 1 //'ECTED.') + NLF=NLF+1 + ISCAT=NLF + ISPN=1 + ENDIF + ELSE IF(TEXT4.EQ.'SCAT') THEN + IF(NLF.EQ.0) CALL XABORT('BIVACT: DEFINE PN OR SPN FIRST.') + CALL REDGET(INDIC,ISCAT,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('BIVACT: INTEGER DATA EXPECTED(11)' + 1 //'.') + IF(ISCAT.LE.0) CALL XABORT('BIVACT: POSITIVE ISCAT EXPECTED.') + ELSE IF(TEXT4.EQ.';') THEN + GO TO 30 + ELSE + CALL XABORT('BIVACT: '//TEXT4//' IS AN INVALID KEY WORD.') + ENDIF + GO TO 15 +* + 30 IF(LDIFF) ISCAT=-ISCAT + IF(TITLE.NE.' ') CALL LCMPTC(KENTRY(1),'TITLE',72,TITLE) + IF((NLF.GT.0).AND.(IELEM.LT.0)) CALL XABORT('BIVACT: SPN APPROXI' + 1 //'MATIONS LIMITED TO DUAL DISCRETIZATIONS.') + TEXT12=HENTRY(2) + CALL LCMPTC(KENTRY(1),'LINK.GEOM',12,TEXT12) + IF(IMPX.GT.1) WRITE(IOUT,100) TITLE +* + IF(MAXPTS.EQ.0) CALL XABORT('BIVACT: MAXPTS NOT DEFINED.') + CALL BIVTRK (MAXPTS,KENTRY(1),KENTRY(2),IMPX,IELEM,ICOL,NLF,NVD, + 1 ISPN,ISCAT) +* + IF(IMPX.GT.1) THEN + CALL LCMGET(KENTRY(1),'STATE-VECTOR',IGP) + WRITE(IOUT,110) (IGP(I),I=1,17) + ENDIF + RETURN +* + 100 FORMAT(1H1,36HBBBBBB IIIIII VV VV AA CCCCC ,95(1H*)/ + 1 38H BBBBBBB IIIIII VV VV AAAA CCCCCCC ,56(1H*), + 2 38H MULTIGROUP VERSION. A. HEBERT (1993)/ + 3 37H BB BB II VV VV AAAA CC CC/ + 4 37H BBBBB II VV VV AA AA CC / + 5 37H BBBBB II VV VV AAAAAA CC / + 6 37H BB BB II VV VV AAAAAA CC CC/ + 7 37H BBBBBBB IIIIII VVVV AA AA CCCCCCC/ + 8 37H BBBBBB IIIIII VV AA AA CCCCC //1X,A72//) + 110 FORMAT(/14H STATE VECTOR:/ + 1 7H NREG ,I6,22H (NUMBER OF REGIONS)/ + 2 7H NUN ,I6,23H (NUMBER OF UNKNOWNS)/ + 3 7H ILK ,I6,39H (0=LEAKAGE PRESENT/1=LEAKAGE ABSENT)/ + 4 7H NBMIX ,I6,36H (MAXIMUM NUMBER OF MIXTURES USED)/ + 5 7H NSURF ,I6,29H (NUMBER OF OUTER SURFACES)/ + 6 7H ITYPE ,I6,21H (TYPE OF GEOMETRY)/ + 7 7H IHEX ,I6,31H (TYPE OF HEXAGONAL SYMMETRY)/ + 8 7H IELEM ,I6,28H (TYPE OF FINITE ELEMENTS)/ + 9 7H ICOL ,I6,47H (TYPE OF QUADRATURE USED TO INTEGRATE THE MA, + 1 10HSS MATRIX)/ + 2 7H ISPLH ,I6,37H (TYPE OF HEXAGONAL MESH-SPLITTING)/ + 3 7H LL4 ,I6,45H (ORDER OF THE MATRICES PER GROUP IN BIVAC)/ + 4 7H LX ,I6,40H (NUMBER OF ELEMENTS ALONG THE X AXIS)/ + 5 7H LY ,I6,40H (NUMBER OF ELEMENTS ALONG THE Y AXIS)/ + 6 7H NLF ,I6,45H (0=DIFFUSION/NB OF PN ORDERS FOR THE FLUX)/ + 7 7H ISPN ,I6,34H (0=COMPLETE PN/1=SIMPLIFIED PN)/ + 8 7H ISCAT ,I6,47H (1=ISOTROPIC SOURCE/2=LINEARLY ANISOTROPIC S, + 9 6HOURCE)/ + 1 7H NVD ,I6,47H (0=PN-TYPE VOID/1=SN-TYPE VOID/2=DIFFUSION-T, + 2 9HYPE VOID)) + END diff --git a/Trivac/src/BIVALL.f b/Trivac/src/BIVALL.f new file mode 100755 index 0000000..d4c38af --- /dev/null +++ b/Trivac/src/BIVALL.f @@ -0,0 +1,426 @@ +*DECK BIVALL + SUBROUTINE BIVALL (MAXPTS,IHEX,NH,NTH,ITAB) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Unfold any hexagonal geometry to produce a complete domain. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Benaboud +* +*Parameters: input +* MAXPTS maximum number of hexagons. +* IHEX type of symmetry: +* =1: S30; =2: SA60; =3: SB60; =4: S90; =5: R120; +* =6: R180; =7: SA180; =8: SB180; =9: COMPLETE. +* NH total number of hexagons in the partial hexagonal geometry. +* +*Parameters: output +* NTH total number of hexagons in the complete geometry. +* ITAB correspondance table. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MAXPTS,IHEX,NH,NTH,ITAB(MAXPTS) +*---- +* LOCAL VARIABLES +*---- + LOGICAL LPAIR + CHARACTER TEXT4*4 + INTEGER NP(7) + INTEGER, DIMENSION(:), ALLOCATABLE :: J1,J2,J3,K1,K2,K3,K4 +* + NC=0 + IF((IHEX.EQ.1).OR.(IHEX.EQ.10)) THEN + VI = 2.* SQRT(REAL(NH)) - 1. + VP = SQRT(REAL(4*NH+1)) - 1. + IF(AINT(VI).EQ.VI) THEN + NC = INT(VI) + ELSE IF(AINT(VP).EQ.VP) THEN + NC = INT(VP) + ELSE + CALL XABORT('BIVALL: INVALID NUMBER OF HEXAGONS (1).') + ENDIF + ELSE IF((IHEX.EQ.2).OR.(IHEX.EQ.11)) THEN + VA = (SQRT(REAL(8*NH+1)) - 1.)/2. + IF(AINT(VA).EQ.VA) THEN + NC = INT(VA) + ELSE + CALL XABORT('BIVALL: INVALID NUMBER OF HEXAGONS (2).') + ENDIF + ELSE IF(IHEX.EQ.3) THEN + VI = SQRT(REAL(2*NH-1)) + VP = SQRT(REAL(2*NH)) + IF(AINT(VI).EQ.VI) THEN + NC = INT(VI) + ELSE IF(AINT(VP).EQ.VP) THEN + NC = INT(VP) + ELSE + CALL XABORT('BIVALL: INVALID NUMBER OF HEXAGONS (3).') + ENDIF + ELSE IF(IHEX.EQ.4) THEN + VI = SQRT(REAL((4*NH-1)/3)) + VP = SQRT(REAL(4*NH/3)) + IF(AINT(VI).EQ.VI) THEN + NC = INT(VI) + ELSE IF(AINT(VP).EQ.VP) THEN + NC = INT(VP) + ELSE + CALL XABORT('BIVALL: INVALID NUMBER OF HEXAGONS (4).') + ENDIF + ELSE IF(IHEX.EQ.5) THEN + VA = (SQRT(REAL(4*(NH-1)+1)) + 1.)/2. + IF(AINT(VA).EQ.VA) THEN + NC = INT(VA) + ELSE + CALL XABORT('BIVALL: INVALID NUMBER OF HEXAGONS (5).') + ENDIF + ELSE IF(IHEX.EQ.6) THEN + VA = (SQRT(REAL(8*(NH-1)/3+1)) + 1)/2 + IF(AINT(VA).EQ.VA) THEN + NC = INT(VA) + ELSE + CALL XABORT('BIVALL: INVALID NUMBER OF HEXAGONS (6).') + ENDIF + ELSE IF(IHEX.EQ.7) THEN + VA = (SQRT(REAL(24*NH+1)) + 1.)/6. + IF(AINT(VA).EQ.VA) THEN + NC = INT(VA) + ELSE + CALL XABORT('BIVALL: INVALID NUMBER OF HEXAGONS (7).') + ENDIF + ELSE IF(IHEX.EQ.8) THEN + VI = (1.+SQRT(REAL(3*(2*NH-1)+1)))/3. + VP = (1.+SQRT(REAL(6*NH+1)))/3. + IF(AINT(VI).EQ.VI) THEN + NC = INT(VI) + ELSE IF(AINT(VP).EQ.VP) THEN + NC = INT(VP) + ELSE + CALL XABORT('BIVALL: INVALID NUMBER OF HEXAGONS (8).') + ENDIF + ELSE IF(IHEX.EQ.9) THEN + VA = (SQRT(REAL((4*NH-1)/3)) + 1.)/2. + IF(AINT(VA).EQ.VA) THEN + NC = INT(VA) + ELSE + CALL XABORT('BIVALL: INVALID NUMBER OF HEXAGONS (9).') + ENDIF + ELSE + WRITE(TEXT4,'(I4)') IHEX + CALL XABORT('BIVALL: INVALID TYPE OF SYMMETRY (IHEX='//TEXT4// + 1 ').') + ENDIF + NTH = 1 + 3 * NC * (NC - 1) + IF(NTH.GT.MAXPTS) CALL XABORT('BIVALL: MAXPTS OVERFLOW.') + ITAB(1) = 1 + ALLOCATE(J1(NC+2),J2(NC+2),J3(NC+2),K1(NC+2),K2(NC+2),K3(NC+2), + 1 K4(NC+2)) + J1(1) = 1 + J2(1) = 1 + J3(1) = 1 + K1(1) = 1 + K2(1) = 1 + K3(1) = 1 + DO 10 L = 2,NC+1 + J1(L) = (L-1)*6 + J3(L) = 1+3*L*(L-1) + J2(L) = 1+J3(L-1) + 10 CONTINUE +* + IF((IHEX.EQ.1).OR.(IHEX.EQ.10)) THEN + IL=0 + DO 20 L = 1,NC+1,2 + K1(L) = 1 + IL + K1(L+1) = 1 + IL + IL = IL+1 + 20 CONTINUE + DO 30 L = 2,NC+1 + K2(L) = K2(L-1) + K1(L-1) + 30 CONTINUE + IL=0 + DO 40 L = 1,NC+1,2 + K3(L) = K2(L) + IL + K3(L+1) = K2(L+1) + IL + IL = IL+1 + 40 CONTINUE + ELSE IF((IHEX.EQ.2).OR.(IHEX.EQ.11)) THEN + K1(2) = 2 + DO 50 L = 2,NC+1 + K2(L) = K2(L-1) + L + K1(L+1) = K1(L) + L + 50 CONTINUE + ELSE IF(IHEX.EQ.3) THEN + K1(2) = 2 + DO 60 L = 1,NC+1 + K1(L+1) = K1(L) + L + 60 CONTINUE + IL=0 + DO 70 L = 1,NC+1,2 + K4(L) = 1 + IL + K4(L+1) = 1 + IL + IL = IL + 2 + 70 CONTINUE + DO 80 L = 2,NC+1 + K2(L) = K2(L-1) + K4(L-1) + K3(L) = K3(L-1) + K4(L) + 80 CONTINUE + ELSE IF(IHEX.EQ.4) THEN + IL=0 + DO 90 L = 1,NC+1,2 + K4(L) = L + IL + K4(L+1) = L + IL + 1 + IL = IL + 1 + 90 CONTINUE + DO 100 L = 2,NC+1 + K1(L) = K1(L-1) + K4(L-1) + K3(L) = K3(L-1) + K4(L) +100 CONTINUE + IL=0 + DO 110 L = 1,NC+1,2 + K2(L) = K1(L) + IL + K2(L+1) = K1(L+1) + IL + IL = IL+1 +110 CONTINUE + ELSE IF(IHEX.EQ.5) THEN + DO 120 L = 2,NC+1 + K2(L) = 2 * (L-1) + K1(L) = K1(L-1) + K2(L) +120 CONTINUE + ELSE IF(IHEX.EQ.6) THEN + DO 130 L = 2,NC+1 + K2(L) = 3 * (L-1) + K1(L) = K1(L-1) + K2(L) +130 CONTINUE + ELSE IF(IHEX.EQ.7) THEN + DO 140 L = 2,NC+1 + K2(L) = 3 + K2(L-1) + K1(L) = K1(L-1) + K2(L) +140 CONTINUE + ELSE IF(IHEX.EQ.8) THEN + IL = 1 + IF = 1 + DO 150 L = 2,NC+1,2 + K2(L) = 3 * (L-1) + K2(L+1) = 3 * L + 1 +150 CONTINUE + DO 160 L = 2,NC+1 + IL = IL + K2(L) + IF = IF + K2(L-1) + K1(L) = (IF + IL) / 2 +160 CONTINUE + ENDIF +* + DO 300 N = 2,NTH + I=0 + J=0 + DO 170 I0 = 2,NC + IF((N.GE.J2(I0)).AND.(N.LE.J3(I0))) THEN + I=I0 + GO TO 180 + ENDIF +170 CONTINUE + IF(I.EQ.0) CALL XABORT('BIVALL: ALGORITHM FAILURE(1).') +180 DO 190 K = 1,6 + NP(K) = J2(I) + (K - 1) * (I - 1) +190 CONTINUE + NP(7) = J3(I) + COURS2 = REAL(I)/2. + LPAIR = (AINT(COURS2).EQ.COURS2) +* + IF((IHEX.EQ.1).OR.(IHEX.EQ.10)) THEN + IF(N.LE.7) THEN + ITAB(N) = 2 + GO TO 300 + ENDIF + DO 200 L = 1,6 + IF((N.GE.NP(L)).AND.(N.LT.NP(L+1))) J = L +200 CONTINUE + IF(N.EQ.NP(7)) J = 6 + IF(J.EQ.0) CALL XABORT('BIVALL: ALGORITHM FAILURE(2).') + IC = 0 + IF(J.EQ.6) IC = 1 + N12 = (NP(J) + NP(J+1)+IC)/2 + N13 = N12 + 1 + IF(N.EQ.NP(J)) THEN + ITAB(N) = K3(I) + ELSE IF(N.EQ.NP(7)) THEN + ITAB(N) = K3(I) - 1 + ELSE IF((N.GT.NP(J)).AND.(N.LT.N12)) THEN + ITAB(N) = K3(I) - (N - NP(J)) + ELSE IF((N.EQ.N12).OR.((N.EQ.N13).AND.LPAIR)) THEN + ITAB(N) = K2(I) + ELSE IF((N.EQ.N13).AND.(.NOT.LPAIR)) THEN + ITAB(N) = K3(I) - (NP(J+1) + IC - N) + ELSE IF((N.GT.N13).AND.(N.LT.NP(J+1))) THEN + ITAB(N) = K3(I) - (NP(J+1) + IC - N) + ENDIF +* + ELSE IF((IHEX.EQ.2).OR.(IHEX.EQ.11)) THEN + DO 210 L = 1,6,2 + IF((N.GE.NP(L)).AND.(N.LT.NP(L+2))) J = L +210 CONTINUE + IF(N.EQ.NP(7)) J = 5 + IF(J.EQ.0) CALL XABORT('BIVALL: ALGORITHM FAILURE(3).') + IF(N.EQ.NP(J)) THEN + ITAB(N) = K2(I) + ELSE IF(N.EQ.NP(7)) THEN + ITAB(N) = K2(I) - 1 + ELSE IF((N.GT.NP(J)).AND.(N.LT.NP(J+1))) THEN + ITAB(N) = K2(I) - (N - NP(J)) + ELSE IF(N.EQ.NP(J+1)) THEN + ITAB(N) = K1(I) + ELSE IF((N.GT.NP(J+1)).AND.(N.LT.NP(J+2))) THEN + ITAB(N) = K1(I) + (N - NP(J+1)) + ENDIF +* + ELSE IF(IHEX.EQ.3) THEN + IF(N.LE.7) THEN + ITAB(N) = 2 + GO TO 300 + ENDIF + DO 220 L = 1,6,2 + IF((N.GE.NP(L)).AND.(N.LT.NP(L+2))) J = L +220 CONTINUE + IF(N.EQ.NP(7)) J = 5 + IF(J.EQ.0) CALL XABORT('BIVALL: ALGORITHM FAILURE(4).') + IC = 0 + IF(J.EQ.5) IC = 1 + N12 = (NP(J) + NP(J+1))/2 + N13 = N12 + 1 + N14 = (NP(J+1) + NP(J+2)+IC)/2 + N15 = N14 + 1 + IF((N.EQ.NP(J)).OR.(N.EQ.NP(J+1))) THEN + ITAB(N) = K1(I) + ELSE IF(N.EQ.NP(7)) THEN + ITAB(N) = K1(I) - 1 + ELSE IF((N.GT.NP(J)).AND.(N.LT.N12)) THEN + ITAB(N) = K1(I) + (N - NP(J)) + ELSE IF((N.EQ.N12).OR.((N.EQ.N13).AND.LPAIR)) THEN + ITAB(N) = K3(I) + ELSE IF((N.EQ.N13).AND.(.NOT.LPAIR)) THEN + ITAB(N) = K3(I) - 1 + ELSE IF((N.GT.N13).AND.(N.LT.NP(J+1))) THEN + ITAB(N) = K1(I) + (NP(J+1) - N) + ELSE IF((N.GT.NP(J+1)).AND.(N.LT.N14)) THEN + ITAB(N) = K1(I) - (N - NP(J+1)) + ELSE IF((N.EQ.N14).OR.((N.EQ.N15).AND.LPAIR)) THEN + ITAB(N) = K2(I) + ELSE IF((N.EQ.N15).AND.(.NOT.LPAIR)) THEN + ITAB(N) = K2(I) + 1 + ELSE IF((N.GT.N15).AND.(N.LT.NP(J+2))) THEN + ITAB(N) = K1(I) - (NP(J+2) + IC - N) + ENDIF +* + ELSE IF(IHEX.EQ.4) THEN + IF(N.EQ.7) THEN + ITAB(N) = 2 + GO TO 300 + ENDIF + DO 230 L = 1,6,3 + IF((N.GE.NP(L)).AND.(N.LT.NP(L+3))) J = L +230 CONTINUE + IF(N.EQ.NP(7)) J = 4 + IF(J.EQ.0) CALL XABORT('BIVALL: ALGORITHM FAILURE(5).') + IC = 0 + IF(J.EQ.4) IC = 1 + N12 = (NP(J+2) + NP(J+3)+IC)/2 + N13 = N12 + 1 + IF((N.EQ.NP(J)).OR.(N.EQ.NP(J+2))) THEN + ITAB(N) = K2(I) + ELSE IF(N.EQ.NP(7)) THEN + ITAB(N) = K2(I) - 1 + ELSE IF((N.GT.NP(J)).AND.(N.LT.NP(J+1))) THEN + ITAB(N) = K2(I) + (N - NP(J)) + ELSE IF(N.EQ.NP(J+1)) THEN + ITAB(N) = K3(I) + ELSE IF((N.GT.NP(J+1)).AND.(N.LE.N12).AND.(N.NE.NP(J+2))) THEN + ITAB(N) = K2(I) - (N - NP(J+2)) + ELSE IF((N.EQ.N13).AND.(.NOT.LPAIR)) THEN + ITAB(N) = K2(I) - (NP(J+3) + IC - N) + ELSE IF((N.EQ.N13).AND.LPAIR) THEN + ITAB(N) = K1(I) + ELSE IF((N.GT.N13).AND.(N.LT.NP(J+3))) THEN + ITAB(N) = K2(I) - (NP(J+3) + IC - N) + ENDIF +* + ELSE IF(IHEX.EQ.5) THEN + IF(N.EQ.7) THEN + ITAB(N) = 3 + GO TO 300 + ELSE IF((N.EQ.11).OR.(N.EQ.15).OR.(N.EQ.19)) THEN + ITAB(N) = 4 + GO TO 300 + ENDIF + DO 240 L = 1,6,2 + IF((N.GE.NP(L)).AND.(N.LT.NP(L+2))) J = L +240 CONTINUE + IF(N.EQ.NP(7)) J = 5 + IF(J.EQ.0) CALL XABORT('BIVALL: ALGORITHM FAILURE(6).') + IC = 0 + IF(J.EQ.5) IC = 1 + IF((N.GE.NP(J)).AND.(N.LE.NP(J+1))) THEN + ITAB(N) = K1(I) - (NP(J+1) - N) + ELSE IF((N.GT.NP(J+1)).AND.(N.LE.NP(J+2)+IC)) THEN + ITAB(N) = K1(I) -(2*(NP(J+2)+IC)-NP(J+1)- N) + ENDIF +* + ELSE IF(IHEX.EQ.6) THEN + DO 250 L = 1,6,3 + IF((N.GE.NP(L)).AND.(N.LT.NP(L+3))) J = L +250 CONTINUE + IF(N.EQ.NP(7)) J = 4 + IF(J.EQ.0) CALL XABORT('BIVALL: ALGORITHM FAILURE(7).') + IC = 0 + IF(J.EQ.4) IC = 1 + IF((N.GE.NP(J)).AND.(N.LE.NP(J+1))) THEN + ITAB(N) = K1(I) - (NP(J+1) - N) + ELSE IF((N.GT.NP(J+1)).AND.(N.LE.NP(J+2))) THEN + ITAB(N) = K1(I) - 2*(NP(J+2)-NP(J+1))-(NP(J+2)-N) + ELSE IF((N.GT.NP(J+2)).AND.(N.LE.NP(J+3)+IC)) THEN + ITAB(N) = K1(I)-(2*(NP(J+3)+IC)-NP(J+2)-N) + ENDIF +* + ELSE IF(IHEX.EQ.7) THEN + IF((N.GE.NP(1)).AND.(N.LE.NP(2))) THEN + ITAB(N) = K1(I) - (NP(2) - N) + ELSE IF((N.GT.NP(2)).AND.(N.LE.NP(3))) THEN + ITAB(N) = K1(I) - (NP(3) - NP(2)) + (NP(3) - N) + ELSE IF((N.GT.NP(3)).AND.(N.LE.NP(4))) THEN + ITAB(N) = K1(I) - (NP(4) - NP(2)) + (NP(4) - N) + ELSE IF((N.GT.NP(4)).AND.(N.LE.NP(5))) THEN + ITAB(N) = K1(I) - (NP(5) - NP(2)) + (NP(5) - N) + ELSE IF((N.GT.NP(5)).AND.(N.LE.NP(6))) THEN + ITAB(N) = K1(I) - (NP(4) - NP(2)) - (NP(6) - N) + ELSE IF((N.GT.NP(6)).AND.(N.LE.NP(7)+1)) THEN + ITAB(N) = K1(I) - (NP(3) - NP(2)) - (NP(7) + 1 - N) + ENDIF +* + ELSE IF(IHEX.EQ.8) THEN + N12 = (NP(3) + NP(4)) / 2 + N13 = (NP(6) + NP(7) + 1) / 2 + IF((N.GE.NP(1)).AND.(N.LE.N12)) THEN + ITAB(N) = K1(I) - (NP(2) - N) + ELSE IF((N.GT.N12).AND.(N.LE.N13)) THEN + ITAB(N) = K1(I) + (NP(5) - N) + ELSE IF((N.GT.N13).AND.(N.LE.NP(7)+1)) THEN + ITAB(N) = K1(I) - (NP(6) - NP(5)) - (NP(7) + 1 - N) + ENDIF +* + ELSE IF(IHEX.EQ.9) THEN + ITAB(N) = N + ENDIF +300 CONTINUE + DEALLOCATE(K4,K3,K2,K1,J3,J2,J1) + RETURN + END diff --git a/Trivac/src/BIVASM.f b/Trivac/src/BIVASM.f new file mode 100755 index 0000000..6d86410 --- /dev/null +++ b/Trivac/src/BIVASM.f @@ -0,0 +1,229 @@ +*DECK BIVASM
+ SUBROUTINE BIVASM(HNAMT,ITY,IPTRK,IPSYS,IMPX,NBMIX,NEL,NLF,NDIM,
+ 1 NALBP,MAT,VOL,GAMMA,SGD)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Assembling of a single-group system matrix for BIVAC.
+*
+*Copyright:
+* Copyright (C) 2008 Ecole Polytechnique de Montreal.
+*
+*Author(s): A. Hebert
+*
+*Parameters: input/output
+* HNAMT name of the matrix.
+* ITY type of assembly: =0: leakage-removal matrix assembly;
+* =1: cross section matrix assembly.
+* IPTRK L_TRACK pointer to the BIVAC tracking information.
+* IPSYS L_SYSTEM pointer to system matrices.
+* IMPX print parameter (equal to zero for no print).
+* NBMIX total number of material mixtures.
+* NEL total number of finite elements.
+* NLF number of Legendre orders for the flux (even number). Equal
+* to zero for diffusion theory.
+* NDIM second dimension of matrix SGD.
+* NALBP number of physical albedos.
+* MAT mixture index assigned to each volume.
+* VOL volume of each element.
+* GAMMA physical albedo functions.
+* SGD nuclear properties per material mixture.
+*
+*-----------------------------------------------------------------------
+*
+ USE GANLIB
+*----
+* SUBROUTINE ARGUMENTS
+*----
+ CHARACTER HNAMT*(*)
+ TYPE(C_PTR) IPTRK,IPSYS
+ INTEGER ITY,IMPX,NBMIX,NEL,NLF,NDIM,NALBP,MAT(NEL)
+ REAL VOL(NEL),GAMMA(NALBP),SGD(NBMIX,NDIM)
+*----
+* LOCAL VARIABLES
+*----
+ PARAMETER (NSTATE=40)
+ LOGICAL CYLIND
+ CHARACTER TEXT11*11
+ INTEGER ITP(NSTATE)
+ INTEGER, DIMENSION(:), ALLOCATABLE :: KN,IQFR,MU,IPERT
+ REAL, DIMENSION(:), ALLOCATABLE :: XX,YY,DD,QFR
+ REAL, DIMENSION(:,:), ALLOCATABLE :: R,RS,Q,QS,V,H,RH,QH,RT,QT
+ REAL, DIMENSION(:), POINTER :: SYS,ASS
+ TYPE(C_PTR) SYS_PTR,ASS_PTR
+*----
+* RECOVER BIVAC SPECIFIC TRACKING INFORMATION
+*----
+ CALL LCMGET(IPTRK,'STATE-VECTOR',ITP)
+ ITYPE=ITP(6)
+ CYLIND=(ITYPE.EQ.3).OR.(ITYPE.EQ.6)
+ IELEM=ITP(8)
+ ICOL=ITP(9)
+ ISPLH=ITP(10)
+ LL4=ITP(11)
+ LX=ITP(12)
+ LY=ITP(13)
+ NVD=ITP(17)
+ CALL LCMLEN(IPTRK,'KN',MAXKN,ITYLCM)
+ CALL LCMLEN(IPTRK,'QFR',MAXQF,ITYLCM)
+ ALLOCATE(XX(LX*LY),YY(LX*LY),DD(LX*LY),KN(MAXKN),QFR(MAXQF),
+ 1 IQFR(MAXQF),MU(LL4))
+ IF(ITYPE.EQ.8) THEN
+ CALL LCMGET(IPTRK,'SIDE',SIDE)
+ ELSE
+ CALL LCMGET(IPTRK,'XX',XX)
+ CALL LCMGET(IPTRK,'YY',YY)
+ CALL LCMGET(IPTRK,'DD',DD)
+ ENDIF
+ CALL LCMGET(IPTRK,'KN',KN)
+ CALL LCMGET(IPTRK,'QFR',QFR)
+ CALL LCMGET(IPTRK,'IQFR',IQFR)
+ CALL LCMGET(IPTRK,'MU',MU)
+*----
+* APPLY PHYSICAL ALBEDO FUNCTIONS
+*----
+ IF(NALBP.GT.0) THEN
+ DO IQW=1,MAXQF
+ IALB=IQFR(IQW)
+ IF(IALB.NE.0) QFR(IQW)=QFR(IQW)*GAMMA(IALB)
+ ENDDO
+ ENDIF
+*
+ TEXT11=HNAMT
+ IF(IMPX.GT.0) WRITE(6,'(/36H BIVASM: ASSEMBLY OF SYMMETRIC MATRI,
+ 1 3HX '',A11,38H'' IN COMPRESSED DIAGONAL STORAGE MODE.)') TEXT11
+*----
+* ASSEMBLY OF THE SYSTEM MATRICES
+*----
+ CALL KDRCPU(TK1)
+ IIMAX=MU(LL4)
+ IF(NLF.NE.0) IIMAX=IIMAX*NLF/2
+ SYS_PTR=LCMARA(IIMAX)
+ CALL C_F_POINTER(SYS_PTR,SYS,(/ IIMAX /))
+ SYS(:IIMAX)=0.0
+*
+ IF((IELEM.LT.0).AND.(ITYPE.NE.8)) THEN
+* MESH CORNER FINITE DIFFERENCES OR LAGRANGIAN FINITE ELEMENTS
+ CALL LCMSIX(IPTRK,'BIVCOL',1)
+ CALL LCMLEN(IPTRK,'T',LC,ITYLCM)
+ ALLOCATE(R(LC,LC),RS(LC,LC),Q(LC,LC),QS(LC,LC))
+ CALL LCMGET(IPTRK,'R',R)
+ CALL LCMGET(IPTRK,'RS',RS)
+ CALL LCMGET(IPTRK,'Q',Q)
+ CALL LCMGET(IPTRK,'QS',QS)
+ CALL LCMSIX(IPTRK,' ',2)
+ CALL BIVA01(ITY,MAXKN,SGD,CYLIND,NEL,LL4,NBMIX,IIMAX,
+ 1 XX,YY,DD,MAT,KN,QFR,VOL,MU,LC,R,RS,Q,QS,SYS)
+ DEALLOCATE(R,RS,Q,QS)
+ ELSE IF((IELEM.GT.0).AND.(ITYPE.NE.8).AND.(NLF.GT.0)) THEN
+* MIXED-DUAL FINITE ELEMENTS (SIMPLIFIED PN THEORY)
+ CALL LCMSIX(IPTRK,'BIVCOL',1)
+ CALL LCMLEN(IPTRK,'T',LC,ITYLCM)
+ ALLOCATE(R(LC,LC),V(LC,LC-1))
+ CALL LCMGET(IPTRK,'R',R)
+ CALL LCMGET(IPTRK,'V',V)
+ CALL LCMSIX(IPTRK,' ',2)
+ CALL PNDM2E(ITY,NEL,LL4,IELEM,ICOL,MAT,VOL,NBMIX,NLF,NVD,
+ 1 NDIM/2,SGD(1,1),SGD(1,1+NDIM/2),XX,YY,KN,QFR,MU,IIMAX,LC,
+ 2 R,V,SYS)
+ DEALLOCATE(R,V)
+ ELSE IF((IELEM.GT.0).AND.(ITYPE.NE.8)) THEN
+* MIXED-DUAL FINITE ELEMENTS (DIFFUSION THEORY).
+ CALL LCMSIX(IPTRK,'BIVCOL',1)
+ CALL LCMLEN(IPTRK,'T',LC,ITYLCM)
+ ALLOCATE(R(LC,LC),V(LC,LC-1))
+ CALL LCMGET(IPTRK,'R',R)
+ CALL LCMGET(IPTRK,'V',V)
+ CALL LCMSIX(IPTRK,' ',2)
+ CALL BIVA02(ITY,SGD,CYLIND,IELEM,ICOL,NEL,LL4,NBMIX,IIMAX,XX,
+ 1 YY,DD,MAT,KN,QFR,VOL,MU,LC,R,V,SYS)
+ DEALLOCATE(R,V)
+ ELSE IF((IELEM.LT.0).AND.(ITYPE.EQ.8)) THEN
+* MESH CORNER FINITE DIFFERENCES FOR HEXAGONS
+ CALL LCMSIX(IPTRK,'BIVCOL',1)
+ ALLOCATE(R(2,2),RH(6,6),QH(6,6),RT(3,3),QT(3,3))
+ CALL LCMGET(IPTRK,'R',R)
+ CALL LCMGET(IPTRK,'RH',RH)
+ CALL LCMGET(IPTRK,'QH',QH)
+ CALL LCMGET(IPTRK,'RT',RT)
+ CALL LCMGET(IPTRK,'QT',QT)
+ CALL LCMSIX(IPTRK,' ',2)
+ IF(ISPLH.EQ.1) THEN
+ NELEM=MAXKN/7
+ ELSE
+ NELEM=MAXKN/4
+ ENDIF
+ CALL BIVA03(ITY,MAXKN,MAXQF,SGD,NEL,LL4,ISPLH,NELEM,NBMIX,
+ 1 IIMAX,SIDE,MAT,KN,QFR,VOL,MU,R,RH,QH,RT,QT,SYS)
+ DEALLOCATE(R,RH,QH,RT,QT)
+ ELSE IF((IELEM.GT.0).AND.(ITYPE.EQ.8).AND.(ICOL.EQ.4)) THEN
+* MESH CENTERED FINITE DIFFERENCES FOR HEXAGONS
+ CALL BIVA04(ITY,MAXKN,MAXQF,SGD,NEL,LL4,ISPLH,NBMIX,IIMAX,
+ 1 SIDE,MAT,KN,QFR,VOL,MU,SYS)
+ ELSE IF((IELEM.GT.0).AND.(ITYPE.EQ.8).AND.(NLF.GT.0)) THEN
+* THOMAS-RAVIART-SCHNEIDER METHOD FOR HEXAGONS (SIMPLIFIED PN
+* THEORY)
+ LXH=LX/(3*ISPLH**2)
+ NBLOS=LXH*ISPLH**2
+ ALLOCATE(IPERT(NBLOS))
+ CALL LCMGET(IPTRK,'IPERT',IPERT)
+ CALL LCMSIX(IPTRK,'BIVCOL',1)
+ CALL LCMLEN(IPTRK,'T',LC,ITYLCM)
+ ALLOCATE(R(LC,LC),V(LC,LC-1),H(LC,LC-1))
+ CALL LCMGET(IPTRK,'R',R)
+ CALL LCMGET(IPTRK,'V',V)
+ CALL LCMGET(IPTRK,'H',H)
+ CALL LCMSIX(IPTRK,' ',2)
+ CALL PNDH2E(ITY,IELEM,ICOL,NBLOS,LL4,NBMIX,IIMAX,SIDE,MAT,
+ 1 IPERT,SGD(1,1),KN,QFR,NLF,NVD,NDIM/2,MU,LC,R,V,H,SYS)
+ DEALLOCATE(R,V,H,IPERT)
+ ELSE IF((IELEM.GT.0).AND.(ITYPE.EQ.8)) THEN
+* THOMAS-RAVIART-SCHNEIDER METHOD FOR HEXAGONS (DIFFUSION THEORY)
+ LXH=LX/(3*ISPLH**2)
+ NBLOS=LXH*ISPLH**2
+ ALLOCATE(IPERT(NBLOS))
+ CALL LCMGET(IPTRK,'IPERT',IPERT)
+ CALL LCMSIX(IPTRK,'BIVCOL',1)
+ CALL LCMLEN(IPTRK,'T',LC,ITYLCM)
+ ALLOCATE(R(LC,LC),V(LC,LC-1),H(LC,LC-1))
+ CALL LCMGET(IPTRK,'R',R)
+ CALL LCMGET(IPTRK,'V',V)
+ CALL LCMGET(IPTRK,'H',H)
+ CALL LCMSIX(IPTRK,' ',2)
+ CALL BIVA05(ITY,SGD,IELEM,NBLOS,LL4,NBMIX,IIMAX,SIDE,MAT,IPERT,
+ 1 KN,QFR,MU,LC,R,V,H,SYS)
+ DEALLOCATE(R,V,H,IPERT)
+ ENDIF
+ CALL LCMPPD(IPSYS,TEXT11,IIMAX,2,SYS_PTR)
+ CALL KDRCPU(TK2)
+ IF(IMPX.GT.0) WRITE(6,'(/35H BIVASM: CPU TIME FOR SYSTEM MATRIX,
+ 1 11H ASSEMBLY =,F9.2,3H S.)') TK2-TK1
+*----
+* MATRIX FACTORIZATIONS
+*----
+ IF((ITY.EQ.0).OR.(TEXT11.EQ.'RM')) THEN
+ CALL KDRCPU(TK1)
+ ASS_PTR=LCMARA(IIMAX)
+ CALL C_F_POINTER(ASS_PTR,ASS,(/ IIMAX /))
+ CALL LCMGET(IPSYS,TEXT11,ASS)
+ IF(NLF.EQ.0) THEN
+ CALL ALLDLF(LL4,ASS(1),MU)
+ ELSE
+ IOF=1
+ DO 50 IL=0,NLF-2,2
+ CALL ALLDLF(LL4,ASS(IOF),MU)
+ IOF=IOF+MU(LL4)
+ 50 CONTINUE
+ ENDIF
+ CALL LCMPPD(IPSYS,'I'//TEXT11,IIMAX,2,ASS_PTR)
+ CALL KDRCPU(TK2)
+ IF(IMPX.GT.1) WRITE(6,'(/34H BIVASM: CPU TIME FOR LDLT FACTORI,
+ 1 18HZATION OF MATRIX '',A11,2H''=,F9.2,3H S.)') TEXT11,TK2-TK1
+ ENDIF
+*----
+* RELEASE BIVAC SPECIFIC TRACKING INFORMATION
+*----
+ DEALLOCATE(MU,IQFR,QFR,KN,DD,XX,YY)
+ RETURN
+ END
diff --git a/Trivac/src/BIVCOL.f b/Trivac/src/BIVCOL.f new file mode 100755 index 0000000..733855e --- /dev/null +++ b/Trivac/src/BIVCOL.f @@ -0,0 +1,621 @@ +*DECK BIVCOL + SUBROUTINE BIVCOL (IPTRK,IMPX,IELEM,ICOL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Selection of the unit matrices (mass, stiffness, etc.) for a finite +* element approximation. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK L_TRACK pointer to the tracking information. +* IMPX print parameter. +* IELEM degree of the finite elements: =1: (linear polynomials); +* =2: (parabolic polynomials); =3: (cubic polynomials); +* =4: (quartic polynomials). +* ICOL type of quadrature used to integrate the mass matrices: +* =1: (analytic integration); =2: (Gauss-Lobatto quadrature) +* =3: (Gauss-Legendre quadrature). +* IELEM=1 with ICOL=2 is equivalent to finite differences. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK + INTEGER IMPX,IELEM,ICOL +*---- +* LOCAL VARIABLES +*---- + CHARACTER*40 HTYPE + DOUBLE PRECISION DSUM + REAL EL(2,2),TL(2),TSL(2),RL(2,2),RSL(2,2),QSL(2,2),TSL1(2), + 1 TSL2(2),RL2(2,2),RSL2(2,2) + REAL RHA6(6,6),QHA6(6,6),RHL6(6,6),QHL6(6,6),RTA(3,3),QTA(3,3), + 1 RTL(3,3),QTL(3,3) + REAL EP(3,3),TP(3),TSP(3),RP(3,3),VP(3,2),HP(3,2),RSP(3,3), + 1 QSP(3,3),EP1(3,3),TP1(3),TSP1(3),VP1(3,2),HP1(3,2),QSP1(3,3), + 2 EP2(3,3),TP2(3),TSP2(3),RP2(3,3),VP2(3,2),HP2(3,2),RSP2(3,3), + 3 QSP2(3,3) + REAL EC(4,4),TC(4),TSC(4),RC(4,4),VC(4,3),HC(4,3),RSC(4,4), + 1 QSC(4,4),EC1(4,4),TC1(4),TSC1(4),VC1(4,3),HC1(4,3),QSC1(4,4), + 2 EC2(4,4),TC2(4),TSC2(4),RC2(4,4),VC2(4,3),HC2(4,3),RSC2(4,4), + 3 QSC2(4,4) + REAL EQ(5,5),VQ(5,4),HQ(5,4),TQ(5),TSQ(5),QSQ(5,5) + REAL RLQ(2,2),RLR(2,2),RL1Q(2,2),RL1R(2,2),RL2Q(2,2),RL2R(2,2) +*----------------------------------------------------------------------- +* THE BIVAC REFERENCE ELEMENT IS DEFINED BETWEEN POINTS -1/2 AND +1/2. +* THE COLLOCATION POLYNOMIALS CORRESPONDING TO APPROXIMATIONS LL2$, PL3, +* PL3$, PL3#, CL4, CL4$, CL4# AND QL5$ ARE PARTIALLY OR COMPLETELY +* ORTHONORMALIZED IN ORDER TO PRODUCE A SPARSE MASS MATRIX. +*----------------------------------------------------------------------- +* +******************* FINITE ELEMENT BASIC MATRICES ********************** +* * + REAL T(5),TS(5),R(25),RS(25),Q(25),QS(25),V(20),H(20),E(25), + 1 RH(6,6),QH(6,6),RT(3,3),QT(3,3),R1DQ(4),R1DR(4) +* * +* LC : NUMBER OF POLYNOMIALS IN A COMPLETE 1-D BASIS. * +* T : CARTESIAN LINEAR PRODUCT VECTOR. * +* TS : CYLINDRICAL LINEAR PRODUCT VECTOR. * +* R : CARTESIAN MASS MATRIX. * +* RS : CYLINDRICAL MASS MATRIX. * +* Q : CARTESIAN STIFFNESS MATRIX. * +* QS : CYLINDRICAL STIFFNESS MATRIX. * +* V : NODAL COUPLING MATRIX. * +* H : PIOLAT (HEXAGONAL) COUPLING MATRIX. * +* E : POLYNOMIAL COEFFICIENTS. * +* RH : HEXAGONAL MASS MATRIX. * +* QH : HEXAGONAL STIFFNESS MATRIX. * +* RT : TRIANGULAR MASS MATRIX. * +* QT : TRIANGULAR STIFFNESS MATRIX. * +* R1DQ : SPHERICAL MASS MATRIX. * +* R1DR : SPHERICAL MASS MATRIX. * +* * +************************************************************************ +* +*---- +* LINEAR LAGRANGIAN POLYNOMIALS. +*---- + DATA EL/0.5,-1.0,0.5,1.0/ + DATA TL/0.5,0.5/ + DATA RL/ + $ 0.333333333333, 0.166666666667, 0.166666666667, 0.333333333333/ +* CYLINDRICAL OPTION MATRICES: + DATA TSL/-0.083333333333, 0.083333333333/ + DATA RSL/ + $-0.083333333333, 0.000000000000, 0.000000000000, 0.083333333333/ + DATA QSL/ + $ 0.000000000000, 0.000000000000, 0.000000000000, 0.000000000000/ +* SPHERICAL OPTION MATRICES (ANALYTIC INTEGRATION): + DATA RLQ/-.083333333333, 0.0, 0.0, 0.083333333333/ + DATA RLR/ + $ 0.033333333333, 0.008333333333, 0.008333333333, 0.033333333333/ +* GAUSS-LOBATTO (FINITE DIFFERENCES) MATRICES: + DATA TSL1/-0.25,0.25/ +* SPHERICAL OPTION MATRICES (GAUSS-LOBATTO): + DATA RL1Q/-0.166666666667, 0.0, 0.0, 0.166666666667/ + DATA RL1R/0.041666666667, 0.0, 0.0, 0.041666666667/ +* GAUSS-LEGENDRE (SUPERCONVERGENT) MATRICES: + DATA TSL2/0.0,0.0/ + DATA RL2/0.25,0.25,0.25,0.25/ + DATA RSL2/0.0,0.0,0.0,0.0/ +* SPHERICAL OPTION MATRICES (SUPERCONVERGENT): + DATA RL2Q/ + $ -0.03472222222,-0.0069444444444,-0.0069444444444, 0.048611111111/ + DATA RL2R/ + $ 0.00925925926, 0.0185185185185, 0.0185185185185, 0.037037037037/ +* +* ANALYTIC INTEGRATION FOR HEXAGON AND TRIANGLE. + DATA RHA6/ + > 0.158470 , 0.086580 , 0.036760 , 0.027870 , 0.036760 , 0.086580, + > 0.086580 , 0.158470 , 0.086580 , 0.036760 , 0.027870 , 0.036760, + > 0.036760 , 0.086580 , 0.158470 , 0.086580 , 0.036760 , 0.027870, + > 0.027870 , 0.036760 , 0.086580 , 0.158470 , 0.086580 , 0.036760, + > 0.036760 , 0.027870 , 0.036760 , 0.086580 , 0.158470 , 0.086580, + > 0.086580 , 0.036760 , 0.027870 , 0.036760 , 0.086580 , 0.158470/ + DATA QHA6/ + > 0.760640 ,-0.161980 ,-0.169310 ,-0.098060 ,-0.169310 ,-0.161980, + >-0.161980 , 0.760640 ,-0.161980 ,-0.169310 ,-0.098060 ,-0.169310, + >-0.169310 ,-0.161980 , 0.760640 ,-0.161980 ,-0.169310 ,-0.098060, + >-0.098060 ,-0.169310 ,-0.161980 , 0.760640 ,-0.161980 ,-0.169310, + >-0.169310 ,-0.098060 ,-0.169310 ,-0.161980 , 0.760640 ,-0.161980, + >-0.161980 ,-0.169310 ,-0.098060 ,-0.169310 ,-0.161980 , 0.760640/ + DATA RTA/ + > 1.0, 0.5, 0.5, 0.5, 1.0, 0.5, 0.5, 0.5, 1.0/ + DATA QTA/ + > 1.0,-0.5,-0.5,-0.5, 1.0,-0.5,-0.5,-0.5, 1.0/ +* +* GAUSS-LOBATTO INTEGRATION FOR HEXAGON AND TRIANGLE. + DATA RHL6/ + > 1.000000 , 0.000000 , 0.000000 , 0.000000 , 0.000000 , 0.000000, + > 0.000000 , 1.000000 , 0.000000 , 0.000000 , 0.000000 , 0.000000, + > 0.000000 , 0.000000 , 1.000000 , 0.000000 , 0.000000 , 0.000000, + > 0.000000 , 0.000000 , 0.000000 , 1.000000 , 0.000000 , 0.000000, + > 0.000000 , 0.000000 , 0.000000 , 0.000000 , 1.000000 , 0.000000, + > 0.000000 , 0.000000 , 0.000000 , 0.000000 , 0.000000 , 1.000000/ + DATA QHL6/ + > 1.666667 ,-1.000000 , 0.166667 ,-1.000000 , 0.166667 , 0.000000, + >-1.000000 , 1.666667 ,-1.000000 , 0.166667 , 0.000000 , 0.166667, + > 0.166667 ,-1.000000 , 1.666667 , 0.000000 , 0.166667 ,-1.000000, + >-1.000000 , 0.166667 , 0.000000 , 1.666667 ,-1.000000 , 0.166667, + > 0.166667 , 0.000000 , 0.166667 ,-1.000000 , 1.666667 ,-1.000000, + > 0.000000 , 0.166667 ,-1.000000 , 0.166667 ,-1.000000 , 1.666667/ + DATA RTL/ + > 1.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 1.0/ + DATA QTL/ + > 1.0,-0.5,-0.5,-0.5, 1.0,-0.5,-0.5,-0.5, 1.0/ +*---- +* PARABOLIC LAGRANGIAN POLYNOMIALS. +*---- + DATA EP/ + $-0.125000000000,-1.000000000000, 2.500000000000, + $ 1.250000000000, 0.000000000000,-5.000000000000, + $-0.125000000000, 1.000000000000, 2.500000000000/ + DATA TP/ + $ 0.083333333333, 0.833333333333, 0.083333333333/ + DATA RP/ + $ 0.125000000000, 0.000000000000,-0.041666666667, + $ 0.000000000000, 0.833333333333, 0.000000000000, + $-0.041666666667, 0.000000000000, 0.125000000000/ + DATA VP/ + $-1.000000000000, 0.000000000000, 1.000000000000, + $ 1.443375672974,-2.886751345948, 1.443375672974/ + DATA HP/ + $ 0.083333333333, 0.833333333333, 0.083333333333, + $-0.288675134595, 0.000000000000, 0.288675134595/ +* CYLINDRICAL OPTION MATRICES: + DATA TSP/ + $-0.083333333333, 0.000000000000, 0.083333333333/ + DATA RSP/ + $-0.041666666667,-0.041666666667, 0.000000000000, + $-0.041666666667, 0.000000000000, 0.041666666667, + $ 0.000000000000, 0.041666666667, 0.041666666667/ + DATA QSP/ + $-0.833333333333, 0.833333333333, 0.000000000000, + $ 0.833333333333, 0.000000000000,-0.833333333333, + $ 0.000000000000,-0.833333333333, 0.833333333333/ +* GAUSS-LOBATTO (VARIATIONAL COLLOCATION METHOD) MATRICES: + DATA EP1/0.0,-1.0,2.0,1.0,0.0,-4.0,0.0,1.0,2.0/ + DATA TP1/ + $ 0.166666666667, 0.666666666667, 0.166666666667/ + DATA VP1/ + $-1.000000000000, 0.0000000000000, 1.000000000000, + $ 1.154700538379,-2.3094010767585, 1.154700538379/ + DATA HP1/ + $ 0.166666666667, 0.666666666667, 0.166666666667, + $-0.288675134595, 0.000000000000, 0.288675134595/ +* CYLINDRICAL GAUSS-LOBATTO (VARIATIONAL COLLOCATION METHOD) +* MATRICES. + DATA TSP1/ + $-0.083333333333, 0.000000000000, 0.083333333333/ + DATA QSP1/ + $-0.666666666667, 0.666666666667, 0.000000000000, + $ 0.666666666667, 0.000000000000,-0.666666666667, + $ 0.000000000000,-0.666666666667, 0.666666666667/ +* GAUSS-LEGENDRE (SUPERCONVERGENT) MATRICES: + DATA EP2/ + $-0.250000000000,-1.000000000000, 3.000000000000, + $ 1.500000000000, 0.000000000000,-6.000000000000, + $-0.250000000000, 1.000000000000, 3.000000000000/ + DATA TP2/ + $ 0.000000000000, 1.000000000000, 0.000000000000/ + DATA RP2/ + $ 0.083333333333, 0.000000000000,-0.083333333333, + $ 0.000000000000, 1.000000000000, 0.000000000000, + $-0.083333333333, 0.000000000000, 0.083333333333/ + DATA VP2/ + $-1.000000000000, 0.000000000000, 1.000000000000, + $ 1.732050807569,-3.464101615138, 1.732050807569/ + DATA HP2/ + $ 0.000000000000, 1.000000000000, 0.000000000000, + $-0.288675134595, 0.000000000000, 0.288675134595/ +* CYLINDRICAL GAUSS-LEGENDRE (SUPERCONVERGENT) MATRICES: + DATA TSP2/ + $-0.083333333333, 0.000000000000, 0.083333333333/ + DATA RSP2/ + $ 0.000000000000,-0.083333333333, 0.000000000000, + $-0.083333333333, 0.000000000000, 0.083333333333, + $ 0.000000000000, 0.083333333333, 0.000000000000/ + DATA QSP2/ + $-1.000000000000, 1.000000000000, 0.000000000000, + $ 1.000000000000, 0.000000000000,-1.000000000000, + $ 0.000000000000,-1.000000000000, 1.000000000000/ +*---- +* CUBIC LAGRANGIAN POLYNOMIALS. +*---- + DATA EC/ + $-0.125000000000, 0.750000000000, 2.500000000000, -7.000000000000, + $ 0.625000000000,-3.307189138831,-2.500000000000, 13.228756555323, + $ 0.625000000000, 3.307189138831,-2.500000000000,-13.228756555323, + $-0.125000000000,-0.750000000000, 2.500000000000, 7.000000000000/ + DATA TC/ + $ 0.083333333333, 0.416666666667, 0.416666666667, 0.083333333333/ + DATA RC/ + $ 0.066666666667, 0.000000000000, 0.000000000000, 0.016666666667, + $ 0.000000000000, 0.416666666667, 0.000000000000, 0.000000000000, + $ 0.000000000000, 0.000000000000, 0.416666666667, 0.000000000000, + $ 0.016666666667, 0.000000000000, 0.000000000000, 0.066666666667/ + DATA VC/ + $-1.000000000000, 0.000000000000, 0.000000000000,1.000000000000, + $ 1.443375672974,-1.443375672974,-1.443375672974,1.443375672974, + $-1.565247584250, 2.958039891550,-2.958039891550,1.565247584250/ + DATA HC/ + $ 0.083333333333, 0.416666666667, 0.416666666667, 0.083333333333, + $-0.086602540378,-0.381881307913, 0.381881307913, 0.086602540378, + $ 0.186338998125,-0.186338998125,-0.186338998125, 0.186338998125/ +* CYLINDRICAL OPTION MATRICES: + DATA TSC / + $-0.025000000000,-0.110239637961, 0.110239637961, 0.025000000000/ + DATA RSC/ + $-0.025000000000,-0.015748519709, 0.015748519709, 0.000000000000, + $-0.015748519709,-0.078742598544, 0.000000000000,-0.015748519709, + $ 0.015748519709, 0.000000000000, 0.078742598544, 0.015748519709, + $ 0.000000000000,-0.015748519709, 0.015748519709, 0.025000000000/ + DATA QSC/ + $-2.000000000000, 2.102396379610,-0.102396379610, 0.000000000000, + $ 2.102396379610,-2.204792759220, 0.000000000000, 0.102396379610, + $-0.102396379610, 0.000000000000, 2.204792759220,-2.102396379610, + $ 0.000000000000, 0.102396379610,-2.102396379610, 2.000000000000/ +* GAUSS-LOBATTO (VARIATIONAL COLLOCATION METHOD) MATRICES: + DATA EC1/ + $-0.125000000000, 0.250000000000, 2.500000000000, -5.000000000000, + $ 0.625000000000,-2.795084971875,-2.500000000000, 11.180339887499, + $ 0.625000000000, 2.795084971875,-2.500000000000,-11.180339887499, + $-0.125000000000,-0.250000000000, 2.500000000000, 5.000000000000/ + DATA TC1/ + $ 0.083333333333, 0.416666666667, 0.416666666667, 0.083333333333/ + DATA VC1/ + $-1.000000000000, 0.000000000000, 0.000000000000,1.000000000000, + $ 1.443375672974,-1.443375672974,-1.443375672974,1.443375672974, + $-1.118033988750, 2.500000000000,-2.500000000000,1.118033988750/ + DATA HC1/ + $ 0.083333333333, 0.416666666667, 0.416666666667, 0.083333333333, + $-0.144337567297,-0.322748612184, 0.322748612184, 0.144337567297, + $ 0.186338998125,-0.186338998125,-0.186338998125, 0.186338998125/ +* CYLINDRICAL GAUSS-LOBATTO (VARIATIONAL COLLOCATION METHOD) +* MATRICES: + DATA TSC1/ + $-0.041666666667,-0.093169499062, 0.093169499062, 0.041666666667/ + DATA QSC1/ + $-1.666666666667, 1.765028323958,-0.098361657292, 0.000000000000, + $ 1.765028323958,-1.863389981250, 0.000000000000, 0.098361657292, + $-0.098361657292, 0.000000000000, 1.863389981250,-1.765028323958, + $ 0.000000000000, 0.098361657292,-1.765028323958, 1.666666666667/ +* GAUSS-LEGENDRE (SUPERCONVERGENT) MATRICES: + DATA EC2/ + $-0.125000000000, 1.500000000000, 2.500000000000,-10.000000000000, + $ 0.625000000000,-3.952847075210,-2.500000000000, 15.811388300842, + $ 0.625000000000, 3.952847075210,-2.500000000000,-15.811388300842, + $-0.125000000000,-1.500000000000, 2.500000000000, 10.000000000000/ + DATA TC2/ + $ 0.083333333333, 0.416666666667, 0.416666666667, 0.083333333333/ + DATA RC2/ + $ 0.041666666667, 0.000000000000, 0.000000000000, 0.041666666667, + $ 0.000000000000, 0.416666666667, 0.000000000000, 0.000000000000, + $ 0.000000000000, 0.000000000000, 0.416666666667, 0.000000000000, + $ 0.041666666667, 0.000000000000, 0.000000000000, 0.041666666667/ + DATA VC2/ + $-1.000000000000, 0.000000000000, 0.000000000000,1.000000000000, + $ 1.443375672974,-1.443375672974,-1.443375672974,1.443375672974, + $-2.236067977500, 3.535533905933,-3.535533905933,2.236067977500/ + DATA HC2/ + $ 0.083333333333, 0.416666666667, 0.416666666667, 0.083333333333, + $ 0.000000000000,-0.456435464588, 0.456435464588, 0.000000000000, + $ 0.186338998125,-0.186338998125,-0.186338998125, 0.186338998125/ +* CYLINDRICAL GAUSS-LEGENDRE (SUPERCONVERGENT) MATRICES: + DATA TSC2/ + $ 0.000000000000,-0.131761569174, 0.131761569174, 0.000000000000/ + DATA RSC2/ + $ 0.000000000000,-0.032940392293, 0.032940392293, 0.000000000000, + $-0.032940392293,-0.065880784587, 0.000000000000,-0.032940392293, + $ 0.032940392293, 0.000000000000, 0.065880784587, 0.032940392293, + $ 0.000000000000,-0.032940392293, 0.032940392293, 0.000000000000/ + DATA QSC2/ + $-2.500000000000, 2.567615691737,-0.067615691737, 0.000000000000, + $ 2.567615691737,-2.635231383474, 0.000000000000, 0.067615691737, + $-0.067615691737, 0.000000000000, 2.635231383474,-2.567615691737, + $ 0.000000000000, 0.067615691737,-2.567615691737, 2.500000000000/ +*---- +* QUARTIC LAGRANGIAN POLYNOMIALS. +*---- + DATA EQ/ + $ 0.000000000000, 0.750000000000,-1.500000000000,-7.000000000000, + $ 14.000000000000, 0.000000000000,-2.673169155391, 8.166666666667, + $ 10.692676621564,-32.666666666667, 1.000000000000, 0.000000000000, + $-13.333333333333, 0.000000000000,37.333333333333, 0.000000000000, + $ 2.673169155391,8.166666666667,-10.692676621564,-32.666666666667, + $ 0.000000000000,-0.750000000000,-1.500000000000, 7.000000000000, + $ 14.000000000000/ + DATA TQ/ + $ 0.050000000000, 0.272222222222, 0.355555555556, 0.272222222222, + $ 0.050000000000/ + DATA VQ/ + $-1.000000000000, 0.00000000000, 0.000000000000, 0.00000000000, + $ 1.000000000000, 1.55884572681,-0.943005439677,-1.23168057427, + $-0.943005439677, 1.55884572681,-1.565247584250, 2.39095517873, + $ 0.000000000000,-2.39095517873, 1.565247584250, 1.058300524426, + $-2.46936789032 , 2.8221347318 ,-2.46936789032 , 1.058300524426/ + DATA HQ/ + $ 0.050000000000, 0.272222222222, 0.355555555556, 0.272222222222, + $ 0.050000000000,-0.086602540378,-0.308670986291, 0.000000000000, + $ 0.308670986291, 0.086602540378, 0.111803398875, 0.086958199125, + $-0.397523196000, 0.086958199125, 0.111803398875,-0.132287565553, + $ 0.202072594216, 0.000000000000,-0.202072594216, 0.132287565553/ +* CYLINDRICAL GAUSS-LOBATTO (VARIATIONAL COLLOCATION METHOD) +* MATRICES: + DATA TSQ/ + $-0.025000000000,-0.089105638513, 0.000000000000, 0.089105638513, + $ 0.025000000000/ + DATA QSQ/ + $-3.000000000000, 3.237234826568,-0.266666666667, 0.029431840099, + $ 0.000000000000, 3.237234826568,-4.158263130608, 0.950460144139, + $ 0.000000000000,-0.029431840099,-0.266666666667, 0.950460144139, + $ 0.000000000000,-0.950460144139, 0.266666666667, 0.029431840099, + $ 0.000000000000,-0.950460144139, 4.158263130608,-3.237234826568, + $ 0.000000000000,-0.029431840099, 0.266666666667,-3.237234826568, + $ 3.000000000000/ +* + LC=IELEM+1 + IF((IELEM.EQ.1).AND.(ICOL.EQ.1)) THEN +* LL2 + HTYPE='LINEAR LAGRANGIAN POLYNOMIALS' + DO 20 I=1,LC + T(I)=TL(I) + TS(I)=TSL(I) + DO 10 J=1,LC + R((J-1)*LC+I)=RL(I,J) + RS((J-1)*LC+I)=RSL(I,J) + QS((J-1)*LC+I)=QSL(I,J) + R1DQ((J-1)*LC+I)=RLQ(I,J) + R1DR((J-1)*LC+I)=RLR(I,J) + E((J-1)*LC+I)=EL(I,J) + 10 CONTINUE + 20 CONTINUE + V(1)=-1.0 + V(2)=1.0 + H(1)=0.5 + H(2)=0.5 + DO 40 I=1,6 + DO 30 J=1,6 + RH(I,J)=RHA6(I,J) + QH(I,J)=QHA6(I,J) + 30 CONTINUE + 40 CONTINUE + DO 60 I=1,3 + DO 50 J=1,3 + RT(I,J)=RTA(I,J)*SQRT(3.0)/24.0 + QT(I,J)=QTA(I,J)/SQRT(3.0) + 50 CONTINUE + 60 CONTINUE + ELSE IF((IELEM.EQ.1).AND.(ICOL.EQ.2)) THEN +* LL2$ + HTYPE='FINITE DIFFERENCES' + DO 80 I=1,LC + T(I)=TL(I) + TS(I)=TSL1(I) + DO 70 J=1,LC + R((J-1)*LC+I)=0.0 + RS((J-1)*LC+I)=0.0 + QS((J-1)*LC+I)=QSL(I,J) + R1DQ((J-1)*LC+I)=RL1Q(I,J) + R1DR((J-1)*LC+I)=RL1R(I,J) + E((J-1)*LC+I)=EL(I,J) + 70 CONTINUE + R((I-1)*LC+I)=TL(I) + RS((I-1)*LC+I)=TSL1(I) + 80 CONTINUE + V(1)=-1.0 + V(2)=1.0 + H(1)=0.5 + H(2)=0.5 + DO 100 I=1,6 + DO 90 J=1,6 + RH(I,J)=RHL6(I,J)*SQRT(3.0)/4.0 + QH(I,J)=QHL6(I,J)*SQRT(3.0) + 90 CONTINUE + 100 CONTINUE + DO 120 I=1,3 + DO 110 J=1,3 + RT(I,J)=RTL(I,J)*SQRT(3.0)/12.0 + QT(I,J)=QTL(I,J)/SQRT(3.0) + 110 CONTINUE + 120 CONTINUE + ELSE IF((IELEM.EQ.1).AND.(ICOL.EQ.3)) THEN +* LL2# + HTYPE='SUPERCONVERGENT LINEAR POLYNOMIALS' + DO 140 I=1,LC + T(I)=TL(I) + TS(I)=TSL2(I) + DO 130 J=1,LC + R((J-1)*LC+I)=RL2(I,J) + RS((J-1)*LC+I)=RSL2(I,J) + QS((J-1)*LC+I)=QSL(I,J) + R1DQ((J-1)*LC+I)=RL2Q(I,J) + R1DR((J-1)*LC+I)=RL2R(I,J) + E((J-1)*LC+I)=EL(I,J) + 130 CONTINUE + 140 CONTINUE + V(1)=-1.0 + V(2)=1.0 + H(1)=0.5 + H(2)=0.5 + ELSE IF((IELEM.EQ.2).AND.(ICOL.EQ.1)) THEN +* PL3 + HTYPE='PARABOLIC LAGRANGIAN POLYNOMIALS' + DO 170 I=1,LC + T(I)=TP(I) + TS(I)=TSP(I) + DO 150 J=1,LC-1 + V((J-1)*LC+I)=VP(I,J) + H((J-1)*LC+I)=HP(I,J) + 150 CONTINUE + DO 160 J=1,LC + R((J-1)*LC+I)=RP(I,J) + RS((J-1)*LC+I)=RSP(I,J) + QS((J-1)*LC+I)=QSP(I,J) + E((J-1)*LC+I)=EP(I,J) + 160 CONTINUE + 170 CONTINUE + ELSE IF((IELEM.EQ.2).AND.(ICOL.EQ.2)) THEN +* PL3$ + HTYPE='PARABOLIC COLLOCATION METHOD' + DO 200 I=1,LC + T(I)=TP1(I) + TS(I)=TSP1(I) + DO 180 J=1,LC-1 + V((J-1)*LC+I)=VP1(I,J) + H((J-1)*LC+I)=HP1(I,J) + 180 CONTINUE + DO 190 J=1,LC + R((J-1)*LC+I)=0.0 + RS((J-1)*LC+I)=0.0 + QS((J-1)*LC+I)=QSP1(I,J) + E((J-1)*LC+I)=EP1(I,J) + 190 CONTINUE + R((I-1)*LC+I)=TP1(I) + RS((I-1)*LC+I)=TSP1(I) + 200 CONTINUE + ELSE IF((IELEM.EQ.2).AND.(ICOL.EQ.3)) THEN +* PL3# + HTYPE='PARABOLIC SUPERCONVERGENT POLYNOMIALS' + DO 230 I=1,LC + T(I)=TP2(I) + TS(I)=TSP2(I) + DO 210 J=1,LC-1 + V((J-1)*LC+I)=VP2(I,J) + H((J-1)*LC+I)=HP2(I,J) + 210 CONTINUE + DO 220 J=1,LC + R((J-1)*LC+I)=RP2(I,J) + RS((J-1)*LC+I)=RSP2(I,J) + QS((J-1)*LC+I)=QSP2(I,J) + E((J-1)*LC+I)=EP2(I,J) + 220 CONTINUE + 230 CONTINUE + ELSE IF((IELEM.EQ.3).AND.(ICOL.EQ.1)) THEN +* CL4 + HTYPE='CUBIC LAGRANGIAN POLYNOMIALS' + DO 260 I=1,LC + T(I)=TC(I) + TS(I)=TSC(I) + DO 240 J=1,LC-1 + V((J-1)*LC+I)=VC(I,J) + H((J-1)*LC+I)=HC(I,J) + 240 CONTINUE + DO 250 J=1,LC + R((J-1)*LC+I)=RC(I,J) + RS((J-1)*LC+I)=RSC(I,J) + QS((J-1)*LC+I)=QSC(I,J) + E((J-1)*LC+I)=EC(I,J) + 250 CONTINUE + 260 CONTINUE + ELSE IF((IELEM.EQ.3).AND.(ICOL.EQ.2)) THEN +* CL4$ + HTYPE='CUBIC COLLOCATION METHOD' + DO 290 I=1,LC + T(I)=TC1(I) + TS(I)=TSC1(I) + DO 270 J=1,LC-1 + V((J-1)*LC+I)=VC1(I,J) + H((J-1)*LC+I)=HC1(I,J) + 270 CONTINUE + DO 280 J=1,LC + R((J-1)*LC+I)=0.0 + RS((J-1)*LC+I)=0.0 + QS((J-1)*LC+I)=QSC1(I,J) + E((J-1)*LC+I)=EC1(I,J) + 280 CONTINUE + R((I-1)*LC+I)=TC1(I) + RS((I-1)*LC+I)=TSC1(I) + 290 CONTINUE + ELSE IF((IELEM.EQ.3).AND.(ICOL.EQ.3)) THEN +* CL4# + HTYPE='SUPERCONVERGENT CUBIC POLYNOMIALS' + DO 320 I=1,LC + T(I)=TC2(I) + TS(I)=TSC2(I) + DO 300 J=1,LC-1 + V((J-1)*LC+I)=VC2(I,J) + H((J-1)*LC+I)=HC2(I,J) + 300 CONTINUE + DO 310 J=1,LC + R((J-1)*LC+I)=RC2(I,J) + RS((J-1)*LC+I)=RSC2(I,J) + QS((J-1)*LC+I)=QSC2(I,J) + E((J-1)*LC+I)=EC2(I,J) + 310 CONTINUE + 320 CONTINUE + ELSE IF((IELEM.EQ.4).AND.(ICOL.EQ.2)) THEN +* QL5$ + HTYPE='QUARTIC COLLOCATION METHOD' + DO 350 I=1,LC + T(I)=TQ(I) + TS(I)=TSQ(I) + DO 330 J=1,LC-1 + V((J-1)*LC+I)=VQ(I,J) + H((J-1)*LC+I)=HQ(I,J) + 330 CONTINUE + DO 340 J=1,LC + R((J-1)*LC+I)=0.0 + RS((J-1)*LC+I)=0.0 + QS((J-1)*LC+I)=QSQ(I,J) + E((J-1)*LC+I)=EQ(I,J) + 340 CONTINUE + R((I-1)*LC+I)=TQ(I) + RS((I-1)*LC+I)=TSQ(I) + 350 CONTINUE + ELSE + CALL XABORT('BIVCOL: TYPE OF FINITE ELEMENT NOT AVAILABLE.') + ENDIF +*---- +* COMPUTE THE CARTESIAN STIFFNESS MATRIX FROM THE TENSORIAL PRODUCT OF +* TWO NODAL COUPLING MATRICES. +*---- + DO 380 I=1,LC + DO 370 J=1,LC + DSUM=0.0D0 + DO 360 K=1,LC-1 + DSUM=DSUM+V((K-1)*LC+I)*V((K-1)*LC+J) + 360 CONTINUE + Q((J-1)*LC+I)=REAL(DSUM) + 370 CONTINUE + 380 CONTINUE + IF(IMPX.GT.0) WRITE (6,'(/9H BIVCOL: ,A40)') HTYPE +*---- +* SAVE THE UNIT MATRICES ON LCM. +*---- + CALL LCMSIX(IPTRK,'BIVCOL',1) + CALL LCMPUT(IPTRK,'T',LC,2,T) + CALL LCMPUT(IPTRK,'TS',LC,2,TS) + CALL LCMPUT(IPTRK,'R',LC*LC,2,R) + CALL LCMPUT(IPTRK,'RS',LC*LC,2,RS) + IF(IELEM.EQ.1) THEN + CALL LCMPUT(IPTRK,'RSH1',LC*LC,2,R1DQ) + CALL LCMPUT(IPTRK,'RSH2',LC*LC,2,R1DR) + ENDIF + CALL LCMPUT(IPTRK,'Q',LC*LC,2,Q) + CALL LCMPUT(IPTRK,'QS',LC*LC,2,QS) + CALL LCMPUT(IPTRK,'V',LC*(LC-1),2,V) + CALL LCMPUT(IPTRK,'H',LC*(LC-1),2,H) + CALL LCMPUT(IPTRK,'E',LC*LC,2,E) + IF((IELEM.EQ.1).AND.(ICOL.LE.2)) THEN + CALL LCMPUT(IPTRK,'RH',36,2,RH) + CALL LCMPUT(IPTRK,'QH',36,2,QH) + CALL LCMPUT(IPTRK,'RT',9,2,RT) + CALL LCMPUT(IPTRK,'QT',9,2,QT) + ENDIF + CALL LCMSIX(IPTRK,' ',2) + RETURN + END diff --git a/Trivac/src/BIVDFH.f b/Trivac/src/BIVDFH.f new file mode 100755 index 0000000..9894899 --- /dev/null +++ b/Trivac/src/BIVDFH.f @@ -0,0 +1,204 @@ +*DECK BIVDFH + SUBROUTINE BIVDFH (MAXEV,MAXKN,IMPX,ISPLH,LX,SIDE,NELEM,NUN,IHEX, + 1 NCODE,ICODE,ZCODE,MAT,VOL,IDL,KN,QFR,IQFR,BFR,MUW) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Numbering corresponding to a mesh centered finite difference +* discretization of a 2-D hexagonal geometry. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXEV maximum number of unknowns. +* MAXKN dimension of arrays KN, QFR and BFR. +* IMPX print parameter. +* ISPLH hexagonal mesh-splitting flag: +* =1 for complete hexagons; >1 for triangular mesh-splitting +* into 6*(ISPLH-1)**2 triangles. +* LX number of hexagons. +* SIDE side of an hexagon. +* NCODE type of boundary condition applied on each side +* (i=1: X- i=2: X+ i=3: Y- i=4: Y+): +* NCODE(I)=1: VOID; NCODE(I)=2: REFL; NCODE(I)=5: SYME; +* NCODE(I)=7: ZERO. +* ICODE physical albedo index on each side of the domain. +* ZCODE albedo corresponding to boundary condition 'VOID' on each +* side (ZCODE(I)=0.0 by default). +* MAT mixture index assigned to each hexagon. +* IHEX type of hexagonal boundary condition. +* +*Parameters: output +* NELEM order of the system matrices (number of elements). +* NUN number of unknowns per energy group. +* VOL volume of each hexagon. +* KN element-ordered unknown list. +* QFR element-ordered boundary conditions. +* IQFR element-ordered physical albedo indices. +* BFR element-ordered surface fractions. +* MUW compressed storage mode indices. +* IDL position of the average flux component associated with each +* hexagon. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MAXEV,MAXKN,IMPX,ISPLH,LX,NELEM,NUN,IHEX,NCODE(4), + 1 ICODE(4),MAT(LX),IDL(LX),KN(MAXKN),IQFR(MAXKN),MUW(NELEM) + REAL SIDE,ZCODE(4),VOL(LX),QFR(MAXKN),BFR(MAXKN) +* + ALB(X)=0.5*(1.0-X)/(1.0+X) +* + IF(IMPX.GT.0) WRITE(6,500) + CALL BIVSBH (MAXEV,MAXKN,IMPX,ISPLH,LX,SIDE,NELEM,IHEX,NCODE,MAT, + 1 VOL,KN,QFR) +*---- +* PRODUCE STANDARD MESH CENTERED FINITE DIFFERENCE NUMBERING. +*---- + IF(ISPLH.EQ.1) THEN + NSURF=6 + ELSE + NSURF=3 + ENDIF + SURFTOT=0.0 + NUM1=0 + DO 200 KX=1,NELEM + DO 190 IC=1,NSURF + N1=ABS(KN(NUM1+IC)) + IF(N1.GT.NELEM) THEN + IF(NCODE(1).EQ.1) THEN + N1=-1 + ELSE IF(NCODE(1).EQ.2) THEN + N1=-2 + ELSE IF(NCODE(1).EQ.7) THEN + N1=-3 + ENDIF + ELSE IF(N1.EQ.KX) THEN + N1=-2 + ENDIF + KN(NUM1+IC)=N1 +*---- +* PROCESS BOUNDARY CONDITIONS. +*---- + IF(NSURF.EQ.6) THEN + BFR(NUM1+IC)=QFR(NUM1+IC)*QFR(NUM1+7)/(1.5*SQRT(3.0)*SIDE) + IF((NCODE(1).EQ.1).AND.(ICODE(1).EQ.0))THEN + QFR(NUM1+IC)=ALB(ZCODE(1))*QFR(NUM1+IC) + ELSE IF(NCODE(1).NE.1) THEN + QFR(NUM1+IC)=0.0 + ENDIF + ELSE + AA=SIDE/REAL(ISPLH-1) + BFR(NUM1+IC)=QFR(NUM1+IC)*QFR(NUM1+4)/(0.25*SQRT(3.0)*AA) + IF((NCODE(1).EQ.1).AND.(ICODE(1).EQ.0))THEN + QFR(NUM1+IC)=ALB(ZCODE(1))*QFR(NUM1+IC) + ELSE IF(NCODE(1).NE.1) THEN + QFR(NUM1+IC)=0.0 + ENDIF + ENDIF + IQFR(NUM1+IC)=ICODE(1) + SURFTOT=SURFTOT+BFR(NUM1+IC) + 190 CONTINUE + NUM1=NUM1+NSURF+1 + 200 CONTINUE +*---- +* COMPUTE THE SURFACE FRACTIONS. +*---- + IF(SURFTOT.GT.0.0) THEN + DO 210 I=1,NUM1 + BFR(I)=BFR(I)/SURFTOT + 210 CONTINUE + ENDIF +* + IF((IMPX.GT.1).AND.(NSURF.EQ.6)) THEN + WRITE(6,510) + NUM1=0 + DO 220 I=1,NELEM + WRITE(6,520) I,KN(NUM1+7),(KN(NUM1+J),J=1,6),(QFR(NUM1+J), + 1 J=1,7) + NUM1=NUM1+7 + 220 CONTINUE + NUM1=0 + WRITE (6,580) + DO 225 I=1,NELEM + IF(MAT(I).LE.0) GO TO 225 + WRITE (6,590) I,(BFR(NUM1+J),J=1,6) + NUM1=NUM1+7 + 225 CONTINUE + ELSE IF((IMPX.GT.1).AND.(NSURF.EQ.3)) THEN + WRITE(6,530) + NUM1=0 + DO 230 I=1,NELEM + WRITE(6,540) I,KN(NUM1+4),(KN(NUM1+J),J=1,3),(QFR(NUM1+J), + 1 J=1,4),(BFR(NUM1+J),J=1,3) + NUM1=NUM1+4 + 230 CONTINUE + ENDIF + IF(IMPX.GT.0) WRITE(6,570) NELEM +*---- +* COMPUTE THE SYSTEM MATRIX BANDWIDTH. +*---- + DO 240 I=1,NELEM + MUW(I)=1 + 240 CONTINUE + NUM1=0 + DO 260 INW1=1,NELEM + DO 250 I=1,NSURF + IF(KN(NUM1+I).GT.0) THEN + INW2=KN(NUM1+I) + IF(INW2.LT.INW1) THEN + MUW(INW1)=MAX(MUW(INW1),INW1-INW2+1) + ENDIF + ENDIF + 250 CONTINUE + NUM1=NUM1+NSURF+1 + 260 CONTINUE + IIMAX=0 + DO 270 I=1,NELEM + IIMAX=IIMAX+MUW(I) + MUW(I)=IIMAX + 270 CONTINUE + IF(IMPX.GT.6) WRITE(6,550) 'MUW :',(MUW(I),I=1,NELEM) + IF(IMPX.GT.2) WRITE(6,560) IIMAX +*---- +* APPEND THE AVERAGED FLUXES AT THE END OF UNKNOWN VECTOR. +*---- + NUN=0 + IF(ISPLH.GT.1) NUN=NELEM + DO 280 I=1,LX + IF(MAT(I).EQ.0) THEN + IDL(I)=0 + ELSE + NUN=NUN+1 + IDL(I)=NUN + ENDIF + 280 CONTINUE + RETURN +* + 500 FORMAT(//52H BIVDFH: NUMBERING FOR A MESH CENTERED FINITE DIFFER, + 1 42HENCE DISCRETIZATION IN HEXAGONAL GEOMETRY.) + 510 FORMAT(/31H BIVDFH: NUMBERING OF UNKNOWNS./1X,30(1H-)/9X, + 1 7HHEXAGON,3X,9HNEIGHBOUR,28X,23HVOID BOUNDARY CONDITION,15X, + 2 6HVOLUME) + 520 FORMAT (1X,2I6,2X,6I6,2X,6F6.2,5X,1P,E13.6) + 530 FORMAT(/31H BIVDFH: NUMBERING OF UNKNOWNS./1X,30(1H-)/9X, + 1 7HHEXAGON,3X,8HUNKNOWNS,11X,23HVOID BOUNDARY CONDITION,12X, + 2 6HVOLUME,13X,16HSURFACE FRACTION) + 540 FORMAT (1X,2I6,2X,3I6,2X,1P,3E11.2,5X,E13.6,5X,3E10.2) + 550 FORMAT(/1X,A5/(1X,20I6)) + 560 FORMAT(/52H NUMBER OF TERMS IN THE COMPRESSED SYSTEM MATRICES =, + > I6) + 570 FORMAT(/39H BIVDFH: NUMBER OF UNKNOWNS PER GROUP =,I6/) + 580 FORMAT (//17H SURFACE FRACTION//8H HEXAGON,5X,3HBFR) + 590 FORMAT (3X,I4,4X,1P,6E10.2) + END diff --git a/Trivac/src/BIVDKN.f b/Trivac/src/BIVDKN.f new file mode 100755 index 0000000..ac927d4 --- /dev/null +++ b/Trivac/src/BIVDKN.f @@ -0,0 +1,405 @@ +*DECK BIVDKN + SUBROUTINE BIVDKN (MAXEV,IMPX,LX,LY,CYLIND,IELEM,ICOL,L4,NCODE, + 1 ICODE,ZCODE,MAT,VOL,XXX,YYY,XX,YY,DD,KN,QFR,IQFR,BFR,IDL,MU) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Numbering corresponding to a mixed-dual formulation of the finite- +* element discretization in a 2-D geometry. This version does not +* support diagonal symmetries. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXEV allocated storage for vector MU. +* IMPX print parameter. +* LX number of elements along the X axis. +* LY number of elements along the Y axis. +* CYLIND cylinderization flag (=.true. for cylindrical geometry) +* IELEM degree of the Lagrangian finite elements: =1 (linear); +* =2 (parabolic); =3 (cubic); =4 (quartic). +* ICOL type of quadrature: =1 (analytical integration); +* =2 (Gauss-Lobatto); =3 (Gauss-Legendre). +* NCODE type of boundary condition applied on each side +* (i=1: X- i=2: X+ i=3: Y- i=4: Y+): +* NCODE(I)=1: VOID; NCODE(I)=2: REFL; NCODE(I)=4: TRAN; +* NCODE(I)=5: SYME; NCODE(I)=7: ZERO. +* ICODE physical albedo index on each side of the domain. +* ZCODE ZCODE(I) is the albedo corresponding to boundary condition +* 'VOID' on each side (ZCODE(I)=0.0 by default). +* MAT mixture index assigned to each element. +* XXX Cartesian coordinates along the X axis. +* YYY Cartesian coordinates along the Y axis. +* +*Parameters: output +* L4 total number of unknown (variational coefficients) per +* energy group (order of system matrices). +* VOL volume of each element. +* XX X-directed mesh spacings. +* YY Y-directed mesh spacings. +* DD value used with a cylindrical geometry. +* KN element-ordered unknown list. +* QFR element-ordered boundary conditions. +* IQFR element-ordered physical albedo indices. +* BFR element-ordered surface fractions. +* IDL position of integrated fluxes into unknown vector. +* MU compressed storage mode indices. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MAXEV,IMPX,LX,LY,IELEM,ICOL,L4,NCODE(4),ICODE(4), + 1 MAT(LX*LY),KN(5*LX*LY),IQFR(4*LX*LY),IDL(LX*LY),MU(MAXEV) + REAL ZCODE(4),VOL(LX*LY),XXX(LX+1),YYY(LY+1),XX(LX*LY),YY(LX*LY), + 1 DD(LX*LY),QFR(4*LX*LY),BFR(4*LX*LY) + LOGICAL CYLIND +*---- +* LOCAL VARIABLES +*---- + LOGICAL COND,LOG1,LOG2,LOG3,LOG4 + CHARACTER TEXT8*8 + REAL ZALB(4) + INTEGER, DIMENSION(:), ALLOCATABLE :: IP +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IP(MAXEV)) +*---- +* IDENTIFICATION OF THE GEOMETRY. MAIN LOOP OVER THE ELEMENTS. +*---- + DO 10 I=1,4 + IF(ZCODE(I).NE.1.0) THEN + ZALB(I)=2.0*(1.0+ZCODE(I))/(1.0-ZCODE(I)) + ELSE + ZALB(I)=1.0E20 + ENDIF + 10 CONTINUE + IF(IMPX.GT.0) WRITE(6,700) LX,LY + KN(:5*LX*LY)=0 + SURFTOT=0.0 + NUM1=0 + NUM2=0 + KEL=0 + DO 151 K1=1,LY + DO 150 K2=1,LX + KEL=KEL+1 + XX(KEL)=0.0 + YY(KEL)=0.0 + VOL(KEL)=0.0 + IF(MAT(KEL).EQ.0) GO TO 150 + XX(KEL)=XXX(K2+1)-XXX(K2) + YY(KEL)=YYY(K1+1)-YYY(K1) + IF(CYLIND) DD(KEL)=0.5*(XXX(K2)+XXX(K2+1)) + IND1=(K1-1)*(3*LX+1) + KN(NUM1+1)=IND1+LX+2*K2 + KN(NUM1+2)=IND1+LX+2*K2-1 + KN(NUM1+3)=IND1+LX+2*K2+1 + KN(NUM1+4)=IND1+K2 + KN(NUM1+5)=IND1+3*LX+K2+1 + QFR(NUM2+1:NUM2+4)=0.0 + IQFR(NUM2+1:NUM2+4)=0 + BFR(NUM2+1:NUM2+4)=0.0 + FRX=1.0 + FRY=1.0 +*---- +* VOID, REFL OR ZERO BOUNDARY CONTITION. +*---- + IF(K2.EQ.1) THEN + LOG1=.TRUE. + ELSE + LOG1=(MAT(KEL-1).EQ.0) + ENDIF + IF(LOG1) THEN + COND=(NCODE(1).EQ.2).OR.((NCODE(1).EQ.1).AND.(ZCODE(1).EQ.1.0)) + IF(COND) THEN + KN(NUM1+2)=0 + ELSE IF(NCODE(1).EQ.1) THEN + IF(ICODE(1).EQ.0) THEN + QFR(NUM2+1)=ZALB(1) + ELSE + QFR(NUM2+1)=1.0 + IQFR(NUM2+1)=ICODE(1) + ENDIF + ENDIF + ENDIF +* + IF(K2.EQ.LX) THEN + LOG2=.TRUE. + ELSE + LOG2=(MAT(KEL+1).EQ.0) + ENDIF + IF(LOG2) THEN + COND=(NCODE(2).EQ.2).OR.((NCODE(2).EQ.1).AND.(ZCODE(2).EQ.1.0)) + IF(COND) THEN + KN(NUM1+3)=0 + ELSE IF(NCODE(2).EQ.1) THEN + IF(ICODE(2).EQ.0) THEN + QFR(NUM2+2)=ZALB(2) + ELSE + QFR(NUM2+2)=1.0 + IQFR(NUM2+2)=ICODE(2) + ENDIF + ENDIF + ENDIF +* + IF(K1.EQ.1) THEN + LOG3=.TRUE. + ELSE + LOG3=(MAT(KEL-LX).EQ.0) + ENDIF + IF(LOG3) THEN + COND=(NCODE(3).EQ.2).OR.((NCODE(3).EQ.1).AND.(ZCODE(3).EQ.1.0)) + IF(COND) THEN + KN(NUM1+4)=0 + ELSE IF(NCODE(3).EQ.1) THEN + IF(ICODE(3).EQ.0) THEN + QFR(NUM2+3)=ZALB(3) + ELSE + QFR(NUM2+3)=1.0 + IQFR(NUM2+3)=ICODE(3) + ENDIF + ENDIF + ENDIF +* + IF(K1.EQ.LY) THEN + LOG4=.TRUE. + ELSE + LOG4=(MAT(KEL+LX).EQ.0) + ENDIF + IF(LOG4) THEN + COND=(NCODE(4).EQ.2).OR.((NCODE(4).EQ.1).AND.(ZCODE(4).EQ.1.0)) + IF(COND) THEN + KN(NUM1+5)=0 + ELSE IF(NCODE(4).EQ.1) THEN + IF(ICODE(4).EQ.0) THEN + QFR(NUM2+4)=ZALB(4) + ELSE + QFR(NUM2+4)=1.0 + IQFR(NUM2+4)=ICODE(4) + ENDIF + ENDIF + ENDIF +*---- +* TRAN BOUNDARY CONDITION. +*---- + IF((K2.EQ.LX).AND.(NCODE(2).EQ.4)) THEN + KN(NUM1+3)=KN(NUM1+3)-2*LX + ENDIF + IF((K1.EQ.LY).AND.(NCODE(4).EQ.4)) THEN + KN(NUM1+5)=K2 + ENDIF +*---- +* SYME BOUNDARY CONDITION. +*---- + IF((NCODE(1).EQ.5).AND.(K2.EQ.1)) THEN + QFR(NUM2+1)=QFR(NUM2+2) + IQFR(NUM2+1)=IQFR(NUM2+2) + FRX=0.5 + KN(NUM1+2)=-KN(NUM1+3) + ELSE IF((NCODE(2).EQ.5).AND.(K2.EQ.LX)) THEN + QFR(NUM2+2)=QFR(NUM2+1) + IQFR(NUM2+2)=IQFR(NUM2+1) + FRX=0.5 + KN(NUM1+3)=-KN(NUM1+2) + ENDIF + IF((NCODE(3).EQ.5).AND.(K1.EQ.1)) THEN + QFR(NUM2+3)=QFR(NUM2+4) + FRY=0.5 + KN(NUM1+4)=-KN(NUM1+5) + ELSE IF((NCODE(4).EQ.5).AND.(K1.EQ.LY)) THEN + QFR(NUM2+4)=QFR(NUM2+3) + IQFR(NUM2+4)=IQFR(NUM2+3) + FRY=0.5 + KN(NUM1+5)=-KN(NUM1+4) + ENDIF +* + VOL0=XX(KEL)*YY(KEL)*FRX*FRY + IF(CYLIND) THEN + VOL0=6.2831853072*DD(KEL)*VOL0 + ENDIF + VOL(KEL)=VOL0 + QFR(NUM2+1)=QFR(NUM2+1)*VOL0/XX(KEL) + QFR(NUM2+2)=QFR(NUM2+2)*VOL0/XX(KEL) + QFR(NUM2+3)=QFR(NUM2+3)*VOL0/YY(KEL) + QFR(NUM2+4)=QFR(NUM2+4)*VOL0/YY(KEL) +* + IF(((NCODE(1).EQ.1).OR.(NCODE(1).EQ.7)).AND.LOG1) + 1 BFR(NUM2+1)=VOL0/XX(KEL) + IF(((NCODE(2).EQ.1).OR.(NCODE(2).EQ.7)).AND.LOG2) + 1 BFR(NUM2+2)=VOL0/XX(KEL) + IF(((NCODE(3).EQ.1).OR.(NCODE(3).EQ.7)).AND.LOG3) + 1 BFR(NUM2+3)=VOL0/YY(KEL) + IF(((NCODE(4).EQ.1).OR.(NCODE(4).EQ.7)).AND.LOG4) + 1 BFR(NUM2+4)=VOL0/YY(KEL) + SURFTOT=SURFTOT+BFR(NUM2+1)+BFR(NUM2+2)+BFR(NUM2+3)+BFR(NUM2+4) + NUM1=NUM1+5 + NUM2=NUM2+4 + 150 CONTINUE + 151 CONTINUE +* END OF THE MAIN LOOP OVER ELEMENTS. +* +* COMPUTE THE SURFACE FRACTIONS. + IF(SURFTOT.GT.0.0) THEN + DO 155 I=1,4*LX*LY + BFR(I)=BFR(I)/SURFTOT + 155 CONTINUE + ENDIF +*---- +* REMOVING THE UNUSED UNKNOWNS INDICES FROM KN. +*---- + LL4=LY*(3*LX+1)+LX + WRITE (TEXT8,'(I8)') LL4 + IF(LL4.GT.MAXEV) CALL XABORT('BIVDKN: MAXEV SHOULD BE INCREASED ' + 1 //'TO'//TEXT8//'.') + DO 160 IND=1,LL4 + IP(IND)=0 + 160 CONTINUE + DO 170 NUM1=1,5*LX*LY + IF(KN(NUM1).NE.0) IP(ABS(KN(NUM1)))=1 + 170 CONTINUE + L4=0 + DO 180 IND=1,LL4 + IF(IP(IND).EQ.1) THEN + L4=L4+1 + IP(IND)=L4 + ENDIF + 180 CONTINUE + DO 190 NUM1=1,5*LX*LY + IF(KN(NUM1).NE.0) KN(NUM1)=SIGN(IP(ABS(KN(NUM1))),KN(NUM1)) + 190 CONTINUE +*---- +* PROCESS CASES WITH IELEM.GT.1. +*---- + IF(IELEM.GT.1) THEN + LL4=0 + DO 220 IND=1,L4 + IP(IND)=LL4+1 + NUM1=0 + DO 210 KEL=1,LX*LY + IF(MAT(KEL).EQ.0) GO TO 210 + IF(ABS(KN(NUM1+1)).EQ.IND) THEN + LL4=LL4+IELEM**2 + GO TO 220 + ELSE + DO 200 I=2,5 + IF(ABS(KN(NUM1+I)).EQ.IND) THEN + LL4=LL4+IELEM + GO TO 220 + ENDIF + 200 CONTINUE + ENDIF + NUM1=NUM1+5 + 210 CONTINUE + CALL XABORT('BIVDKN: FAILURE OF THE RENUMBERING ALGORITHM.') + 220 CONTINUE + L4=LL4 + DO 230 NUM1=1,5*LX*LY + IF(KN(NUM1).NE.0) KN(NUM1)=SIGN(IP(ABS(KN(NUM1))),KN(NUM1)) + 230 CONTINUE + ENDIF + NUM1=0 + DO 235 KEL=1,LX*LY + IDL(KEL)=0 + IF(MAT(KEL).EQ.0) GO TO 235 + IDL(KEL)=KN(NUM1+1) + NUM1=NUM1+5 + 235 CONTINUE + WRITE (TEXT8,'(I8)') L4 + IF(L4.GT.MAXEV) CALL XABORT('BIVDKN: MAXEV SHOULD BE INCREASED TO' + 1 //TEXT8//'.') + IF(IMPX.GT.2) WRITE(6,710) (VOL(I),I=1,LX*LY) +*---- +* COMPUTE THE SYSTEM MATRIX BANDWIDTH. +*---- + DO 240 I=1,L4 + MU(I)=1 + 240 CONTINUE + NUM1=0 + DO 270 KEL=1,LX*LY + IF(MAT(KEL).EQ.0) GO TO 270 + DO 260 I0=1,IELEM + INX1=ABS(KN(NUM1+2))+I0-1 + INX2=ABS(KN(NUM1+3))+I0-1 + INY1=ABS(KN(NUM1+4))+I0-1 + INY2=ABS(KN(NUM1+5))+I0-1 + DO 250 J0=1,IELEM + JND1=KN(NUM1+1)+(I0-1)*IELEM+J0-1 + IF(IELEM.GE.4) MU(JND1)=MAX(MU(JND1),J0) + IF(KN(NUM1+2).NE.0) THEN + MU(JND1)=MAX(MU(JND1),JND1-INX1+1) + MU(INX1)=MAX(MU(INX1),INX1-JND1+1) + ENDIF + IF(KN(NUM1+3).NE.0) THEN + MU(INX2)=MAX(MU(INX2),INX2-JND1+1) + MU(JND1)=MAX(MU(JND1),JND1-INX2+1) + ENDIF + JND1=KN(NUM1+1)+(J0-1)*IELEM+I0-1 + IF(IELEM.GE.4) MU(JND1)=MAX(MU(JND1),(J0-1)*IELEM+1) + IF(KN(NUM1+4).NE.0) THEN + MU(JND1)=MAX(MU(JND1),JND1-INY1+1) + MU(INY1)=MAX(MU(INY1),INY1-JND1+1) + ENDIF + IF(KN(NUM1+5).NE.0) THEN + MU(INY2)=MAX(MU(INY2),INY2-JND1+1) + MU(JND1)=MAX(MU(JND1),JND1-INY2+1) + ENDIF + 250 CONTINUE + IF(ICOL.NE.2) THEN + IF((KN(NUM1+2).NE.0).AND.(KN(NUM1+3).NE.0)) THEN + MU(INX2)=MAX(MU(INX2),INX2-INX1+1) + MU(INX1)=MAX(MU(INX1),INX1-INX2+1) + ENDIF + IF((KN(NUM1+4).NE.0).AND.(KN(NUM1+5).NE.0)) THEN + MU(INY2)=MAX(MU(INY2),INY2-INY1+1) + MU(INY1)=MAX(MU(INY1),INY1-INY2+1) + ENDIF + ENDIF + 260 CONTINUE + NUM1=NUM1+5 + 270 CONTINUE + IIMAX=0 + DO 280 I=1,L4 + IIMAX=IIMAX+MU(I) + MU(I)=IIMAX + 280 CONTINUE +* + IF(IMPX.GT.2) THEN + WRITE (6,720) IIMAX + NUM1=0 + NUM2=0 + WRITE (6,750) + DO 500 K=1,LX*LY + IF(MAT(K).EQ.0) GO TO 500 + WRITE (6,755) K,(KN(NUM1+I),I=1,5),(QFR(NUM2+I),I=1,4), + 1 (BFR(NUM2+I),I=1,4) + NUM1=NUM1+5 + NUM2=NUM2+4 + 500 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IP) + RETURN +* + 700 FORMAT(/42H BIVDKN: MIXED-DUAL FINITE ELEMENT METHOD.//7H NUMBER, + 1 27H OF ELEMENTS ALONG X AXIS =,I3/26H NUMBER OF ELEMENTS ALONG , + 2 8HY AXIS =,I3) + 710 FORMAT(/20H VOLUMES PER ELEMENT/(1X,1P,10E13.4)) + 720 FORMAT(/52H NUMBER OF TERMS IN THE COMPRESSED SYSTEM MATRICES =, + 1 I7) + 750 FORMAT(/22H NUMBERING OF UNKNOWNS/1X,21(1H-)// + 1 8H ELEMENT,2X,7HNUMBERS,30X,23HVOID BOUNDARY CONDITION,23X, + 2 17HSURFACE FRACTIONS) + 755 FORMAT (1X,I4,2X,5I7,2X,1P,4E11.2,3X,4E10.2) + END diff --git a/Trivac/src/BIVPER.f b/Trivac/src/BIVPER.f new file mode 100755 index 0000000..f4ba1bc --- /dev/null +++ b/Trivac/src/BIVPER.f @@ -0,0 +1,96 @@ +*DECK BIVPER + SUBROUTINE BIVPER (JP,IDIR,LX,LT4,IP,IENV) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the permutation vectors in 2-D hexagonal geometry. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Benaboud +* +*Parameters: input +* JP first index. +* IDIR choice of direction (=1: W axis ; =2: X axis ; =3: Y axis). +* LX number of hexagons, including virtual hexagons. +* LT4 number of non virtual hexagons. +* IENV index of non virtual hexagon corresponding to each hexagon. +* +*Parameters: output +* IP permutation vector. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER JP,IDIR,LX,LT4,IP(LX),IENV(LX) +*---- +* LOCAL VARIABLES +*---- + LOGICAL LPAS +* + LPAS = .TRUE. + DO 10 I=1,LT4 + IP(I)=0 + 10 CONTINUE + NC = INT((SQRT(REAL((4*LX-1)/3))+1.)/2.) + IFACE1 = 0 + IFACE2 = 0 + IFACE3 = 0 + IF(IDIR.EQ.1) THEN + IFACE1 = 3 + IFACE2 = 5 + IFACE3 = 4 + ELSE IF(IDIR.EQ.2) THEN + IFACE1 = 4 + IFACE2 = 6 + IFACE3 = 5 + ELSE IF(IDIR.EQ.3) THEN + IFACE1 = 5 + IFACE2 = 1 + IFACE3 = 6 + ELSE IF(IDIR.EQ.5) THEN + IFACE1 = 1 + IFACE2 = 3 + IFACE3 = 2 + ELSE + CALL XABORT('BIVPER: INVALID DATA') + ENDIF + JI = JP + JS = JP + KEL = 0 + M = JI + 1 + IF(IENV(JI).GT.0) THEN + IP(IENV(JI)) = 1 + KEL = KEL + 1 + ENDIF + IC = JP + NC - 1 + 20 IF(KEL.EQ.LT4) RETURN + IF(JI.EQ.IC) IFACE2 = IDIR + 3 + 30 IF(M.LE.LX) THEN + IF(IENV(M).GT.0) THEN + KEL = KEL + 1 + IP(IENV(M)) = KEL + ENDIF + JI = M + M = NEIGHB(JI,IFACE1,9,LX,POIDS) + GOTO 30 + ELSE + 40 JI = NEIGHB(JS,IFACE2,9,LX,POIDS) + IF(JI.GT.LX.AND.LPAS) THEN + IFACE2 = IFACE3 + LPAS = .FALSE. + GO TO 40 + ENDIF + M = JI + JS = JI + GOTO 20 + ENDIF + END diff --git a/Trivac/src/BIVPKN.f b/Trivac/src/BIVPKN.f new file mode 100755 index 0000000..2856652 --- /dev/null +++ b/Trivac/src/BIVPKN.f @@ -0,0 +1,523 @@ +*DECK BIVPKN + SUBROUTINE BIVPKN (MAXEV,IMPX,LX,LY,CYLIND,IELEM,L4,NCODE,ICODE, + 1 ZCODE,MAT,VOL,XXX,YYY,XX,YY,DD,KN,QFR,IQFR,BFR,MU) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Numbering corresponding to a mesh corner finite difference or primal +* finite element discretization in a 2-D geometry. This version does +* not support diagonal symmetries. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXEV allocated storage for vector MU. +* IMPX print parameter. +* LX number of elements along the X axis. +* LY number of elements along the Y axis. +* CYLIND cylinderization flag (=.true. for cylindrical geometry) +* IELEM degree of the Lagrangian finite elements: =1 (linear); +* =2 (parabolic); =3 (cubic); =4 (quartic). +* NCODE type of boundary condition applied on each side +* (i=1: X- i=2: X+ i=3: Y- i=4: Y+): +* NCODE(I)=1: VOID; NCODE(I)=2: REFL; NCODE(I)=4: TRAN; +* NCODE(I)=5: SYME; NCODE(I)=7: ZERO. +* ICODE physical albedo index on each side of the domain. +* ZCODE albedo corresponding to boundary condition 'VOID' on +* each side (ZCODE(I)=0.0 by default). +* MAT mixture index assigned to each element. +* XXX Cartesian coordinates along the X axis. +* YYY Cartesian coordinates along the Y axis. +* +*Parameters: output +* L4 total number of unknown (variational coefficients) per +* energy group (order of system matrices). +* VOL volume of each element. +* XX X-directed mesh spacings. +* YY Y-directed mesh spacings. +* DD values used with a cylindrical geometry. +* KN element-ordered unknown list. +* QFR element-ordered boundary conditions. +* IQFR element-ordered physical albedo indices. +* BFR element-ordered surface fractions. +* MU compressed storage mode indices. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MAXEV,IMPX,LX,LY,IELEM,L4,NCODE(4),ICODE(4),MAT(LX*LY), + 1 KN(LX*LY*IELEM*IELEM),IQFR(4*LX*LY),MU(MAXEV) + REAL ZCODE(4),VOL(LX*LY),XXX(LX+1),YYY(LY+1),XX(LX*LY),YY(LX*LY), + 1 DD(LX*LY),QFR(4*LX*LY),BFR(4*LX*LY) + LOGICAL CYLIND +*---- +* LOCAL VARIABLES +*---- + LOGICAL LOG1,LOG2,LOG3,LOG4 + INTEGER, DIMENSION(:), ALLOCATABLE :: IP,IWRK +* + ALB(X)=0.5*(1.0-X)/(1.0+X) +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IP((IELEM*LX+1)*(IELEM*LY+1))) + ALLOCATE(IWRK((IELEM*LX+1)*(IELEM*LY+1))) +*---- +* IDENTIFICATION OF THE GEOMETRY. MAIN LOOP OVER THE ELEMENTS. +*---- + IF(IMPX.GT.0) WRITE(6,700) LX,LY + LC=1+IELEM + LL=LC*LC + IX=LX*(LC-1)+1 + IXY=(LY*(LC-1)+1)*IX + SURFTOT=0.0 + NUM1=0 + NUM2=0 + KEL=0 + DO 151 K1=1,LY + DO 150 K2=1,LX + KEL=KEL+1 + XX(KEL)=0.0 + YY(KEL)=0.0 + VOL(KEL)=0.0 + IF(MAT(KEL).LE.0) GO TO 150 + XX(KEL)=XXX(K2+1)-XXX(K2) + YY(KEL)=YYY(K1+1)-YYY(K1) + IF(CYLIND) DD(KEL)=0.5*(XXX(K2)+XXX(K2+1)) + IND1=(LC-1)*((K1-1)*IX+(K2-1)) + L=0 + DO 15 I=1,LC + DO 10 J=1,LC + L=L+1 + KN(NUM1+L)=IND1+(I-1)*IX+J + 10 CONTINUE + 15 CONTINUE + DO 20 IC=1,4 + QFR(NUM2+IC)=0.0 + IQFR(NUM2+IC)=0 + BFR(NUM2+IC)=0.0 + 20 CONTINUE + KK1=KEL-1 + KK2=KEL+1 + KK3=KEL-LX + KK4=KEL+LX + FRX=1.0 + FRY=1.0 +*---- +* VOID, REFL OR ZERO BOUNDARY CONDITION. +*---- + IF(K2.EQ.1) THEN + LOG1=.TRUE. + ELSE + LOG1=(MAT(KK1).EQ.0) + ENDIF + IF(LOG1) THEN + IF(NCODE(1).EQ.1) THEN + IF(ICODE(1).EQ.0) THEN + QFR(NUM2+1)=ALB(ZCODE(1)) + ELSE + QFR(NUM2+1)=1.0 + IQFR(NUM2+1)=ICODE(1) + ENDIF + ELSE IF(NCODE(1).EQ.7) THEN + L=0 + DO 35 I=1,LC + DO 30 J=1,LC + L=L+1 + IF(J.EQ.1) KN(NUM1+L)=0 + 30 CONTINUE + 35 CONTINUE + ENDIF + ENDIF +* + IF(K2.EQ.LX) THEN + LOG2=.TRUE. + ELSE + LOG2=(MAT(KK2).EQ.0) + ENDIF + IF(LOG2) THEN + IF(NCODE(2).EQ.1) THEN + IF(ICODE(2).EQ.0) THEN + QFR(NUM2+2)=ALB(ZCODE(2)) + ELSE + QFR(NUM2+2)=1.0 + IQFR(NUM2+2)=ICODE(2) + ENDIF + ELSE IF(NCODE(2).EQ.7) THEN + L=0 + DO 45 I=1,LC + DO 40 J=1,LC + L=L+1 + IF(J.EQ.LC) KN(NUM1+L)=0 + 40 CONTINUE + 45 CONTINUE + ENDIF + ENDIF +* + IF(K1.EQ.1) THEN + LOG3=.TRUE. + ELSE + LOG3=(MAT(KK3).EQ.0) + ENDIF + IF(LOG3) THEN + IF(NCODE(3).EQ.1) THEN + IF(ICODE(3).EQ.0) THEN + QFR(NUM2+3)=ALB(ZCODE(3)) + ELSE + QFR(NUM2+3)=1.0 + IQFR(NUM2+3)=ICODE(3) + ENDIF + ELSE IF(NCODE(3).EQ.7) THEN + L=0 + DO 55 I=1,LC + DO 50 J=1,LC + L=L+1 + IF(I.EQ.1) KN(NUM1+L)=0 + 50 CONTINUE + 55 CONTINUE + ENDIF + ENDIF +* + IF(K1.EQ.LY) THEN + LOG4=.TRUE. + ELSE + LOG4=(MAT(KK4).EQ.0) + ENDIF + IF(LOG4) THEN + IF(NCODE(4).EQ.1) THEN + IF(ICODE(4).EQ.0) THEN + QFR(NUM2+4)=ALB(ZCODE(4)) + ELSE + QFR(NUM2+4)=1.0 + IQFR(NUM2+4)=ICODE(4) + ENDIF + ELSE IF(NCODE(4).EQ.7) THEN + L=0 + DO 65 I=1,LC + DO 60 J=1,LC + L=L+1 + IF(I.EQ.LC) KN(NUM1+L)=0 + 60 CONTINUE + 65 CONTINUE + ENDIF + ENDIF +*---- +* TRAN BOUNDARY CONDITION. +*---- + IF((K2.EQ.LX).AND.(NCODE(2).EQ.4)) THEN + DO 70 I=1,LC + M=(I-1)*LC+LC + KN(NUM1+M)=KN(NUM1+M)-IX+1 + 70 CONTINUE + ENDIF + IF((K1.EQ.LY).AND.(NCODE(4).EQ.4)) THEN + DO 80 I=1,LC + M=(LC-1)*LC+I + KN(NUM1+M)=KN(NUM1+M)-IXY+IX + 80 CONTINUE + ENDIF +*---- +* SYME BOUNDARY CONDITION. +*---- + IF((NCODE(1).EQ.5).AND.(K2.EQ.1)) THEN + QFR(NUM2+1)=QFR(NUM2+2) + IQFR(NUM2+1)=IQFR(NUM2+2) + FRX=0.5 + DO 95 I=1,LC + DO 90 J=1,(LC+1)/2 + L=(I-1)*LC+J + M=(I-1)*LC+(LC-J+1) + KN(NUM1+L)=KN(NUM1+M) + 90 CONTINUE + 95 CONTINUE + ELSE IF((NCODE(2).EQ.5).AND.(K2.EQ.LX)) THEN + QFR(NUM2+2)=QFR(NUM2+1) + IQFR(NUM2+2)=IQFR(NUM2+1) + FRX=0.5 + DO 105 I=1,LC + DO 100 J=(LC+2)/2,LC + L=(I-1)*LC+J + M=(I-1)*LC+(LC-J+1) + KN(NUM1+L)=KN(NUM1+M) + 100 CONTINUE + 105 CONTINUE + ENDIF + IF((NCODE(3).EQ.5).AND.(K1.EQ.1)) THEN + QFR(NUM2+3)=QFR(NUM2+4) + IQFR(NUM2+3)=IQFR(NUM2+4) + FRY=0.5 + DO 115 I=1,(LC+1)/2 + DO 110 J=1,LC + L=(I-1)*LC+J + M=(LC-I)*LC+J + KN(NUM1+L)=KN(NUM1+M) + 110 CONTINUE + 115 CONTINUE + ELSE IF((NCODE(4).EQ.5).AND.(K1.EQ.LY)) THEN + QFR(NUM2+4)=QFR(NUM2+3) + IQFR(NUM2+4)=IQFR(NUM2+3) + FRY=0.5 + DO 125 I=(LC+2)/2,LC + DO 120 J=1,LC + L=(I-1)*LC+J + M=(LC-I)*LC+J + KN(NUM1+L)=KN(NUM1+M) + 120 CONTINUE + 125 CONTINUE + ENDIF +* + VOL0=XX(KEL)*YY(KEL)*FRX*FRY + IF(CYLIND) THEN + VOL0=6.2831853072*DD(KEL)*VOL0 + ENDIF + VOL(KEL)=VOL0 + QFR(NUM2+1)=QFR(NUM2+1)*VOL0/XX(KEL) + QFR(NUM2+2)=QFR(NUM2+2)*VOL0/XX(KEL) + QFR(NUM2+3)=QFR(NUM2+3)*VOL0/YY(KEL) + QFR(NUM2+4)=QFR(NUM2+4)*VOL0/YY(KEL) +* + IF(((NCODE(1).EQ.1).OR.(NCODE(1).EQ.7)).AND.LOG1) + 1 BFR(NUM2+1)=VOL0/XX(KEL) + IF(((NCODE(2).EQ.1).OR.(NCODE(2).EQ.7)).AND.LOG2) + 1 BFR(NUM2+2)=VOL0/XX(KEL) + IF(((NCODE(3).EQ.1).OR.(NCODE(3).EQ.7)).AND.LOG3) + 1 BFR(NUM2+3)=VOL0/YY(KEL) + IF(((NCODE(4).EQ.1).OR.(NCODE(4).EQ.7)).AND.LOG4) + 1 BFR(NUM2+4)=VOL0/YY(KEL) + SURFTOT=SURFTOT+BFR(NUM2+1)+BFR(NUM2+2)+BFR(NUM2+3)+BFR(NUM2+4) + NUM1=NUM1+LL + NUM2=NUM2+4 + 150 CONTINUE + 151 CONTINUE +* END OF THE MAIN LOOP OVER THE ELEMENTS. +* +*---- +* COMPUTE THE SURFACE FRACTIONS. +*---- + IF(SURFTOT.GT.0.0) THEN + DO 155 I=1,4*LX*LY + BFR(I)=BFR(I)/SURFTOT + 155 CONTINUE + ENDIF +*---- +* TREATMENT OF 1D CASES. +*---- + LOG1=(LX.EQ.1).AND.(NCODE(1).EQ.2).AND.(NCODE(2).EQ.5) + 1 .AND.(IELEM.GT.1) + LOG2=(LX.EQ.1).AND.(NCODE(1).EQ.5).AND.(NCODE(2).EQ.2) + 1 .AND.(IELEM.GT.1) + IF(LOG1.OR.LOG2) THEN + NUM1=0 + DO 170 KEL=1,LX*LY + IF(MAT(KEL).EQ.0) GO TO 170 + DO 165 I=1,LC + DO 160 J=2,LC + KN(NUM1+(I-1)*LC+J)=KN(NUM1+(I-1)*LC+1) + 160 CONTINUE + 165 CONTINUE + NUM1=NUM1+LL + 170 CONTINUE + ENDIF + LOG1=(LY.EQ.1).AND.(NCODE(3).EQ.2).AND.(NCODE(4).EQ.5) + 1 .AND.(IELEM.GT.1) + LOG2=(LY.EQ.1).AND.(NCODE(3).EQ.5).AND.(NCODE(4).EQ.2) + 1 .AND.(IELEM.GT.1) + IF(LOG1.OR.LOG2) THEN + NUM1=0 + DO 190 KEL=1,LX*LY + IF(MAT(KEL).EQ.0) GO TO 190 + DO 185 I=2,LC + DO 180 J=1,LC + KN(NUM1+(I-1)*LC+J)=KN(NUM1+J) + 180 CONTINUE + 185 CONTINUE + NUM1=NUM1+LL + 190 CONTINUE + ENDIF +*---- +* JUXTAPOSITION OF A CHECKERBOARD OVER THE REACTOR DOMAIN. +*---- + LYTOT=LY*(LC-1)+1 + LXTOT=LX*(LC-1)+1 + DO 220 I=1,LXTOT*LYTOT + IWRK(I)=-1 + 220 CONTINUE + NUM1=0 + KEL=0 + DO 245 K1=1,LY + LK1=(K1-1)*(LC-1) + DO 240 K2=1,LX + KEL=KEL+1 + IF(MAT(KEL).EQ.0) GO TO 240 + LK2=(K2-1)*(LC-1) + L=0 + DO 235 IK1=LK1+1,LK1+LC + I1=(IK1-1)*LXTOT + DO 230 IK2=LK2+1,LK2+LC + I2=I1+IK2 + L=L+1 + IND1=KN(NUM1+L) + IF(IND1.EQ.0) THEN + IWRK(I2)=0 + GO TO 230 + ENDIF + IF(IWRK(I2).EQ.-1) THEN + IWRK(I2)=IND1 + ELSE IF(IWRK(I2).EQ.0) THEN + KN(NUM1+L)=0 + ELSE IF(IWRK(I2).NE.IND1) THEN + CALL XABORT('BIVPKN: FAILURE OF THE RENUMBERING ALGORITHM(1).') + ENDIF + 230 CONTINUE + 235 CONTINUE + NUM1=NUM1+LL + 240 CONTINUE + 245 CONTINUE +*---- +* COMPUTE THE PERMUTATION VECTOR IP AND RENUMBER THE UNKNOWNS. +*---- + DO 250 I=1,MAXEV + IP(I)=0 + 250 CONTINUE + L4=0 + IF(NCODE(1).EQ.5) THEN + K2MIN=1+LC/2 + ELSE + K2MIN=1 + ENDIF + DO 265 K1=1,LYTOT + IK1=(K1-1)*LXTOT + DO 260 K2=K2MIN,LXTOT + I=IWRK(IK1+K2) + IF(I.LE.0) GO TO 260 + IF(I.GT.MAXEV) THEN + CALL XABORT('BIVPKN: FAILURE OF THE RENUMBERING ALGORITHM(2).') + ENDIF + IF(IP(I).EQ.0) THEN + L4=L4+1 + IP(I)=L4 + ENDIF + 260 CONTINUE + 265 CONTINUE + DO 270 K=1,NUM1 + KNK=KN(K) + IF(KNK.NE.0) KN(K)=IP(KNK) + 270 CONTINUE + IF(L4.EQ.0) THEN + CALL XABORT('BIVPKN: FAILURE OF THE RENUMBERING ALGORITHM(3).') + ELSE IF(L4.GT.MAXEV) THEN + CALL XABORT('BIVPKN: INSUFFICIENT MAXEV.') + ENDIF + IF(IMPX.GT.2) WRITE (6,745) (VOL(I),I=1,LX*LY) +*---- +* COMPUTE THE SYSTEM MATRIX BANDWIDTH. +*---- + DO 450 I=1,L4 + MU(I)=0 + 450 CONTINUE + NUM1=0 + DO 480 K=1,LX*LY + IF(MAT(K).LE.0) GO TO 480 + DO 470 I=1,LL + IND1=KN(NUM1+I) + IF(IND1.EQ.0) GO TO 470 + DO 460 J=1,LL + IND2=KN(NUM1+J) + IF(IND2.EQ.0) GO TO 460 + MU(IND1)=MAX0(MU(IND1),IND1-IND2+1) + 460 CONTINUE + 470 CONTINUE + NUM1=NUM1+LL + 480 CONTINUE + IIMAX=0 + DO 490 I=1,L4 + IIMAX=IIMAX+MU(I) + MU(I)=IIMAX + 490 CONTINUE +* + IF(IMPX.GT.2) THEN + WRITE (6,720) IIMAX + NUM1=0 + NUM2=0 + IF(IELEM.EQ.1) THEN + WRITE (6,750) + DO 500 K=1,LX*LY + IF(MAT(K).LE.0) GO TO 500 + WRITE (6,755) K,(KN(NUM1+I),I=1,LL),(QFR(NUM2+I),I=1,4), + 1 (BFR(NUM2+I),I=1,4) + NUM1=NUM1+LL + NUM2=NUM2+4 +500 CONTINUE + ELSE IF(IELEM.EQ.2) THEN + WRITE (6,760) + DO 510 K=1,LX*LY + IF(MAT(K).LE.0) GO TO 510 + WRITE (6,765) K,(KN(NUM1+I),I=1,LL),(QFR(NUM2+I),I=1,4) + NUM1=NUM1+LL + NUM2=NUM2+4 +510 CONTINUE + NUM2=0 + WRITE (6,830) + DO 515 K=1,LX*LY + IF(MAT(K).LE.0) GO TO 515 + WRITE (6,820) K,(BFR(NUM2+I),I=1,4) + NUM2=NUM2+4 +515 CONTINUE + ELSE IF((IELEM.EQ.3).OR.(IELEM.EQ.4)) THEN + WRITE (6,790) + DO 530 K=1,LX*LY + IF(MAT(K).LE.0) GO TO 530 + WRITE (6,800) K,(KN(NUM1+I),I=1,LL) + NUM1=NUM1+LL +530 CONTINUE + WRITE (6,810) + DO 540 K=1,LX*LY + IF(MAT(K).LE.0) GO TO 540 + WRITE (6,820) K,(QFR(NUM2+I),I=1,4) + NUM2=NUM2+4 +540 CONTINUE + NUM2=0 + WRITE (6,830) + DO 550 K=1,LX*LY + IF(MAT(K).LE.0) GO TO 550 + WRITE (6,820) K,(BFR(NUM2+I),I=1,4) + NUM2=NUM2+4 +550 CONTINUE + ENDIF + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IWRK,IP) + RETURN +* + 700 FORMAT(/38H BIVPKN: PRIMAL FINITE ELEMENT METHOD.//7H NUMBER, + 1 27H OF ELEMENTS ALONG X AXIS =,I3/26H NUMBER OF ELEMENTS ALONG , + 2 8HY AXIS =,I3) + 720 FORMAT(/52H NUMBER OF TERMS IN THE COMPRESSED SYSTEM MATRICES =, + 1 I7) + 745 FORMAT(/20H VOLUMES PER ELEMENT/(1X,1P,10E13.4)) + 750 FORMAT(/22H NUMBERING OF UNKNOWNS/1X,21(1H-)// + 1 8H ELEMENT,5X,7HNUMBERS,23X,23HVOID BOUNDARY CONDITION,25X, + 2 17HSURFACE FRACTIONS) + 755 FORMAT (3X,I4,7X,4I5,6X,1P,4E11.2,5X,4E10.2) + 760 FORMAT(/22H NUMBERING OF UNKNOWNS/1X,21(1H-)// + 1 8H ELEMENT,5X,7HNUMBERS,47X,23HVOID BOUNDARY CONDITION) + 765 FORMAT (3X,I4,7X,9I5,6X,1P,4E11.2) + 790 FORMAT(/22H NUMBERING OF UNKNOWNS/1X,21(1H-)//5H ELE-/5H MENT, + 1 3X,7HNUMBERS) + 800 FORMAT (1X,I4,2X,25I5) + 810 FORMAT (///24H VOID BOUNDARY CONDITION//8H ELEMENT,5X,3HQFR) + 820 FORMAT (3X,I4,4X,1P,4E10.2) + 830 FORMAT (///17H SURFACE FRACTION//8H ELEMENT,5X,3HBFR) + END diff --git a/Trivac/src/BIVPRH.f b/Trivac/src/BIVPRH.f new file mode 100755 index 0000000..7034adc --- /dev/null +++ b/Trivac/src/BIVPRH.f @@ -0,0 +1,469 @@ +*DECK BIVPRH + SUBROUTINE BIVPRH (MAXEV,MAXKN,IMPX,ISPLH,LX,IHEX,NCODE,ICODE, + 1 ZCODE,MAT,SIDE,LL4,NELEM,VOL,KN,QFR,IQFR,BFR,MUW) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Numbering corresponding to a mesh corner finite difference or linear +* Lagrangian finite element discretization of a 2-D hexagonal geometry. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXEV maximum number of unknowns. +* MAXKN dimension for arrays KN, QFR and BFR. +* IMPX print parameter. +* ISPLH type of hexagonal mesh-splitting: +* =1: hexagonal elements; >1: 6*(ISPLH-1)**2 triangular elements +* per hexagon. +* LX number of hexagons. +* IHEX type of hexagonal boundary condition. +* NCODE type of boundary condition applied on each side +* (i=1: X- i=2: X+ i=3: Y- i=4: Y+): +* NCODE(I)=1: VOID; NCODE(I)=2: REFL; NCODE(I)=5: SYME; +* NCODE(I)=7: ZERO. +* ICODE physical albedo index on each side of the domain. +* ZCODE ZCODE(I) is the albedo corresponding to boundary condition +* 'VOID' on each side (ZCODE(I)=0.0 by default). +* MAT mixture index assigned to each hexagon. +* SIDE side of the hexagon. +* +*Parameters: output +* LL4 order of system matrices. +* NELEM number of finite elements (hexagons or triangles) excluding +* the virtual elements. +* VOL volume of each hexagon. +* KN element-ordered unknown list. +* QFR element-ordered boundary conditions. +* IQFR element-ordered physical albedo indices. +* BFR element-ordered surface fractions. +* MUW compressed storage mode indices. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MAXEV,MAXKN,IMPX,ISPLH,LX,IHEX,NCODE(4),ICODE(4),MAT(LX), + 1 LL4,NELEM,KN(MAXKN),IQFR(MAXKN),MUW(LL4) + REAL ZCODE(4),SIDE,VOL(LX),QFR(MAXKN),BFR(MAXKN) +*---- +* LOCAL VARIABLES +*---- + INTEGER ISR(6,2),JCR(6),KK(6),ISRH(6,2),ISRT(3,2),ISRT2(3,2) + CHARACTER HSMG*131 + LOGICAL LOG + INTEGER, DIMENSION(:), ALLOCATABLE :: IGAR,KN1 + ALB(X)=0.5*(1.0-X)/(1.0+X) + DATA ISRH/2,1,4,5,6,3,1,4,5,6,3,2/ + DATA ISRT/1,2,3,2,3,1/ + DATA ISRT2/3,1,2,2,3,1/ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IGAR(MAXEV),KN1(MAXKN)) +* + IF(IMPX.GT.0) WRITE(6,500) + IF(ISPLH.EQ.1) THEN + NSURF=6 + MAXNH=LX + ELSE + NSURF=3 + MAXNH=(6*(ISPLH-1)**2)*LX + ENDIF + CALL BIVSBH (MAXNH,MAXKN,IMPX,ISPLH,LX,SIDE,NELEM,IHEX,NCODE, + 1 MAT,VOL,KN1,QFR) + IF(NELEM*NSURF.GT.MAXKN) THEN + WRITE(HSMG,'(28HBIVPRH: INSUFFICIENT MAXKN (,I7,10H). SHOULD , + 1 15HBE INCREASED TO,I7,1H.)') MAXKN,NELEM*NSURF + CALL XABORT(HSMG) + ENDIF +*---- +* PRODUCE STANDARD MESH CORNER FINITE DIFFERENCE NUMBERING. +*---- + DO 10 I=1,NELEM*(NSURF+1) + KN(I)=-98 + 10 CONTINUE + DO 20 IC=1,NSURF + IF(ISPLH.EQ.1) THEN + JCR(IC)=IC+3-(IC/4)*6 + ISR(IC,1)=ISRH(IC,1) + ISR(IC,2)=ISRH(IC,2) + ELSE + IF(IC.EQ.1) JCR(1)=1 + IF(IC.EQ.2) JCR(2)=3 + IF(IC.EQ.3) JCR(3)=2 + ISR(IC,1)=ISRT(IC,1) + ISR(IC,2)=ISRT(IC,2) + ENDIF + 20 CONTINUE +*---- +* SET ZERO BOUNDARY CONDITIONS +*---- + NUM1=0 + DO 30 KX=1,NELEM + DO 26 IC=1,NSURF + KY=ABS(KN1(NUM1+IC)) + DO 25 I1=1,2 + IF((KY.GT.NELEM).AND.(NCODE(1).EQ.7)) KN(NUM1+ISR(IC,I1))=-99 + 25 CONTINUE + 26 CONTINUE + NUM1=NUM1+NSURF+1 + 30 CONTINUE +* + SURFTOT=0.0 + LL4=0 + NUM1=0 + DO 50 KX=1,NELEM + DO 40 IC=1,NSURF + IF(NSURF.EQ.6) THEN + BFR(NUM1+IC)=QFR(NUM1+IC)*QFR(NUM1+7)/(1.5*SQRT(3.0)*SIDE) + IF((NCODE(1).EQ.1).AND.(ICODE(1).EQ.0)) THEN + QFR(NUM1+IC)=ALB(ZCODE(1))*QFR(NUM1+IC)*QFR(NUM1+7)/ + 1 (1.5*SQRT(3.0)*SIDE) + ELSE IF(NCODE(1).EQ.1) THEN + QFR(NUM1+IC)=QFR(NUM1+IC)*QFR(NUM1+7)/(1.5*SQRT(3.0)*SIDE) + ELSE + QFR(NUM1+IC)=0.0 + ENDIF + ELSE + AA=SIDE/REAL(ISPLH-1) + BFR(NUM1+IC)=QFR(NUM1+IC)*QFR(NUM1+4)/(0.25*SQRT(3.0)*AA) + IF((NCODE(1).EQ.1).AND.(ICODE(1).EQ.0)) THEN + QFR(NUM1+IC)=ALB(ZCODE(1))*QFR(NUM1+IC)*QFR(NUM1+4)/ + 1 (0.25*SQRT(3.0)*AA) + ELSE IF(NCODE(1).EQ.1) THEN + QFR(NUM1+IC)=QFR(NUM1+IC)*QFR(NUM1+4)/(0.25*SQRT(3.0)*AA) + ELSE + QFR(NUM1+IC)=0.0 + ENDIF + ENDIF + IQFR(NUM1+IC)=ICODE(1) + SURFTOT=SURFTOT+BFR(NUM1+IC) + KY0=KN1(NUM1+IC) + IF((KY0.LT.0).AND.(IHEX.NE.5).AND.(IHEX.NE.6)) GO TO 40 + KY=ABS(KY0) + DO 35 I1=1,2 + IND=ISR(IC,I1) + IF((KY.GT.NELEM).OR.(KY0.LT.0)) THEN + IF(KN(NUM1+IND).EQ.-98) THEN + LL4=LL4+1 + KN(NUM1+IND)=LL4 + ENDIF + ELSE + JND=ISR(JCR(IC),I1+1-(I1/2)*2) + IOF2=(KY-1)*(NSURF+1)+JND + IF(IOF2.GT.MAXKN) CALL XABORT('BIVPRH: ALGORITHM FAILURE 2.') + LOG=.FALSE. + IF(KN(IOF2).EQ.-99) THEN + KN(NUM1+IND)=-99 + ELSE IF(KN(NUM1+IND).EQ.-98) THEN + LL4=LL4+1 + KN(NUM1+IND)=LL4 + IF(KY.NE.KX) KN(IOF2)=LL4 + IF((KY.NE.KX).AND.(ISPLH.GT.1)) LOG=.TRUE. + ELSE IF(KN(NUM1+IND).EQ.-99) THEN + GO TO 35 + ELSE IF((KN(IOF2).EQ.-98).AND.(KY.NE.KX)) THEN + KN(IOF2)=KN(NUM1+IND) + IF((KY.NE.KX).AND.(ISPLH.GT.1)) LOG=.TRUE. + ELSE IF((KN(NUM1+IND).NE.KN(IOF2)).AND.(KY.NE.KX)) THEN + CALL XABORT('BIVPRH: ALGORITHM FAILURE 3.') + ELSE IF((KY.NE.KX).AND.(ISPLH.GT.1)) THEN + LOG=.TRUE. + ENDIF + IF(LOG) THEN + KND=0 + IF(JND.EQ.1) KND=2 + IF(JND.EQ.2) KND=1 + IF(JND.EQ.3) KND=3 + KZ=KN1((KY-1)*4+ISRT2(JCR(IC),I1+1-(I1/2)*2)) + IF((KZ.GT.0).AND.(KZ.LE.NELEM).AND.(KZ.NE.KY)) THEN + IF(KN((KZ-1)*4+KND).EQ.-99) THEN + KN(NUM1+IND)=-99 + ELSE + KN((KZ-1)*4+KND)=KN(NUM1+IND) + ENDIF + ENDIF + ENDIF + ENDIF + 35 CONTINUE + 40 CONTINUE + KN(NUM1+NSURF+1)=KN1(KX*(NSURF+1)) + NUM1=NUM1+NSURF+1 + 50 CONTINUE +*---- +* COMPUTE THE SURFACE FRACTIONS. +*---- + IF(SURFTOT.GT.0.0) THEN + DO 55 I=1,NUM1 + BFR(I)=BFR(I)/SURFTOT + 55 CONTINUE + ENDIF +* + NUM1=0 + DO 150 KX=1,NELEM + DO 60 IC=1,NSURF + KK(IC)=KN1(NUM1+IC) + 60 CONTINUE + IF(ISPLH.EQ.1) THEN + IF((KX.EQ.1).AND.((IHEX.EQ.1).OR.(IHEX.EQ.10))) THEN + DO 70 I=1,6 + KN(I)=KN(2) + 70 CONTINUE + ELSE IF((KX.EQ.1).AND.((IHEX.EQ.2).OR.(IHEX.EQ.11))) THEN + DO 80 I=1,6 + KN(I)=KN(2) + 80 CONTINUE + ELSE IF((KX.EQ.1).AND.(IHEX.EQ.3)) THEN + KN(3)=KN(1) + KN(4)=KN(2) + KN(5)=KN(1) + KN(6)=KN(2) + ELSE IF((KX.EQ.1).AND.(IHEX.EQ.4)) THEN + KN(3)=KN(1) + KN(4)=KN(1) + KN(5)=KN(2) + KN(6)=KN(1) + ELSE IF((KX.EQ.1).AND.(IHEX.EQ.5)) THEN + KN(3)=KN(1) + KN(4)=KN(2) + KN(5)=KN(1) + KN(6)=KN(2) + ELSE IF((KX.EQ.1).AND.(IHEX.EQ.6)) THEN + KN(4)=KN(3) + KN(5)=KN(2) + KN(6)=KN(1) + ELSE IF((KK(1).EQ.-KK(5)).AND.(KK(2).EQ.-KK(4)).AND. + 1 (KK(3).EQ.-KK(5)).AND.(KK(6).EQ.-KK(4))) THEN + DO 90 I=1,6 + KN(NUM1+I)=KN(NUM1+6) + 90 CONTINUE + ELSE IF((KK(1).EQ.-KK(3)).AND.(KK(4).EQ.-KK(2)).AND. + 1 (KK(5).EQ.-KK(3)).AND.(KK(6).EQ.-KK(2))) THEN + DO 100 I=1,6 + KN(NUM1+I)=KN(NUM1+4) + 100 CONTINUE + ELSE IF((KK(1).EQ.-KK(6)).AND.(KK(2).EQ.-KK(5)).AND. + 1 (KK(3).EQ.-KK(4))) THEN + KN(NUM1+3)=KN(NUM1+1) + KN(NUM1+6)=KN(NUM1+4) + ELSE IF((KK(5).EQ.-KK(4)).AND.(KK(6).EQ.-KK(3)).AND. + 1 (KK(1).EQ.-KK(2))) THEN + KN(NUM1+4)=KN(NUM1+2) + KN(NUM1+5)=KN(NUM1+3) + ELSE IF((KK(1).EQ.-KK(3)).AND.(KK(4).EQ.-KK(3)).AND. + 1 (KK(5).EQ.-KK(2)).AND.(KK(6).EQ.-KK(3))) THEN + KN(NUM1+1)=KN(NUM1+4) + KN(NUM1+2)=KN(NUM1+5) + KN(NUM1+3)=KN(NUM1+4) + KN(NUM1+6)=KN(NUM1+4) + ELSE IF((KK(2).EQ.-KK(6)).AND.(KK(3).EQ.-KK(5)).AND. + 1 (KK(2).LT.0)) THEN + KN(NUM1+1)=KN(NUM1+2) + KN(NUM1+4)=KN(NUM1+3) + KN(NUM1+5)=KN(NUM1+6) + ELSE IF((KK(1).EQ.-KK(3)).AND.(KK(6).EQ.-KK(4)).AND. + 1 (KK(1).LT.0)) THEN + KN(NUM1+1)=KN(NUM1+4) + KN(NUM1+2)=KN(NUM1+5) + KN(NUM1+3)=KN(NUM1+6) + ELSE IF((KK(4).EQ.-KK(2)).AND.(KK(5).EQ.-KK(1)).AND. + 1 (KK(4).LT.0)) THEN + KN(NUM1+3)=KN(NUM1+2) + KN(NUM1+5)=KN(NUM1+4) + KN(NUM1+6)=KN(NUM1+1) + ELSE IF((KK(3).EQ.-KK(1)).AND.(KK(4).EQ.-KK(6)).AND. + 1 (KK(3).LT.0)) THEN + KN(NUM1+4)=KN(NUM1+1) + KN(NUM1+5)=KN(NUM1+2) + KN(NUM1+6)=KN(NUM1+3) + ENDIF + DO 120 IC=1,NSURF + IF((KK(IC).LT.0).AND.((IHEX.EQ.5).OR.(IHEX.EQ.6)).AND. + 1 (KX.GT.1)) THEN + IS=0 + DO 110 I=1,6 + IF(-KN1((-KK(IC)-1)*7+I).EQ.KX) IS=I + 110 CONTINUE + IF(IS.EQ.0) CALL XABORT('BIVPRH: ALGORITHM FAILURE 4.') + KN((-KK(IC)-1)*7+ISRH(IS,2))=KN(NUM1+ISRH(IC,1)) + KN((-KK(IC)-1)*7+ISRH(IS,1))=KN(NUM1+ISRH(IC,2)) + ENDIF + 120 CONTINUE + ELSE + IF((IHEX.NE.5).AND.(IHEX.NE.6)) THEN + IF((KK(1).EQ.-KK(2)).AND.(KK(1).LT.0)) THEN + KN(NUM1+1)=KN(NUM1+3) + ELSE IF((KK(1).EQ.-KK(3)).AND.(KK(1).LT.0)) THEN + KN(NUM1+2)=KN(NUM1+3) + ELSE IF((KK(2).EQ.-KK(3)).AND.(KK(2).LT.0)) THEN + KN(NUM1+2)=KN(NUM1+1) + ELSE IF((KK(2).EQ.-KK(1)).AND.(KK(2).LT.0)) THEN + KN(NUM1+3)=KN(NUM1+1) + ELSE IF((KK(3).EQ.-KK(1)).AND.(KK(3).LT.0)) THEN + KN(NUM1+3)=KN(NUM1+2) + ELSE IF((KK(3).EQ.-KK(2)).AND.(KK(3).LT.0)) THEN + KN(NUM1+1)=KN(NUM1+2) + ENDIF + ENDIF + DO 140 IC=1,NSURF + IF((KK(IC).LT.0).AND.((IHEX.EQ.5).OR.(IHEX.EQ.6))) THEN + IS=0 + DO 130 I=1,3 + IF(-KN1((-KK(IC)-1)*4+I).EQ.KX) IS=I + 130 CONTINUE + IF(IS.EQ.0) CALL XABORT('BIVPRH: ALGORITHM FAILURE 5.') + KY=-KK(IC) + DO 135 I1=1,2 + J1=I1+1-(I1/2)*2 + IND=ISRT(IC,I1) + JND=ISRT(IS,J1) + KN((-KK(IC)-1)*4+JND)=KN(NUM1+IND) + KND=0 + IF(JND.EQ.1) KND=2 + IF(JND.EQ.2) KND=1 + IF(JND.EQ.3) KND=3 + KZ=KN1((-KK(IC)-1)*4+ISRT2(IS,J1)) + IF((KZ.GT.0).AND.(KZ.LE.NELEM).AND.(KZ.NE.KY)) THEN + KNZ=KN((KZ-1)*4+KND) + KN((KZ-1)*4+KND)=KN(NUM1+IND) + IF(IHEX.EQ.6) THEN + DO 132 L=1,NELEM + DO 131 LC=1,NSURF + IF(KN((L-1)*4+LC).EQ.KNZ) KN((L-1)*4+LC)=KN(NUM1+IND) + 131 CONTINUE + 132 CONTINUE + ENDIF + ENDIF + 135 CONTINUE + ENDIF + 140 CONTINUE + ENDIF + NUM1=NUM1+NSURF+1 + 150 CONTINUE + LL5=0 + DO 170 I=1,MAXEV + IGAR(I)=0 + 170 CONTINUE + NUM1=0 + DO 190 I=1,NELEM + DO 180 IC=1,NSURF + IND=KN(NUM1+IC) + IF(IND.GT.MAXEV) THEN + WRITE(HSMG,'(28HBIVPRH: INSUFFICIENT MAXEV (,I7,10H). SHOULD , + 1 15HBE INCREASED TO,I7,1H.)') MAXEV,IND + CALL XABORT(HSMG) + ELSE IF(IND.EQ.-98) THEN + CALL XABORT('BIVPRH: ALGORITHM FAILURE 6.') + ELSE IF(IND.EQ.-99) THEN + KN(NUM1+IC)=0 + ELSE IF(IGAR(IND).EQ.0) THEN + LL5=LL5+1 + IGAR(IND)=LL5 + ENDIF + 180 CONTINUE + NUM1=NUM1+NSURF+1 + 190 CONTINUE + NUM1=0 + DO 210 I=1,NELEM + DO 200 IC=1,NSURF + IF(KN(NUM1+IC).NE.0) THEN + IF(IGAR(KN(NUM1+IC)).EQ.0) CALL XABORT('BIVPRH: ALGORITHM FAI' + 1 //'LURE 7.') + KN(NUM1+IC)=IGAR(KN(NUM1+IC)) + ENDIF + 200 CONTINUE + NUM1=NUM1+NSURF+1 + 210 CONTINUE + LL4=LL5 + IF(IMPX.GT.0) WRITE(6,570) LL4 + IF(LL4.GT.MAXEV) THEN + WRITE(HSMG,'(28HBIVPRH: INSUFFICIENT MAXEV (,I7,10H). SHOULD , + 1 15HBE INCREASED TO,I7,1H.)') MAXEV,LL4 + CALL XABORT(HSMG) + ENDIF + IF(LL4.GT.MAXEV) CALL XABORT('BIVPRH: INSUFFICIENT MAXEV.') +* + IF((IMPX.GT.1).AND.(NSURF.EQ.6)) THEN + WRITE(6,510) + NUM1=0 + DO 220 I=1,NELEM + WRITE(6,520) I,KN(NUM1+7),(KN(NUM1+J),J=1,6),(QFR(NUM1+J), + 1 J=1,7) + NUM1=NUM1+7 + 220 CONTINUE + NUM1=0 + WRITE (6,580) + DO 225 I=1,NELEM + IF(MAT(I).LE.0) GO TO 225 + WRITE (6,590) I,(BFR(NUM1+J),J=1,6) + NUM1=NUM1+7 + 225 CONTINUE + ELSE IF((IMPX.GT.1).AND.(NSURF.EQ.3)) THEN + WRITE(6,530) + NUM1=0 + DO 230 I=1,NELEM + WRITE(6,540) I,KN(NUM1+4),(KN(NUM1+J),J=1,3),(QFR(NUM1+J), + 1 J=1,4),(BFR(NUM1+J),J=1,3) + NUM1=NUM1+4 + 230 CONTINUE + ENDIF +*---- +* COMPUTE THE SYSTEM MATRIX BANDWIDTH. +*---- + DO 240 I=1,LL4 + MUW(I)=1 + 240 CONTINUE + NUM1=0 + DO 270 K=1,NELEM + DO 260 I=1,NSURF + IND1=KN(NUM1+I) + IF(IND1.EQ.0) GO TO 260 + DO 250 J=1,NSURF + IND2=KN(NUM1+J) + IF(IND2.EQ.0) GO TO 250 + MUW(IND1)=MAX0(MUW(IND1),IND1-IND2+1) + 250 CONTINUE + 260 CONTINUE + NUM1=NUM1+NSURF+1 + 270 CONTINUE + IIMAX=0 + DO 280 I=1,LL4 + IIMAX=IIMAX+MUW(I) + MUW(I)=IIMAX + 280 CONTINUE + IF(IMPX.GT.6) WRITE(6,550) 'MUW :',(MUW(I),I=1,LL4) + IF(IMPX.GT.2) WRITE(6,560) IIMAX +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(KN1,IGAR) + RETURN +* + 500 FORMAT(//52H BIVPRH: NUMBERING FOR A MESH CORNER FINITE DIFFEREN, + 1 60HCE OR LINEAR LAGRANGIAN FINITE ELEMENT DISCRETIZATION IN HEX, + 2 16HAGONAL GEOMETRY.) + 510 FORMAT(/31H BIVPRH: NUMBERING OF UNKNOWNS./1X,30(1H-)/9X, + 1 7HHEXAGON,3X,8HUNKNOWNS,29X,23HVOID BOUNDARY CONDITION,45X, + 2 6HVOLUME) + 520 FORMAT (1X,2I6,2X,6I6,2X,1P,6E11.2,5X,E13.6) + 530 FORMAT(/31H BIVPRH: NUMBERING OF UNKNOWNS./1X,30(1H-)/9X, + 1 7HHEXAGON,3X,8HUNKNOWNS,11X,23HVOID BOUNDARY CONDITION,12X, + 2 6HVOLUME,13X,16HSURFACE FRACTION) + 540 FORMAT (1X,2I6,2X,3I6,2X,1P,3E11.2,5X,E13.6,5X,3E10.2) + 550 FORMAT(/1X,A5/(1X,20I6)) + 560 FORMAT(/52H NUMBER OF TERMS IN THE COMPRESSED SYSTEM MATRICES =, + > I6) + 570 FORMAT(/39H BIVPRH: NUMBER OF UNKNOWNS PER GROUP =,I6/) + 580 FORMAT (//17H SURFACE FRACTION//8H HEXAGON,5X,3HBFR) + 590 FORMAT (3X,I4,4X,1P,6E10.2) + END diff --git a/Trivac/src/BIVSBH.f b/Trivac/src/BIVSBH.f new file mode 100755 index 0000000..df95d2d --- /dev/null +++ b/Trivac/src/BIVSBH.f @@ -0,0 +1,489 @@ +*DECK BIVSBH + SUBROUTINE BIVSBH (MAXEV,MAXKN,IMPX,ISPLH,LX,SIDE,LL4,IHEX,NCODE, + 1 MAT,VOL,KN,QFR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Numbering of an hexagonal 2-D geometry with or without triangular +* mesh-splitting. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXEV dimension for array IGAR: +* if ISPLH=1: number of hexagons; +* if ISPLH>1: (6*(ISPLH-1)**2)*LX where LX is the number of +* hexagons. +* MAXKN dimension for arrays KN and QFR. +* IMPX print parameter. +* ISPLH type of hexagonal mesh-splitting: +* =1: no mesh splitting (complete hexagons); +* =K: 6*(K-1)*(K-1) triangles per hexagon. +* LX number of hexagons. +* SIDE side of an hexagon. +* NCODE type of boundary condition applied on each side +* (i=1: X- i=2: X+ i=3: Y- i=4: Y+): +* NCODE(I)=1: VOID; NCODE(I)=2: REFL; NCODE(I)=5: SYME; +* NCODE(I)=7: ZERO. +* MAT mixture index assigned to each hexagon. +* IHEX type of hexagonal boundary condition. +* +*Parameters: output +* LL4 number of elements after mesh-splitting. +* VOL volume of each hexagon. +* KN element-ordered unknown list. +* QFR element-ordered external surfaces: =1.0 on external surfaces; +* =0.0 on internal surfaces. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MAXEV,MAXKN,IMPX,ISPLH,LX,LL4,IHEX,NCODE(6),MAT(LX), + 1 KN(MAXKN) + REAL SIDE,VOL(LX),QFR(7*LX) +*---- +* LOCAL VARIABLES +*---- + INTEGER KK(6) + CHARACTER HSMG*131 + LOGICAL LOGSUR + INTEGER, DIMENSION(:), ALLOCATABLE :: IGAR,KN2 + REAL, DIMENSION(:), ALLOCATABLE :: QFR2 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IGAR(MAXEV),KN2(MAXKN),QFR2(MAXKN)) +* + IF(LX.GT.MAXEV) THEN + WRITE(HSMG,'(30HBIVSBH: 1 INSUFFICIENT MAXEV (,I7,7H). SHOU, + 1 18HLD BE INCREASED TO,I7,1H.)') MAXEV,LX + CALL XABORT(HSMG) + ENDIF + LL4=0 + DO 10 KX=1,LX + IGAR(KX)=0 + IF(MAT(KX).LE.0) GO TO 10 + LL4=LL4+1 + IGAR(KX)=LL4 + 10 CONTINUE + NSURF=6 + NUM1=0 + DO 30 KX=1,LX + VOL(KX)=0.0 + IF(MAT(KX).LE.0) GO TO 30 + IF(NUM1+7.GT.MAXKN) THEN + WRITE(HSMG,'(30HBIVSBH: 1 INSUFFICIENT MAXKN (,I7,2H).)') MAXKN + CALL XABORT(HSMG) + ENDIF + LOGSUR=(NCODE(1).EQ.1).OR.(NCODE(1).EQ.7) + DO 20 IX=1,6 + N1=NEIGHB(KX,IX,IHEX,LX,POIDS) + IF(N1.EQ.0) CALL XABORT('BIVSBH: NEIGHB FAILURE.') + QFR(NUM1+IX)=0.0 + IF(ABS(N1).GT.LX) THEN + IF(LOGSUR) QFR(NUM1+IX)=1.0 + KN(NUM1+IX)=SIGN(LX+1,N1) + ELSE IF(MAT(ABS(N1)).LE.0) THEN + IF(LOGSUR) QFR(NUM1+IX)=1.0 + KN(NUM1+IX)=SIGN(LX+1,N1) + IF((IHEX.EQ.5).OR.(IHEX.EQ.6)) KN(NUM1+IX)=LX+1 + ELSE + KN(NUM1+IX)=SIGN(IGAR(ABS(N1)),N1) + ENDIF + 20 CONTINUE + KN(NUM1+7)=KX + VOL(KX)=2.59807587*SIDE*SIDE*POIDS + QFR(NUM1+7)=VOL(KX) + NUM1=NUM1+7 + 30 CONTINUE + MAXMAX=LX + IF(IMPX.GT.4) THEN + WRITE(6,510) 1 + NUM1=0 + DO 40 I=1,LL4 + WRITE(6,520) I,KN(NUM1+7),(KN(NUM1+J),J=1,6),(QFR(NUM1+J), + 1 J=1,7) + NUM1=NUM1+7 + 40 CONTINUE + ENDIF + IF(ISPLH.GE.2) THEN +* HEXAGON TO TRIANGLE. + NSURF=3 + IF(LL4*24.GT.MAXKN) THEN + WRITE(HSMG,'(30HBIVSBH: 2 INSUFFICIENT MAXKN (,I7,7H). SHOU, + 1 18HLD BE INCREASED TO,I7,1H.)') MAXKN,LL4*24 + CALL XABORT(HSMG) + ENDIF + NUM1=0 + DO 60 KX=1,LL4 + IOF2=(KX-1)*24 + DO 50 IT=1,6 + KK(IT)=KN(NUM1+IT) + KN2(IOF2+(IT-1)*4+4)=KN(NUM1+7) + QFR2(IOF2+(IT-1)*4+1)=QFR(NUM1+IT) + QFR2(IOF2+(IT-1)*4+2)=0.0 + QFR2(IOF2+(IT-1)*4+3)=0.0 + IF(IT.NE.6) KN2(IOF2+(IT-1)*4+2)=(KX-1)*6+IT+1 + IF(IT.EQ.6) KN2(IOF2+(IT-1)*4+2)=(KX-1)*6+1 + IF(IT.NE.1) KN2(IOF2+(IT-1)*4+3)=(KX-1)*6+IT-1 + IF(IT.EQ.1) KN2(IOF2+(IT-1)*4+3)=(KX-1)*6+6 + QFR2(IOF2+(IT-1)*4+4)=QFR(NUM1+7)/6.0 + IF((KK(IT).LT.0).AND.((IHEX.EQ.5).OR.(IHEX.EQ.6)).AND. + 1 (KX.GT.1)) THEN + IC=0 + DO 45 I=1,6 + IF(-KN((-KK(IT)-1)*7+I).EQ.KX) IC=I + 45 CONTINUE + IF(IC.EQ.0) CALL XABORT('BIVSBH: ALGORITHM FAILURE 1.') + KN2(IOF2+(IT-1)*4+1)=-((-KK(IT)-1)*6+IC) + ELSE IF(KK(IT).LT.0) THEN + KN2(IOF2+(IT-1)*4+1)=0 + ELSE IF(KK(IT).EQ.KX) THEN + KN2(IOF2+(IT-1)*4+1)=((KX-1)*6+IT) + ELSE IF(ABS(KK(IT)).GT.MAXMAX) THEN + KN2(IOF2+(IT-1)*4+1)=SIGN(LL4*6+1,KK(IT)) + ELSE + KN2(IOF2+(IT-1)*4+1)=(KK(IT)-1)*6+IT+3-(IT/4)*6 + ENDIF + 50 CONTINUE +* CHECK SYMMETRIES. + IF((KX.EQ.1).AND.((IHEX.EQ.1).OR.(IHEX.EQ.10))) THEN + KN2(2)=-1 + KN2(3)=1 + QFR2(4)=QFR(7) + ELSE IF((KX.EQ.1).AND.((IHEX.EQ.2).OR.(IHEX.EQ.11))) THEN + KN2((1-1)*4+2)=-KN2((1-1)*4+3) + KN2((6-1)*4+3)=-KN2((6-1)*4+2) + QFR2((1-1)*4+4)=QFR(7)/2.0 + QFR2((6-1)*4+4)=QFR(7)/2.0 + ELSE IF((KX.EQ.1).AND.(IHEX.EQ.3)) THEN + KN2(2)=1 + KN2(3)=1 + QFR2(4)=QFR(7) + ELSE IF((KX.EQ.1).AND.(IHEX.EQ.4)) THEN + KN2((1-1)*4+3)=1 + KN2((2-1)*4+2)=-KN2((2-1)*4+3) + QFR2((1-1)*4+4)=2.0*QFR(7)/3.0 + QFR2((2-1)*4+4)=QFR(7)/3.0 + ELSE IF((KX.EQ.1).AND.(IHEX.EQ.5)) THEN + KN2((1-1)*4+3)=-KN2((1-1)*4+2) + KN2((2-1)*4+2)=-KN2((2-1)*4+3) + QFR2((1-1)*4+4)=QFR(7)/2.0 + QFR2((2-1)*4+4)=QFR(7)/2.0 + ELSE IF((KX.EQ.1).AND.(IHEX.EQ.6)) THEN + KN2((2-1)*4+2)=-6 + KN2((6-1)*4+3)=-2 + QFR2((1-1)*4+4)=QFR(7)/3.0 + QFR2((2-1)*4+4)=QFR(7)/3.0 + QFR2((6-1)*4+4)=QFR(7)/3.0 + ELSE IF((KK(1).EQ.-KK(5)).AND.(KK(2).EQ.-KK(4)).AND. + 1 (KK(3).EQ.-KK(5)).AND.(KK(6).EQ.-KK(4))) THEN + KN2(IOF2+(4-1)*4+3)=-KN2(IOF2+(4-1)*4+2) + KN2(IOF2+(5-1)*4+2)=-KN2(IOF2+(5-1)*4+3) + QFR2(IOF2+(4-1)*4+4)=QFR(NUM1+7)/2.0 + QFR2(IOF2+(5-1)*4+4)=QFR(NUM1+7)/2.0 + ELSE IF((KK(1).EQ.-KK(3)).AND.(KK(4).EQ.-KK(2)).AND. + 1 (KK(5).EQ.-KK(3)).AND.(KK(6).EQ.-KK(2))) THEN + KN2(IOF2+(2-1)*4+3)=-KN2(IOF2+(2-1)*4+2) + KN2(IOF2+(3-1)*4+2)=-KN2(IOF2+(3-1)*4+3) + QFR2(IOF2+(2-1)*4+4)=QFR(NUM1+7)/2.0 + QFR2(IOF2+(3-1)*4+4)=QFR(NUM1+7)/2.0 + ELSE IF((KK(1).EQ.-KK(6)).AND.(KK(2).EQ.-KK(5)).AND. + 1 (KK(3).EQ.-KK(4))) THEN + KN2(IOF2+(1-1)*4+3)=((KX-1)*6+1) + KN2(IOF2+(3-1)*4+2)=((KX-1)*6+3) + QFR2(IOF2+(1-1)*4+4)=QFR(NUM1+7)/3.0 + QFR2(IOF2+(2-1)*4+4)=QFR(NUM1+7)/3.0 + QFR2(IOF2+(3-1)*4+4)=QFR(NUM1+7)/3.0 + ELSE IF((KK(5).EQ.-KK(4)).AND.(KK(6).EQ.-KK(3)).AND. + 1 (KK(1).EQ.-KK(2))) THEN + KN2(IOF2+(5-1)*4+3)=((KX-1)*6+5) + KN2(IOF2+(1-1)*4+2)=((KX-1)*6+1) + QFR2(IOF2+(5-1)*4+4)=QFR(NUM1+7)/3.0 + QFR2(IOF2+(6-1)*4+4)=QFR(NUM1+7)/3.0 + QFR2(IOF2+(1-1)*4+4)=QFR(NUM1+7)/3.0 + ELSE IF((KK(1).EQ.-KK(3)).AND.(KK(4).EQ.-KK(3)).AND. + 1 (KK(5).EQ.-KK(2)).AND.(KK(6).EQ.-KK(3))) THEN + KN2(IOF2+(2-1)*4+3)=-KN2(IOF2+(2-1)*4+2) + KN2(IOF2+(3-1)*4+2)=((KX-1)*6+3) + QFR2(IOF2+(2-1)*4+4)=QFR(NUM1+7)/3.0 + QFR2(IOF2+(3-1)*4+4)=2.0*QFR(NUM1+7)/3.0 + ELSE IF((KK(2).EQ.-KK(6)).AND.(KK(3).EQ.-KK(5)).AND. + 1 (KK(2).LT.0)) THEN + KN2(IOF2+(1-1)*4+2)=-KN2(IOF2+(1-1)*4+3) + KN2(IOF2+(4-1)*4+3)=-KN2(IOF2+(4-1)*4+2) + QFR2(IOF2+(5-1)*4+4)=2.0*QFR2(IOF2+(5-1)*4+4) + QFR2(IOF2+(6-1)*4+4)=2.0*QFR2(IOF2+(6-1)*4+4) + ELSE IF((KK(1).EQ.-KK(3)).AND.(KK(6).EQ.-KK(4)).AND. + 1 (KK(1).LT.0)) THEN + KN2(IOF2+(2-1)*4+3)=-KN2(IOF2+(2-1)*4+2) + KN2(IOF2+(5-1)*4+2)=-KN2(IOF2+(5-1)*4+3) + QFR2(IOF2+(3-1)*4+4)=2.0*QFR2(IOF2+(3-1)*4+4) + QFR2(IOF2+(4-1)*4+4)=2.0*QFR2(IOF2+(4-1)*4+4) + ELSE IF((KK(4).EQ.-KK(2)).AND.(KK(5).EQ.-KK(1)).AND. + 1 (KK(4).LT.0)) THEN + KN2(IOF2+(3-1)*4+2)=-KN2(IOF2+(3-1)*4+3) + KN2(IOF2+(6-1)*4+3)=-KN2(IOF2+(6-1)*4+2) + QFR2(IOF2+(1-1)*4+4)=2.0*QFR2(IOF2+(1-1)*4+4) + QFR2(IOF2+(2-1)*4+4)=2.0*QFR2(IOF2+(2-1)*4+4) + ELSE IF((KK(3).EQ.-KK(1)).AND.(KK(4).EQ.-KK(6)).AND. + 1 (KK(3).LT.0)) THEN + KN2(IOF2+(2-1)*4+2)=-KN2(IOF2+(2-1)*4+3) + KN2(IOF2+(5-1)*4+3)=-KN2(IOF2+(5-1)*4+2) + QFR2(IOF2+(1-1)*4+4)=2.0*QFR2(IOF2+(1-1)*4+4) + QFR2(IOF2+(6-1)*4+4)=2.0*QFR2(IOF2+(6-1)*4+4) + ENDIF + NUM1=NUM1+7 + 60 CONTINUE + MAXMAX=LL4*6 + IF(LL4*6.GT.MAXEV) THEN + WRITE(HSMG,'(30HBIVSBH: 2 INSUFFICIENT MAXEV (,I7,7H). SHOU, + 1 18HLD BE INCREASED TO,I7,1H.)') MAXEV,LL4*6 + CALL XABORT(HSMG) + ENDIF + LL5=0 + NUM1=0 + NUM2=0 + DO 85 I=1,LL4*6 + IGAR(I)=0 + IF(KN2(NUM2+1).EQ.0) GO TO 80 + LL5=LL5+1 + IGAR(I)=LL5 + DO 70 J=1,4 + KN(NUM1+J)=KN2(NUM2+J) + QFR(NUM1+J)=QFR2(NUM2+J) + 70 CONTINUE + NUM1=NUM1+4 + 80 NUM2=NUM2+4 + 85 CONTINUE + NUM1=0 + DO 100 I=1,LL5 + DO 90 K=1,3 + IF(ABS(KN(NUM1+K)).LE.LL4*6) THEN + IF(IGAR(ABS(KN(NUM1+K))).EQ.0) CALL XABORT('BIVSBH: ALGORIT' + 1 //'HM FAILURE 2.') + KN(NUM1+K)=SIGN(IGAR(ABS(KN(NUM1+K))),KN(NUM1+K)) + ENDIF + 90 CONTINUE + NUM1=NUM1+4 + 100 CONTINUE + LL4=LL5 + IF(IMPX.GT.4) THEN + WRITE(6,530) 2 + NUM1=0 + DO 110 I=1,LL4 + WRITE(6,540) I,KN(NUM1+4),(KN(NUM1+J),J=1,3),(QFR(NUM1+J), + 1 J=1,4) + NUM1=NUM1+4 + 110 CONTINUE + ENDIF +* +* TRIANGLE TO TRIANGLE. + KSPLH=0 + IF(ISPLH.EQ.2) THEN +* MESH-SPLITTING INTO 6 TRIANGLES. + KSPLH=2 + ELSE IF(ISPLH.EQ.3) THEN +* MESH-SPLITTING INTO 24 TRIANGLES. + KSPLH=3 + ELSE IF(ISPLH.EQ.5) THEN +* MESH-SPLITTING INTO 96 TRIANGLES. + KSPLH=4 + ELSE IF(ISPLH.EQ.9) THEN +* MESH-SPLITTING INTO 384 TRIANGLES. + KSPLH=5 + ELSE IF(ISPLH.EQ.17) THEN +* MESH-SPLITTING INTO 1536 TRIANGLES. + KSPLH=6 + ELSE + WRITE(HSMG,'(36HBIVSBH: UNABLE TO SPLIT WITH ISPLH =,I5, + 1 38H ISPLH = 1, 2, 3, 5, 9 AND 17 ALLOWED.)') ISPLH + CALL XABORT(HSMG) + ENDIF + DO 230 JSPLH=3,KSPLH + IF(LL4*16.GT.MAXKN) THEN + WRITE(HSMG,'(30HBIVSBH: 3 INSUFFICIENT MAXKN (,I7,7H). SHOU, + 1 18HLD BE INCREASED TO,I7,1H.)') MAXKN,LL4*16 + CALL XABORT(HSMG) + ENDIF + NUM1=0 + DO 170 KX=1,LL4 + IOF2=(KX-1)*16 + DO 120 IT=1,3 + KK(IT)=KN(NUM1+IT) + 120 CONTINUE + DO 130 IT=1,4 + KN2(IOF2+(IT-1)*4+4)=KN(NUM1+4) + QFR2(IOF2+(IT-1)*4+1)=0.0 + QFR2(IOF2+(IT-1)*4+2)=0.0 + QFR2(IOF2+(IT-1)*4+3)=0.0 + QFR2(IOF2+(IT-1)*4+4)=QFR(NUM1+4)/4.0 + 130 CONTINUE + QFR2(IOF2+(1-1)*4+3)=QFR(NUM1+1) + QFR2(IOF2+(3-1)*4+2)=QFR(NUM1+1) + QFR2(IOF2+(1-1)*4+1)=QFR(NUM1+2) + QFR2(IOF2+(4-1)*4+2)=QFR(NUM1+2) + QFR2(IOF2+(3-1)*4+1)=QFR(NUM1+3) + QFR2(IOF2+(4-1)*4+3)=QFR(NUM1+3) + KN2(IOF2+(1-1)*4+1)=(KK(2)-1)*4+3 + KN2(IOF2+(1-1)*4+2)=(KX-1)*4+2 + KN2(IOF2+(1-1)*4+3)=(KK(1)-1)*4+3 + KN2(IOF2+(2-1)*4+1)=(KX-1)*4+4 + KN2(IOF2+(2-1)*4+2)=(KX-1)*4+3 + KN2(IOF2+(2-1)*4+3)=(KX-1)*4+1 + KN2(IOF2+(3-1)*4+1)=(KK(3)-1)*4+1 + KN2(IOF2+(3-1)*4+2)=(KK(1)-1)*4+1 + KN2(IOF2+(3-1)*4+3)=(KX-1)*4+2 + KN2(IOF2+(4-1)*4+1)=(KX-1)*4+2 + KN2(IOF2+(4-1)*4+2)=(KK(2)-1)*4+4 + KN2(IOF2+(4-1)*4+3)=(KK(3)-1)*4+4 + IF(ABS(KK(1)).GT.MAXMAX) THEN + KN2(IOF2+(1-1)*4+3)=SIGN(LL4*4+1,KK(1)) + KN2(IOF2+(3-1)*4+2)=SIGN(LL4*4+1,KK(1)) + ENDIF + IF(ABS(KK(2)).GT.MAXMAX) THEN + KN2(IOF2+(1-1)*4+1)=SIGN(LL4*4+1,KK(2)) + KN2(IOF2+(4-1)*4+2)=SIGN(LL4*4+1,KK(2)) + ENDIF + IF(ABS(KK(3)).GT.MAXMAX) THEN + KN2(IOF2+(3-1)*4+1)=SIGN(LL4*4+1,KK(3)) + KN2(IOF2+(4-1)*4+3)=SIGN(LL4*4+1,KK(3)) + ENDIF + IF((KK(1).LT.0).AND.((IHEX.EQ.5).OR.(IHEX.EQ.6))) THEN + IC=0 + DO 140 I=1,3 + IF(-KN((-KK(1)-1)*4+I).EQ.KX) IC=I + 140 CONTINUE + IF(IC.EQ.0) CALL XABORT('BIVSBH: ALGORITHM FAILURE 3.') + KN2(IOF2+(1-1)*4+3)=-((-KK(1)-1)*4+3) + KN2(IOF2+(3-1)*4+2)=-((-KK(1)-1)*4+1) + ELSE IF((KK(2).LT.0).AND.((IHEX.EQ.5).OR.(IHEX.EQ.6))) THEN + IC=0 + DO 150 I=1,3 + IF(-KN((-KK(2)-1)*4+I).EQ.KX) IC=I + 150 CONTINUE + IF(IC.EQ.0) CALL XABORT('BIVSBH: ALGORITHM FAILURE 4.') + KN2(IOF2+(1-1)*4+1)=-((-KK(2)-1)*4+3) + KN2(IOF2+(4-1)*4+2)=-((-KK(2)-1)*4+4) + ELSE IF((KK(3).LT.0).AND.((IHEX.EQ.5).OR.(IHEX.EQ.6))) THEN + IC=0 + DO 160 I=1,3 + IF(-KN((-KK(3)-1)*4+I).EQ.KX) IC=I + 160 CONTINUE + IF(IC.EQ.0) CALL XABORT('BIVSBH: ALGORITHM FAILURE 5.') + KN2(IOF2+(3-1)*4+1)=-((-KK(3)-1)*4+1) + KN2(IOF2+(4-1)*4+3)=-((-KK(3)-1)*4+4) + ELSE IF((KK(1).EQ.-KK(2)).AND.(KK(1).LT.0)) THEN + KN2(IOF2+(1-1)*4+3)=-KN2(IOF2+(1-1)*4+1) + KN2(IOF2+(2-1)*4+2)=-KN2(IOF2+(2-1)*4+1) + KN2(IOF2+(3-1)*4+1)=0 + QFR2(IOF2+(4-1)*4+4)=2.0*QFR2(IOF2+(4-1)*4+4) + ELSE IF((KK(1).EQ.-KK(3)).AND.(KK(1).LT.0)) THEN + KN2(IOF2+(2-1)*4+3)=-KN2(IOF2+(2-1)*4+1) + KN2(IOF2+(3-1)*4+2)=-KN2(IOF2+(3-1)*4+1) + KN2(IOF2+(1-1)*4+1)=0 + QFR2(IOF2+(4-1)*4+4)=2.0*QFR2(IOF2+(4-1)*4+4) + ELSE IF((KK(2).EQ.-KK(3)).AND.(KK(2).LT.0)) THEN + KN2(IOF2+(2-1)*4+3)=-KN2(IOF2+(2-1)*4+2) + KN2(IOF2+(4-1)*4+2)=-KN2(IOF2+(4-1)*4+3) + KN2(IOF2+(1-1)*4+1)=0 + QFR2(IOF2+(3-1)*4+4)=2.0*QFR2(IOF2+(3-1)*4+4) + ELSE IF((KK(2).EQ.-KK(1)).AND.(KK(2).LT.0)) THEN + KN2(IOF2+(1-1)*4+1)=-KN2(IOF2+(1-1)*4+3) + KN2(IOF2+(2-1)*4+1)=-KN2(IOF2+(2-1)*4+2) + KN2(IOF2+(4-1)*4+1)=0 + QFR2(IOF2+(3-1)*4+4)=2.0*QFR2(IOF2+(3-1)*4+4) + ELSE IF((KK(3).EQ.-KK(1)).AND.(KK(3).LT.0)) THEN + KN2(IOF2+(2-1)*4+1)=-KN2(IOF2+(2-1)*4+3) + KN2(IOF2+(3-1)*4+1)=-KN2(IOF2+(3-1)*4+2) + KN2(IOF2+(4-1)*4+1)=0 + QFR2(IOF2+(1-1)*4+4)=2.0*QFR2(IOF2+(1-1)*4+4) + ELSE IF((KK(3).EQ.-KK(2)).AND.(KK(3).LT.0)) THEN + KN2(IOF2+(2-1)*4+2)=-KN2(IOF2+(2-1)*4+3) + KN2(IOF2+(4-1)*4+3)=-KN2(IOF2+(4-1)*4+2) + KN2(IOF2+(3-1)*4+1)=0 + QFR2(IOF2+(1-1)*4+4)=2.0*QFR2(IOF2+(1-1)*4+4) + ENDIF + IF(KK(1).EQ.KX) THEN + IF(KN2(IOF2+(1-1)*4+3).NE.0) KN2(IOF2+(1-1)*4+3)=((KX-1)*4+1) + IF(KN2(IOF2+(3-1)*4+2).NE.0) KN2(IOF2+(3-1)*4+2)=((KX-1)*4+3) + ENDIF + IF(KK(2).EQ.KX) THEN + IF(KN2(IOF2+(1-1)*4+1).NE.0) KN2(IOF2+(1-1)*4+1)=((KX-1)*4+1) + IF(KN2(IOF2+(4-1)*4+2).NE.0) KN2(IOF2+(4-1)*4+2)=((KX-1)*4+4) + ENDIF + IF(KK(3).EQ.KX) THEN + IF(KN2(IOF2+(3-1)*4+1).NE.0) KN2(IOF2+(3-1)*4+1)=((KX-1)*4+3) + IF(KN2(IOF2+(4-1)*4+3).NE.0) KN2(IOF2+(4-1)*4+3)=((KX-1)*4+4) + ENDIF + NUM1=NUM1+4 + 170 CONTINUE + MAXMAX=LL4*4 + IF(LL4*4.GT.MAXEV) THEN + WRITE(HSMG,'(30HBIVSBH: 3 INSUFFICIENT MAXEV (,I7,7H). SHOU, + 1 18HLD BE INCREASED TO,I7,1H.)') MAXEV,LL4*4 + CALL XABORT(HSMG) + ENDIF + LL5=0 + NUM1=0 + NUM2=0 + DO 195 I=1,LL4*4 + IGAR(I)=0 + IF(KN2(NUM2+1).EQ.0) GO TO 190 + LL5=LL5+1 + IGAR(I)=LL5 + DO 180 J=1,4 + KN(NUM1+J)=KN2(NUM2+J) + QFR(NUM1+J)=QFR2(NUM2+J) + 180 CONTINUE + NUM1=NUM1+4 + 190 NUM2=NUM2+4 + 195 CONTINUE + NUM1=0 + DO 210 I=1,LL5 + DO 200 K=1,3 + IF(ABS(KN(NUM1+K)).LE.LL4*4) THEN + IF(IGAR(ABS(KN(NUM1+K))).EQ.0) CALL XABORT('BIVSBH: ALGORIT' + 1 //'HM FAILURE 6.') + KN(NUM1+K)=SIGN(IGAR(ABS(KN(NUM1+K))),KN(NUM1+K)) + ENDIF + 200 CONTINUE + NUM1=NUM1+4 + 210 CONTINUE + LL4=LL5 + IF(IMPX.GT.4) THEN + WRITE(6,530) JSPLH + NUM1=0 + DO 220 I=1,LL4 + WRITE(6,540) I,KN(NUM1+4),(KN(NUM1+J),J=1,3),(QFR(NUM1+J), + 1 J=1,4) + NUM1=NUM1+4 + 220 CONTINUE + ENDIF + 230 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IGAR,KN2,QFR2) + RETURN +* + 510 FORMAT(/36H BIVSBH: NUMBERING OF UNKNOWNS. STEP,I3,1H./1X,40(1H-)/ + 1 9X,7HHEXAGON,3X,9HNEIGHBOUR,27X,17HEXTERNAL SURFACES,22X, + 2 6HVOLUME) + 520 FORMAT (1X,2I6,2X,6I6,2X,6F6.2,5X,1P,E13.6) + 530 FORMAT(/36H BIVSBH: NUMBERING OF UNKNOWNS. STEP,I3,1H./1X,40(1H-)/ + 1 9X,7HHEXAGON,3X,9HNEIGHBOUR,9X,17HEXTERNAL SURFACES,11X, + 2 6HVOLUME) + 540 FORMAT (1X,2I6,2X,3I6,2X,3F6.2,12X,1P,E13.6) + END diff --git a/Trivac/src/BIVSFH.f b/Trivac/src/BIVSFH.f new file mode 100755 index 0000000..d439f4a --- /dev/null +++ b/Trivac/src/BIVSFH.f @@ -0,0 +1,959 @@ +*DECK BIVSFH + SUBROUTINE BIVSFH (MAXEV,NBLOS,IMPX,ISPLH,IELEM,LXH,MAT,SIDE, + 1 NCODE,ICODE,ZCODE,LL4,VOL,IDL,IPERT,KN,QFR,IQFR,BFR,MU) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Numbering corresponding to a Thomas-Raviart-Schneider finite element +* discretization of a 2-D hexagonal geometry. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXEV allocated storage for vector MU. +* NBLOS number of lozenges per direction, taking into account +* mesh-splitting. +* IMPX print parameter. +* ISPLH mesh-splitting in 3*ISPLH**2 lozenges per hexagon. +* IELEM degree of the Lagrangian finite elements: =1 (linear); +* =2 (parabolic); =3 (cubic). +* LXH number of hexagons. +* MAT mixture index assigned to each lozenge. +* SIDE side of a lozenge. +* NCODE type of boundary condition applied on each side (I=1: hbc): +* NCODE(I)=1: VOID; =2: REFL; =6: ALBE; +* =5: SYME; =7: ZERO. +* ICODE physical albedo index on each side of the domain. +* ZCODE albedo corresponding to boundary condition 'VOID' on each +* side (ZCODE(I)=0.0 by default). +* +*Parameters: output +* LL4 order of the system matrices. +* VOL volume of each lozenge. +* IDL position of the average flux component associated with each +* lozenge. +* IPERT mixture permutation index. +* KN ADI permutation indices for the volumes and currents. +* QFR element-ordered boundary conditions. +* IQFR element-ordered physical albedo indices. +* BFR element-ordered surface fractions. +* MU compressed storage mode indices. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MAXEV,NBLOS,IMPX,ISPLH,IELEM,LXH,MAT(3,ISPLH**2,LXH), + 1 NCODE(4),ICODE(4),LL4,IDL(3,NBLOS),IPERT(NBLOS), + 2 KN(NBLOS,4+6*IELEM*(IELEM+1)),IQFR(NBLOS,6),MU(MAXEV) + REAL SIDE,ZCODE(4),VOL(3,NBLOS),QFR(NBLOS,6),BFR(NBLOS,6) +*---- +* LOCAL VARIABLES +*---- + LOGICAL COND,LL1,LL2 + INTEGER, DIMENSION(:),ALLOCATABLE :: IP,I1,I3,I4,I5 + INTEGER, DIMENSION(:,:),ALLOCATABLE :: IZGLOB + INTEGER, DIMENSION(:,:,:),ALLOCATABLE :: IJP +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IJP(LXH,ISPLH,ISPLH),IP(MAXEV),IZGLOB(NBLOS,3)) +*---- +* THOMAS-RAVIART-SCHNEIDER SPECIFIC NUMEROTATION +*---- + NBC=INT((SQRT(REAL((4*LXH-1)/3))+1.)/2.) + IF(LXH.NE.1+3*NBC*(NBC-1)) CALL XABORT('BIVSFH: INVALID VALUE OF' + 1 //' LXH(1).') + IF(ISPLH.EQ.1) THEN + DO 10 I=1,LXH + IJP(I,1,1)=I + 10 CONTINUE + ELSE + I=0 + DO 23 I0=1,2*NBC-1 + JMAX=NBC+I0-1 + IF(I0.GE.NBC) JMAX=3*NBC-I0-1 + IKEEP=I + DO 22 J0=1,JMAX + I=I+1 + DO 21 IM=1,ISPLH + DO 20 JM=1,ISPLH + IJP(I,IM,JM)=ISPLH*(IKEEP*ISPLH+(IM-1)*JMAX+J0-1)+JM + 20 CONTINUE + 21 CONTINUE + 22 CONTINUE + 23 CONTINUE + IF(I.NE.LXH) CALL XABORT('BIVSFH: INVALID VALUE OF LXH(2)') + ENDIF + ALLOCATE(I1(3*LXH),I3(2*LXH),I4(NBLOS),I5(NBLOS)) + DO 30 I=1,LXH + I3(I)=I + I4(I)=0 + IF(MAT(1,1,I).GT.0) I4(I)=I + 30 CONTINUE + IZGLOB(:NBLOS,:3)=0 + J1=2+3*(NBC-1)*(NBC-2) + IF(NBC.EQ.1) J1=1 + J3=J1+2*NBC-2 + J5=J3+2*NBC-2 + CALL BIVPER(J1,1,LXH,LXH,I1(1),I3) + CALL BIVPER(J3,3,LXH,LXH,I1(LXH+1),I3) + CALL BIVPER(J5,5,LXH,LXH,I1(2*LXH+1),I3) + DO 42 I=1,LXH + IOFW=I1(I) + IOFX=I1(LXH+I) + IOFY=I1(2*LXH+I) + DO 41 IM=1,ISPLH + DO 40 JM=1,ISPLH + IZGLOB(IJP(IOFW,IM,JM),1)=I4(I) + IZGLOB(IJP(IOFX,IM,JM),2)=I4(I) + IZGLOB(IJP(IOFY,IM,JM),3)=I4(I) + 40 CONTINUE + 41 CONTINUE + 42 CONTINUE + DO 50 I=1,LXH + II1=I1(I) + II2=I1(LXH+I) + II3=I1(2*LXH+I) + I3(II1)=II2 + I3(LXH+II1)=II3 + 50 CONTINUE +*---- +* COMPUTE THE FLUX PERMUTATION PART OF MATRIX KN (W <--> X) +*---- + KN(:NBLOS,:4+6*IELEM*(IELEM+1))=0 + LT4=0 + DO 70 II2=1,NBLOS + I=IZGLOB(II2,1) + I4(II2)=0 + IF(I.NE.0) THEN + LT4=LT4+1 + I4(II2)=LT4 + ENDIF + 70 CONTINUE + LT4=0 + DO 80 II2=1,NBLOS + I=IZGLOB(II2,2) + I5(II2)=0 + IF(I.NE.0) THEN + LT4=LT4+1 + I5(II2)=LT4 + ENDIF + 80 CONTINUE + IF(ISPLH.EQ.1) THEN + DO 90 I=1,LXH + IF(IZGLOB(I,1).EQ.0) GO TO 90 + KN(I4(I),2)=I5(I3(I))+LT4 + 90 CONTINUE + ELSE + I=0 + DO 105 I0=1,2*NBC-1 + JMAX=NBC+I0-1 + IF(I0.GE.NBC) JMAX=3*NBC-I0-1 + IKEEP=I + DO 100 J0=1,JMAX + I=I+1 + I1(I)=JMAX + I1(LXH+I)=IKEEP + I1(2*LXH+I)=J0 + 100 CONTINUE + 105 CONTINUE + DO 120 I=1,LXH + JMAX=I1(I) + IKEEP=I1(LXH+I) + J00=I1(2*LXH+I) + KMAX=I1(I3(I)) + JKEEP=I1(LXH+I3(I)) + K0=I1(2*LXH+I3(I)) + DO 115 IM=1,ISPLH + DO 110 JM=1,ISPLH + II1=ISPLH*(IKEEP*ISPLH+(IM-1)*JMAX+J00-1)+JM + II2=ISPLH*(JKEEP*ISPLH+(ISPLH-JM)*KMAX+K0-1)+IM + IF(IZGLOB(II1,1).EQ.0) GO TO 120 + KN(I4(II1),2)=I5(II2)+LT4 + 110 CONTINUE + 115 CONTINUE + 120 CONTINUE + ENDIF +*---- +* COMPUTE THE FLUX PERMUTATION PART OF MATRIX KN (X <--> Y) +*---- + LT4=0 + DO 130 II2=1,NBLOS + I=IZGLOB(II2,3) + I5(II2)=0 + IF(I.NE.0) THEN + LT4=LT4+1 + I5(II2)=LT4 + ENDIF + 130 CONTINUE + IF(ISPLH.EQ.1) THEN + DO 140 I=1,LXH + IF(IZGLOB(I,1).EQ.0) GO TO 140 + KN(I4(I),3)=I5(I3(LXH+I))+2*LT4 + 140 CONTINUE + ELSE + I=0 + DO 155 I0=1,2*NBC-1 + JMAX=NBC+I0-1 + IF(I0.GE.NBC) JMAX=3*NBC-I0-1 + IKEEP=I + DO 150 J0=1,JMAX + I=I+1 + I1(I)=JMAX + I1(LXH+I)=IKEEP + I1(2*LXH+I)=J0 + 150 CONTINUE + 155 CONTINUE + DO 170 I=1,LXH + JMAX=I1(I) + IKEEP=I1(LXH+I) + J00=I1(2*LXH+I) + KMAX=I1(I3(LXH+I)) + JKEEP=I1(LXH+I3(LXH+I)) + K0=I1(2*LXH+I3(LXH+I)) + DO 165 IM=1,ISPLH + DO 160 JM=1,ISPLH + II1=ISPLH*(IKEEP*ISPLH+(IM-1)*JMAX+J00-1)+JM + II2=ISPLH*(JKEEP*ISPLH+(ISPLH-IM)*KMAX+K0-1)+(ISPLH-JM+1) + IF(IZGLOB(II1,1).EQ.0) GO TO 170 + KN(I4(II1),3)=I5(II2)+2*LT4 + 160 CONTINUE + 165 CONTINUE + 170 CONTINUE + ENDIF +*---- +* COMPUTE THE FLUX PERMUTATION PART OF MATRIX KN (Y <--> W) +*---- + IF(ISPLH.EQ.1) THEN + DO 180 I=1,LXH + IF(IZGLOB(I,1).EQ.0) GO TO 180 + KN(I4(I),4)=I4(I) + 180 CONTINUE + ELSE + I=0 + DO 195 I0=1,2*NBC-1 + JMAX=NBC+I0-1 + IF(I0.GE.NBC) JMAX=3*NBC-I0-1 + IKEEP=I + DO 190 J0=1,JMAX + I=I+1 + I1(I)=JMAX + I1(LXH+I)=IKEEP + I1(2*LXH+I)=J0 + 190 CONTINUE + 195 CONTINUE + DO 210 I=1,LXH + JMAX=I1(I) + IKEEP=I1(LXH+I) + J00=I1(2*LXH+I) + DO 205 IM=1,ISPLH + DO 200 JM=1,ISPLH + II1=ISPLH*(IKEEP*ISPLH+(IM-1)*JMAX+J00-1)+JM + II2=ISPLH*(IKEEP*ISPLH+(JM-1)*JMAX+J00-1)+(ISPLH-IM+1) + IF(IZGLOB(II1,1).EQ.0) GO TO 210 + KN(I4(II1),4)=I4(II2) + 200 CONTINUE + 205 CONTINUE + 210 CONTINUE + ENDIF + DEALLOCATE(I5,I4,I3,I1) +*---- +* SET THE CURRENT NUMBERING PART OF MATRIX KN AND MATRIX QFR (W-AXIS) +*---- + LL4W0=(2*NBLOS*IELEM+(2*NBC-1)*ISPLH)*IELEM + LL4F=3*LT4*IELEM*IELEM + QFR(:NBLOS,:6)=0.0 + IQFR(:NBLOS,:6)=0 + BFR(:NBLOS,:6)=0.0 + ALBEDO=0.5*(1.0-ZCODE(1))/(1.0+ZCODE(1)) + NELEM=IELEM*(IELEM+1) + NB1=(2*NBC*IELEM*ISPLH+1)*IELEM*ISPLH + KEL=0 + NDDIR=LL4F + NUM=0 + DO 290 JSTAGE=1,NBC + DO 282 JEL=1,ISPLH + DO 281 IRANG=1,NBC+JSTAGE-1 + DO 280 IEL=1,ISPLH + KEL=KEL+1 + IF(IZGLOB(KEL,1).EQ.0) GO TO 280 + NUM=NUM+1 + KN(NUM,1)=NUM + IF((IRANG.EQ.1).AND.(IEL.EQ.1)) THEN + LL1=.TRUE. + ELSE + LL1=(IZGLOB(KEL-1,1).EQ.0) + ENDIF + IF((IRANG.EQ.NBC+JSTAGE-1).AND.(IEL.EQ.ISPLH)) THEN + LL2=.TRUE. + ELSE + LL2=(IZGLOB(KEL+1,1).EQ.0) + ENDIF + LCOUR=0 + DO 255 J=1,IELEM + DO 250 I=1,IELEM+1 + LCOUR=LCOUR+1 + ITEMP = NDDIR + > + (JEL-1)*(2*(NBC+JSTAGE-1)*IELEM*ISPLH+1)*IELEM + > + (IRANG-1)*(2*IELEM*ISPLH) + > + (IEL-1)*IELEM + > + (J-1)*(2*(NBC+JSTAGE-1)*IELEM*ISPLH+1) + I + IF(LCOUR.GT.NELEM) CALL XABORT('BIVSFH: bug1') + IF(KEL.GT.NBLOS) CALL XABORT('BIVSFH: bug2') + KN(NUM,4+LCOUR)=ITEMP + KN(NUM,4+NELEM+LCOUR)=ITEMP+IELEM*ISPLH + 250 CONTINUE + 255 CONTINUE + IF(LL1) THEN + COND=(NCODE(1).EQ.2).OR.((NCODE(1).EQ.1).AND.(ZCODE(1).EQ.1.0)) + IF(COND) THEN + DO 260 I=1,IELEM + KN(NUM,4+(I-1)*(IELEM+1)+1)=0 + 260 CONTINUE + ELSE IF((NCODE(1).EQ.1).AND.(ICODE(1).EQ.0)) THEN + QFR(NUM,1)=SIDE/ALBEDO + ELSE IF(NCODE(1).EQ.1) THEN + QFR(NUM,1)=SIDE + IQFR(NUM,1)=ICODE(1) + ENDIF + IF((NCODE(1).EQ.1).OR.(NCODE(1).EQ.7)) BFR(NUM,1)=SIDE + ENDIF + IF(LL2) THEN + COND=(NCODE(1).EQ.2).OR.((NCODE(1).EQ.1).AND.(ZCODE(1).EQ.1.0)) + IF(COND) THEN + DO 270 I=1,IELEM + KN(NUM,4+NELEM+I*(IELEM+1))=0 + 270 CONTINUE + ELSE IF((NCODE(1).EQ.1).AND.(ICODE(1).EQ.0)) THEN + QFR(NUM,2)=SIDE/ALBEDO + ELSE IF(NCODE(1).EQ.1) THEN + QFR(NUM,2)=SIDE + IQFR(NUM,2)=ICODE(1) + ENDIF + IF((NCODE(1).EQ.1).OR.(NCODE(1).EQ.7)) BFR(NUM,2)=SIDE + ENDIF + 280 CONTINUE + 281 CONTINUE + 282 CONTINUE + NDDIR=NDDIR+NB1+(2*(JSTAGE-1)*IELEM*ISPLH)*IELEM*ISPLH + 290 CONTINUE +* + DO 340 JSTAGE=NBC+1,2*NBC-1 + DO 332 JEL=1,ISPLH + DO 331 IRANG=1,(2*NBC-2)-(JSTAGE-NBC-1) + DO 330 IEL=1,ISPLH + KEL=KEL+1 + IF(IZGLOB(KEL,1).EQ.0) GO TO 330 + NUM=NUM+1 + KN(NUM,1)=NUM + IF((IRANG.EQ.1).AND.(IEL.EQ.1)) THEN + LL1=.TRUE. + ELSE + LL1=(IZGLOB(KEL-1,1).EQ.0) + ENDIF + IF((IRANG.EQ.(2*NBC-2)-(JSTAGE-NBC-1)).AND.(IEL.EQ.ISPLH)) THEN + LL2=.TRUE. + ELSE + LL2=(IZGLOB(KEL+1,1).EQ.0) + ENDIF + LCOUR=0 + DO 305 J=1,IELEM + DO 300 I=1,IELEM+1 + LCOUR=LCOUR+1 + ITEMP = NDDIR + > + (JEL-1)*(2*(2*NBC-1+NBC-JSTAGE)*IELEM*ISPLH+1)*IELEM + > + (IRANG-1)*(2*IELEM*ISPLH) + > + (IEL-1)*IELEM + > + (J-1)*(2*(2*NBC-1+NBC-JSTAGE)*IELEM*ISPLH+1) + I + IF(LCOUR.GT.NELEM) CALL XABORT('BIVSFH: bug3') + IF(KEL.GT.NBLOS) CALL XABORT('BIVSFH: bug4') + KN(NUM,4+LCOUR)=ITEMP + KN(NUM,4+NELEM+LCOUR)=ITEMP+IELEM*ISPLH + 300 CONTINUE + 305 CONTINUE + IF(LL1) THEN + COND=(NCODE(1).EQ.2).OR.((NCODE(1).EQ.1).AND.(ZCODE(1).EQ.1.0)) + IF(COND) THEN + DO 310 I=1,IELEM + KN(NUM,4+(I-1)*(IELEM+1)+1)=0 + 310 CONTINUE + ELSE IF((NCODE(1).EQ.1).AND.(ICODE(1).EQ.0)) THEN + QFR(NUM,1)=SIDE/ALBEDO + ELSE IF(NCODE(1).EQ.1) THEN + QFR(NUM,1)=SIDE + IQFR(NUM,1)=ICODE(1) + ENDIF + IF((NCODE(1).EQ.1).OR.(NCODE(1).EQ.7)) BFR(NUM,1)=SIDE + ENDIF + IF(LL2) THEN + COND=(NCODE(1).EQ.2).OR.((NCODE(1).EQ.1).AND.(ZCODE(1).EQ.1.0)) + IF(COND) THEN + DO 320 I=1,IELEM + KN(NUM,4+NELEM+I*(IELEM+1))=0 + 320 CONTINUE + ELSE IF((NCODE(1).EQ.1).AND.(ICODE(1).EQ.0)) THEN + QFR(NUM,2)=SIDE/ALBEDO + ELSE IF(NCODE(1).EQ.1) THEN + QFR(NUM,2)=SIDE + IQFR(NUM,2)=ICODE(1) + ENDIF + IF((NCODE(1).EQ.1).OR.(NCODE(1).EQ.7)) BFR(NUM,2)=SIDE + ENDIF + 330 CONTINUE + 331 CONTINUE + 332 CONTINUE + NDDIR=NDDIR+(2*(2*NBC-1)*IELEM*ISPLH+1)*IELEM*ISPLH + > -(2*(JSTAGE-NBC)*IELEM*ISPLH)*IELEM*ISPLH + 340 CONTINUE +*---- +* SET THE CURRENT NUMBERING PART OF MATRIX KN AND MATRIX QFR (X-AXIS) +*---- + IP(:NBLOS)=0 + DO 350 NUM=1,LT4 + IP(KN(NUM,2)-LT4)=NUM + 350 CONTINUE + KEL=0 + NUM=0 + DO 400 JSTAGE=1,NBC + DO 392 JEL=1,ISPLH + DO 391 IRANG=1,NBC+JSTAGE-1 + DO 390 IEL=1,ISPLH + KEL=KEL+1 + IF(IZGLOB(KEL,2).EQ.0) GO TO 390 + NUM=NUM+1 + IF((IRANG.EQ.1).AND.(IEL.EQ.1)) THEN + LL1=.TRUE. + ELSE + LL1=(IZGLOB(KEL-1,2).EQ.0) + ENDIF + IF((IRANG.EQ.NBC+JSTAGE-1).AND.(IEL.EQ.ISPLH)) THEN + LL2=.TRUE. + ELSE + LL2=(IZGLOB(KEL+1,2).EQ.0) + ENDIF + LCOUR=0 + DO 365 J=1,IELEM + DO 360 I=1,IELEM+1 + LCOUR=LCOUR+1 + ITEMP = NDDIR + > + (JEL-1)*(2*(NBC+JSTAGE-1)*IELEM*ISPLH+1)*IELEM + > + (IRANG-1)*(2*IELEM*ISPLH) + > + (IEL-1)*IELEM + > + (J-1)*(2*(NBC+JSTAGE-1)*IELEM*ISPLH+1) + I + IF(LCOUR.GT.NELEM) CALL XABORT('BIVSFH: bug5') + IF(KEL.GT.NBLOS) CALL XABORT('BIVSFH: bug6') + KN(IP(NUM),4+2*NELEM+LCOUR)=ITEMP + KN(IP(NUM),4+3*NELEM+LCOUR)=ITEMP+IELEM*ISPLH + 360 CONTINUE + 365 CONTINUE + IF(LL1) THEN + COND=(NCODE(1).EQ.2).OR.((NCODE(1).EQ.1).AND.(ZCODE(1).EQ.1.0)) + IF(COND) THEN + DO 370 I=1,IELEM + KN(IP(NUM),4+2*NELEM+(I-1)*(IELEM+1)+1)=0 + 370 CONTINUE + ELSE IF((NCODE(1).EQ.1).AND.(ICODE(1).EQ.0)) THEN + QFR(IP(NUM),3)=SIDE/ALBEDO + ELSE IF(NCODE(1).EQ.1) THEN + QFR(IP(NUM),3)=SIDE + IQFR(NUM,3)=ICODE(1) + ENDIF + IF((NCODE(1).EQ.1).OR.(NCODE(1).EQ.7)) BFR(NUM,3)=SIDE + ENDIF + IF(LL2) THEN + COND=(NCODE(1).EQ.2).OR.((NCODE(1).EQ.1).AND.(ZCODE(1).EQ.1.0)) + IF(COND) THEN + DO 380 I=1,IELEM + KN(IP(NUM),4+3*NELEM+I*(IELEM+1))=0 + 380 CONTINUE + ELSE IF((NCODE(1).EQ.1).AND.(ICODE(1).EQ.0)) THEN + QFR(IP(NUM),4)=SIDE/ALBEDO + ELSE IF(NCODE(1).EQ.1) THEN + QFR(IP(NUM),4)=SIDE + IQFR(NUM,4)=ICODE(1) + ENDIF + IF((NCODE(1).EQ.1).OR.(NCODE(1).EQ.7)) BFR(NUM,4)=SIDE + ENDIF + 390 CONTINUE + 391 CONTINUE + 392 CONTINUE + NDDIR=NDDIR+NB1+(2*(JSTAGE-1)*IELEM*ISPLH)*IELEM*ISPLH + 400 CONTINUE +* + DO 450 JSTAGE=NBC+1,2*NBC-1 + DO 442 JEL=1,ISPLH + DO 441 IRANG=1,(2*NBC-2)-(JSTAGE-NBC-1) + DO 440 IEL=1,ISPLH + KEL=KEL+1 + IF(IZGLOB(KEL,2).EQ.0) GO TO 440 + NUM=NUM+1 + IF((IRANG.EQ.1).AND.(IEL.EQ.1)) THEN + LL1=.TRUE. + ELSE + LL1=(IZGLOB(KEL-1,2).EQ.0) + ENDIF + IF((IRANG.EQ.(2*NBC-2)-(JSTAGE-NBC-1)).AND.(IEL.EQ.ISPLH)) THEN + LL2=.TRUE. + ELSE + LL2=(IZGLOB(KEL+1,2).EQ.0) + ENDIF + LCOUR=0 + DO 415 J=1,IELEM + DO 410 I=1,IELEM+1 + LCOUR=LCOUR+1 + ITEMP = NDDIR + > + (JEL-1)*(2*(2*NBC-1+NBC-JSTAGE)*IELEM*ISPLH+1)*IELEM + > + (IRANG-1)*(2*IELEM*ISPLH) + > + (IEL-1)*IELEM + > + (J-1)*(2*(2*NBC-1+NBC-JSTAGE)*IELEM*ISPLH+1) + I + IF(LCOUR.GT.NELEM) CALL XABORT('BIVSFH: bug7') + IF(KEL.GT.NBLOS) CALL XABORT('BIVSFH: bug8') + KN(IP(NUM),4+2*NELEM+LCOUR)=ITEMP + KN(IP(NUM),4+3*NELEM+LCOUR)=ITEMP+IELEM*ISPLH + 410 CONTINUE + 415 CONTINUE + IF(LL1) THEN + COND=(NCODE(1).EQ.2).OR.((NCODE(1).EQ.1).AND.(ZCODE(1).EQ.1.0)) + IF(COND) THEN + DO 420 I=1,IELEM + KN(IP(NUM),4+2*NELEM+(I-1)*(IELEM+1)+1)=0 + 420 CONTINUE + ELSE IF((NCODE(1).EQ.1).AND.(ICODE(1).EQ.0)) THEN + QFR(IP(NUM),3)=SIDE/ALBEDO + ELSE IF(NCODE(1).EQ.1) THEN + QFR(IP(NUM),3)=SIDE + IQFR(NUM,3)=ICODE(1) + ENDIF + IF((NCODE(1).EQ.1).OR.(NCODE(1).EQ.7)) BFR(NUM,3)=SIDE + ENDIF + IF(LL2) THEN + COND=(NCODE(1).EQ.2).OR.((NCODE(1).EQ.1).AND.(ZCODE(1).EQ.1.0)) + IF(COND) THEN + DO 430 I=1,IELEM + KN(IP(NUM),4+3*NELEM+I*(IELEM+1))=0 + 430 CONTINUE + ELSE IF((NCODE(1).EQ.1).AND.(ICODE(1).EQ.0)) THEN + QFR(IP(NUM),4)=SIDE/ALBEDO + ELSE IF(NCODE(1).EQ.1) THEN + QFR(IP(NUM),4)=SIDE + IQFR(NUM,4)=ICODE(1) + ENDIF + IF((NCODE(1).EQ.1).OR.(NCODE(1).EQ.7)) BFR(NUM,4)=SIDE + ENDIF + 440 CONTINUE + 441 CONTINUE + 442 CONTINUE + NDDIR=NDDIR+(2*(2*NBC-1)*IELEM*ISPLH+1)*IELEM*ISPLH + > -(2*(JSTAGE-NBC)*IELEM*ISPLH)*IELEM*ISPLH + 450 CONTINUE +*---- +* SET THE CURRENT NUMBERING PART OF MATRIX KN AND MATRIX QFR (Y-AXIS) +*---- + IP(:NBLOS)=0 + DO 460 NUM=1,LT4 + IP(KN(NUM,3)-2*LT4)=NUM + 460 CONTINUE + KEL=0 + NUM=0 + DO 510 JSTAGE=1,NBC + DO 502 JEL=1,ISPLH + DO 501 IRANG=1,NBC+JSTAGE-1 + DO 500 IEL=1,ISPLH + KEL=KEL+1 + IF(IZGLOB(KEL,3).EQ.0) GO TO 500 + NUM=NUM+1 + IF((IRANG.EQ.1).AND.(IEL.EQ.1)) THEN + LL1=.TRUE. + ELSE + LL1=(IZGLOB(KEL-1,3).EQ.0) + ENDIF + IF((IRANG.EQ.NBC+JSTAGE-1).AND.(IEL.EQ.ISPLH)) THEN + LL2=.TRUE. + ELSE + LL2=(IZGLOB(KEL+1,3).EQ.0) + ENDIF + LCOUR=0 + DO 475 J=1,IELEM + DO 470 I=1,IELEM+1 + LCOUR=LCOUR+1 + ITEMP = NDDIR + > + (JEL-1)*(2*(NBC+JSTAGE-1)*IELEM*ISPLH+1)*IELEM + > + (IRANG-1)*(2*IELEM*ISPLH) + > + (IEL-1)*IELEM + > + (J-1)*(2*(NBC+JSTAGE-1)*IELEM*ISPLH+1) + I + IF(LCOUR.GT.NELEM) CALL XABORT('BIVSFH: bug9') + IF(KEL.GT.NBLOS) CALL XABORT('BIVSFH: bug10') + KN(IP(NUM),4+4*NELEM+LCOUR)=ITEMP + KN(IP(NUM),4+5*NELEM+LCOUR)=ITEMP+IELEM*ISPLH + 470 CONTINUE + 475 CONTINUE + IF(LL1) THEN + COND=(NCODE(1).EQ.2).OR.((NCODE(1).EQ.1).AND.(ZCODE(1).EQ.1.0)) + IF(COND) THEN + DO 480 I=1,IELEM + KN(IP(NUM),4+4*NELEM+(I-1)*(IELEM+1)+1)=0 + 480 CONTINUE + ELSE IF((NCODE(1).EQ.1).AND.(ICODE(1).EQ.0)) THEN + QFR(IP(NUM),5)=SIDE/ALBEDO + ELSE IF(NCODE(1).EQ.1) THEN + QFR(IP(NUM),5)=SIDE + IQFR(NUM,5)=ICODE(1) + ENDIF + IF((NCODE(1).EQ.1).OR.(NCODE(1).EQ.7)) BFR(NUM,5)=SIDE + ENDIF + IF(LL2) THEN + COND=(NCODE(1).EQ.2).OR.((NCODE(1).EQ.1).AND.(ZCODE(1).EQ.1.0)) + IF(COND) THEN + DO 490 I=1,IELEM + KN(IP(NUM),4+5*NELEM+I*(IELEM+1))=0 + 490 CONTINUE + ELSE IF((NCODE(1).EQ.1).AND.(ICODE(1).EQ.0)) THEN + QFR(IP(NUM),6)=SIDE/ALBEDO + ELSE IF(NCODE(1).EQ.1) THEN + QFR(IP(NUM),6)=SIDE + IQFR(NUM,6)=ICODE(1) + ENDIF + IF((NCODE(1).EQ.1).OR.(NCODE(1).EQ.7)) BFR(NUM,6)=SIDE + ENDIF + 500 CONTINUE + 501 CONTINUE + 502 CONTINUE + NDDIR=NDDIR+NB1+(2*(JSTAGE-1)*IELEM*ISPLH)*IELEM*ISPLH + 510 CONTINUE +* + DO 560 JSTAGE=NBC+1,2*NBC-1 + DO 552 JEL=1,ISPLH + DO 551 IRANG=1,(2*NBC-2)-(JSTAGE-NBC-1) + DO 550 IEL=1,ISPLH + KEL=KEL+1 + IF(IZGLOB(KEL,3).EQ.0) GO TO 550 + NUM=NUM+1 + IF((IRANG.EQ.1).AND.(IEL.EQ.1)) THEN + LL1=.TRUE. + ELSE + LL1=(IZGLOB(KEL-1,3).EQ.0) + ENDIF + IF((IRANG.EQ.(2*NBC-2)-(JSTAGE-NBC-1)).AND.(IEL.EQ.ISPLH)) THEN + LL2=.TRUE. + ELSE + LL2=(IZGLOB(KEL+1,3).EQ.0) + ENDIF + LCOUR=0 + DO 525 J=1,IELEM + DO 520 I=1,IELEM+1 + LCOUR=LCOUR+1 + ITEMP = NDDIR + > + (JEL-1)*(2*(2*NBC-1+NBC-JSTAGE)*IELEM*ISPLH+1)*IELEM + > + (IRANG-1)*(2*IELEM*ISPLH) + > + (IEL-1)*IELEM + > + (J-1)*(2*(2*NBC-1+NBC-JSTAGE)*IELEM*ISPLH+1) + I + IF(LCOUR.GT.NELEM) CALL XABORT('BIVSFH: bug11') + IF(KEL.GT.NBLOS) CALL XABORT('BIVSFH: bug12') + KN(IP(NUM),4+4*NELEM+LCOUR)=ITEMP + KN(IP(NUM),4+5*NELEM+LCOUR)=ITEMP+IELEM*ISPLH + 520 CONTINUE + 525 CONTINUE + IF(LL1) THEN + COND=(NCODE(1).EQ.2).OR.((NCODE(1).EQ.1).AND.(ZCODE(1).EQ.1.0)) + IF(COND) THEN + DO 530 I=1,IELEM + KN(IP(NUM),4+4*NELEM+(I-1)*(IELEM+1)+1)=0 + 530 CONTINUE + ELSE IF((NCODE(1).EQ.1).AND.(ICODE(1).EQ.0)) THEN + QFR(IP(NUM),5)=SIDE/ALBEDO + ELSE IF(NCODE(1).EQ.1) THEN + QFR(IP(NUM),5)=SIDE + IQFR(NUM,5)=ICODE(1) + ENDIF + IF((NCODE(1).EQ.1).OR.(NCODE(1).EQ.7)) BFR(NUM,5)=SIDE + ENDIF + IF(LL2) THEN + COND=(NCODE(1).EQ.2).OR.((NCODE(1).EQ.1).AND.(ZCODE(1).EQ.1.0)) + IF(COND) THEN + DO 540 I=1,IELEM + KN(IP(NUM),4+5*NELEM+I*(IELEM+1))=0 + 540 CONTINUE + ELSE IF((NCODE(1).EQ.1).AND.(ICODE(1).EQ.0)) THEN + QFR(IP(NUM),6)=SIDE/ALBEDO + ELSE IF(NCODE(1).EQ.1) THEN + QFR(IP(NUM),6)=SIDE + IQFR(NUM,6)=ICODE(1) + ENDIF + IF((NCODE(1).EQ.1).OR.(NCODE(1).EQ.7)) BFR(NUM,6)=SIDE + ENDIF + 550 CONTINUE + 551 CONTINUE + 552 CONTINUE + NDDIR=NDDIR+(2*(2*NBC-1)*IELEM*ISPLH+1)*IELEM*ISPLH + > -(2*(JSTAGE-NBC)*IELEM*ISPLH)*IELEM*ISPLH + 560 CONTINUE +*---- +* COMPUTE THE SURFACE FRACTIONS +*---- + SURFTOT=0.0 + DO 566 I=1,NBLOS + DO 565 J=1,6 + SURFTOT=SURFTOT+BFR(I,J) + 565 CONTINUE + 566 CONTINUE + IF(SURFTOT.GT.0.0) THEN + DO 575 I=1,NBLOS + DO 570 J=1,6 + BFR(I,J)=BFR(I,J)/SURFTOT + 570 CONTINUE + 575 CONTINUE + ENDIF +*---- +* REORDER THE UNKNOWNS AND REMOVE THE UNUSED UNKNOWNS INDICES FROM KN +*---- + IP(:LL4F+3*LL4W0)=0 + LL4=0 + DO 591 KEL=1,LT4 + DO 582 IFLUX=1,4 + NUM=KN(KEL,IFLUX) + DO 581 K2=1,IELEM + DO 580 K1=1,IELEM + JND1=(NUM-1)*IELEM**2+(K2-1)*IELEM+K1 + IF(JND1.GT.MAXEV) CALL XABORT('BIVSFH: MAXEV OVERFLOW(1).') + IF(IP(JND1).EQ.0) THEN + LL4=LL4+1 + IP(JND1)=LL4 + ENDIF + 580 CONTINUE + 581 CONTINUE + 582 CONTINUE + DO 590 ICOUR=1,6*NELEM + IND=ABS(KN(KEL,4+ICOUR)) + IF(IND.GT.MAXEV) CALL XABORT('BIVSFH: MAXEV OVERFLOW(2).') + IF(IND.NE.0) THEN + IF(IP(IND).EQ.0) THEN + LL4=LL4+1 + IP(IND)=LL4 + ENDIF + ENDIF + 590 CONTINUE + 591 CONTINUE + DO 605 KEL=1,LT4 + DO 595 IFLUX=1,4 + NUM=KN(KEL,IFLUX) + KN(KEL,IFLUX)=IP((NUM-1)*IELEM**2+1) + 595 CONTINUE + DO 600 ICOUR=1,6*NELEM + IF(KN(KEL,4+ICOUR).NE.0) THEN + IND=KN(KEL,4+ICOUR) + KN(KEL,4+ICOUR)=SIGN(IP(ABS(IND)),IND) + ENDIF + 600 CONTINUE + 605 CONTINUE +*---- +* PRINT A FEW GEOMETRY CHARACTERISTICS +*---- + IF(IMPX.GT.0) THEN + write(6,*) ' ' + write(6,*) 'ISPLH =',ISPLH + write(6,*) 'IELEM =',IELEM + write(6,*) 'NELEM =',NELEM + write(6,*) 'NBLOS =',NBLOS + write(6,*) 'LL4F =',LL4F + write(6,*) 'LL4 =',LL4 + write(6,*) 'NBC =',NBC + ENDIF +*---- +* SET IPERT +*---- + KEL=0 + DO 613 JSTAGE=1,NBC + DO 612 JEL=1,ISPLH + DO 611 IRANG=1,NBC+JSTAGE-1 + DO 610 IEL=1,ISPLH + KEL=KEL+1 + IHEX=IZGLOB(KEL,1) + IF(IHEX.EQ.0) THEN + IPERT(KEL)=0 + ELSE + IPERT(KEL)=(IHEX-1)*ISPLH**2+(IEL-1)*ISPLH+JEL + ENDIF + 610 CONTINUE + 611 CONTINUE + 612 CONTINUE + 613 CONTINUE + DO 623 JSTAGE=NBC+1,2*NBC-1 + DO 622 JEL=1,ISPLH + DO 621 IRANG=1,(2*NBC-2)-(JSTAGE-NBC-1) + DO 620 IEL=1,ISPLH + KEL=KEL+1 + IHEX=IZGLOB(KEL,1) + IF(IHEX.EQ.0) THEN + IPERT(KEL)=0 + ELSE + IPERT(KEL)=(IHEX-1)*ISPLH**2+(IEL-1)*ISPLH+JEL + ENDIF + 620 CONTINUE + 621 CONTINUE + 622 CONTINUE + 623 CONTINUE + IF(KEL.NE.NBLOS) CALL XABORT('BIVSFH: IPERT FAILURE.') +*---- +* SET IDL AND VOL +*---- + NUM=0 + IDL(:3,:NBLOS)=0 + VOL(:3,:NBLOS)=0.0 + DO 630 KEL=1,NBLOS + KEL2=IPERT(KEL) + IF(KEL2.EQ.0) GO TO 630 + NUM=NUM+1 + IDL(:3,KEL2)=KN(NUM,:3) + VOL(:3,KEL2)=2.59807587*SIDE*SIDE/REAL(3) + 630 CONTINUE + IF(IMPX.GT.2) THEN + WRITE(6,800) 'MAT',(((MAT(I,J,K),I=1,3),J=1,ISPLH**2),K=1,LXH) + WRITE(6,800) 'IDL',((IDL(I,J),I=1,3),J=1,NBLOS) + WRITE(6,810) 'VOL',((VOL(I,J),I=1,3),J=1,NBLOS) + ENDIF +*---- +* COMPUTE THE SYSTEM MATRIX BANDWIDTH. +*---- + MU(:LL4)=1 + NUM=0 + DO 690 KEL=1,NBLOS + IF(IZGLOB(KEL,1).EQ.0) GO TO 690 + NUM=NUM+1 + DO 663 K4=0,1 + DO 662 K3=0,IELEM-1 + DO 661 K2=1,IELEM+1 + INW1=ABS(KN(NUM,4+K4*NELEM+K3*(IELEM+1)+K2)) + INX1=ABS(KN(NUM,4+(K4+2)*NELEM+K3*(IELEM+1)+K2)) + INY1=ABS(KN(NUM,4+(K4+4)*NELEM+K3*(IELEM+1)+K2)) + DO 650 K1=1,IELEM+1 + INW2=ABS(KN(NUM,4+K4*NELEM+K3*(IELEM+1)+K1)) + INX2=ABS(KN(NUM,4+(K4+2)*NELEM+K3*(IELEM+1)+K1)) + INY2=ABS(KN(NUM,4+(K4+4)*NELEM+K3*(IELEM+1)+K1)) + IF((INW2.NE.0).AND.(INW1.NE.0)) THEN + MU(INW1)=MAX(MU(INW1),INW1-INW2+1) + MU(INW2)=MAX(MU(INW2),INW2-INW1+1) + ENDIF + IF((INX2.NE.0).AND.(INX1.NE.0)) THEN + MU(INX1)=MAX(MU(INX1),INX1-INX2+1) + MU(INX2)=MAX(MU(INX2),INX2-INX1+1) + ENDIF + IF((INY2.NE.0).AND.(INY1.NE.0)) THEN + MU(INY1)=MAX(MU(INY1),INY1-INY2+1) + MU(INY2)=MAX(MU(INY2),INY2-INY1+1) + ENDIF + 650 CONTINUE + DO 660 K1=0,IELEM-1 + IF(K4.EQ.0) THEN + JND1=KN(NUM,1)+K3*IELEM+K1 + JND2=KN(NUM,2)+K3*IELEM+K1 + JND3=KN(NUM,3)+K3*IELEM+K1 + ELSE + JND1=KN(NUM,2)+K1*IELEM+K3 + JND2=KN(NUM,3)+K1*IELEM+K3 + JND3=KN(NUM,4)+K1*IELEM+K3 + ENDIF + IF(INW1.NE.0) THEN + MU(JND1)=MAX(MU(JND1),JND1-INW1+1) + MU(INW1)=MAX(MU(INW1),INW1-JND1+1) + ENDIF + IF(INX1.NE.0) THEN + MU(JND2)=MAX(MU(JND2),JND2-INX1+1) + MU(INX1)=MAX(MU(INX1),INX1-JND2+1) + ENDIF + IF(INY1.NE.0) THEN + MU(JND3)=MAX(MU(JND3),JND3-INY1+1) + MU(INY1)=MAX(MU(INY1),INY1-JND3+1) + ENDIF + 660 CONTINUE + 661 CONTINUE + 662 CONTINUE + 663 CONTINUE + ITRS=0 + DO I=1,LT4 + IF(KN(I,1).EQ.KN(NUM,4)) THEN + ITRS=I + GO TO 670 + ENDIF + ENDDO + CALL XABORT('BIVSFH: ITRS FAILURE.') + 670 DO 685 I=1,NELEM + INW1=ABS(KN(ITRS,4+I)) + INX1=ABS(KN(NUM,4+2*NELEM+I)) + INY1=ABS(KN(NUM,4+4*NELEM+I)) + DO 680 J=1,NELEM + INW2=ABS(KN(NUM,4+NELEM+J)) + INX2=ABS(KN(NUM,4+3*NELEM+J)) + INY2=ABS(KN(NUM,4+5*NELEM+J)) + IF((INY2.NE.0).AND.(INW1.NE.0)) THEN + MU(INW1)=MAX(MU(INW1),INW1-INY2+1) + MU(INY2)=MAX(MU(INY2),INY2-INW1+1) + ENDIF + IF((INW2.NE.0).AND.(INX1.NE.0)) THEN + MU(INX1)=MAX(MU(INX1),INX1-INW2+1) + MU(INW2)=MAX(MU(INW2),INW2-INX1+1) + ENDIF + IF((INX2.NE.0).AND.(INY1.NE.0)) THEN + MU(INY1)=MAX(MU(INY1),INY1-INX2+1) + MU(INX2)=MAX(MU(INX2),INX2-INY1+1) + ENDIF + 680 CONTINUE + 685 CONTINUE + 690 CONTINUE + MUMAX=0 + IIMAX=0 + DO 700 I=1,LL4 + MUMAX=MAX(MUMAX,MU(I)) + IIMAX=IIMAX+MU(I) + MU(I)=IIMAX + 700 CONTINUE +* + IF(IMPX.GT.0) WRITE(6,820) LL4 + IF(IMPX.GT.2) THEN + WRITE (6,830) MUMAX,IIMAX + WRITE (6,840) + DO 710 K=1,LXH*ISPLH**2 + WRITE (6,850) K,(IZGLOB(K,I),I=1,3) + 710 CONTINUE + WRITE (6,860) + DO 720 K=1,LT4 + WRITE (6,870) K,(KN(K,I),I=1,4+2*NELEM) + WRITE (6,880) 'X',(KN(K,I),I=4+2*NELEM+1,4+4*NELEM) + WRITE (6,880) 'Y',(KN(K,I),I=4+4*NELEM+1,4+6*NELEM) + 720 CONTINUE + WRITE (6,890) + DO 730 K=1,LXH*ISPLH**2 + WRITE (6,900) K,(QFR(K,I),I=1,6) + 730 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IZGLOB,IJP,IP) + RETURN +* + 800 FORMAT(1X,A3/14(2X,I6)) + 810 FORMAT(1X,A3/7(2X,E12.5)) + 820 FORMAT(31H NUMBER OF UNKNOWNS PER GROUP =,I6) + 830 FORMAT(/41H BIVSFH: MAXIMUM BANDWIDTH FOR MATRICES =,I6/9X, + 1 51HNUMBER OF TERMS IN THE COMPRESSED SYSTEM MATRICES =,I10) + 840 FORMAT(/22H NUMBERING OF HEXAGONS/1X,21(1H-)//8H ELEMENT,4X, + 1 24H W ----- X ----- Y -----) + 850 FORMAT(1X,I6,5X,3I8) + 860 FORMAT(/22H NUMBERING OF UNKNOWNS/1X,21(1H-)//8H ELEMENT,5X, + 1 27H---> W ---> X ---> Y ---> W,4X,8HCURRENTS,89(1H.)) + 870 FORMAT(1X,I6,5X,4I7,4X,1HW,12I8:/(45X,12I8)) + 880 FORMAT(44X,A1,12I8:/(45X,12I8)) + 890 FORMAT(/8H ELEMENT,3X,23HVOID BOUNDARY CONDITION/15X,7(1H-), + 1 3H W ,7(1H-),3X,7(1H-),3H X ,7(1H-),3X,7(1H-),3H Y ,7(1H-)) + 900 FORMAT(1X,I6,5X,1P,10E10.1/(12X,1P,10E10.1)) + END diff --git a/Trivac/src/BIVSPS.f b/Trivac/src/BIVSPS.f new file mode 100755 index 0000000..d9e1ff4 --- /dev/null +++ b/Trivac/src/BIVSPS.f @@ -0,0 +1,300 @@ +*DECK BIVSPS + SUBROUTINE BIVSPS(IPTRK,IPMACR,IPSYS,IMPX,NGRP,NEL,NLF,NANI,NBFIS, + 1 NALBP,LDIFF,MAT,VOL,NBMIX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover the cross-section data in LCM object with pointer IPMACR, +* compute and store the corresponding system matrices for a simplified +* PN approximation. +* +*Copyright: +* Copyright (C) 2004 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK L_TRACK pointer to the bivac tracking information. +* IPMACR L_MACROLIB pointer to the cross sections. +* IPSYS L_SYSTEM pointer to system matrices. +* IMPX print parameter (equal to zero for no print). +* NGRP number of energy groups. +* NEL total number of finite elements. +* NLF number of Legendre orders for the flux (even number). +* NANI number of Legendre orders for the scattering cross sections. +* NBFIS number of fissionable isotopes. +* NALBP number of physical albedos per energy group. +* LDIFF flag set to .true. to use 1/3D as 'NTOT1' cross sections. +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* NBMIX total number of material mixtures in the macrolib. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPMACR,IPSYS + INTEGER IMPX,NGRP,NEL,NLF,NANI,NBFIS,NALBP,MAT(NEL),NBMIX + REAL VOL(NEL) + LOGICAL LDIFF +*---- +* LOCAL VARIABLES +*---- + CHARACTER TEXT12*12,CM*2,HSMG*131 + LOGICAL LFIS + TYPE(C_PTR) JPMACR,KPMACR + INTEGER, DIMENSION(:), ALLOCATABLE :: IJJ,NJJ,IPOS,IND + REAL, DIMENSION(:), ALLOCATABLE :: WORK + REAL, DIMENSION(:,:), ALLOCATABLE :: ALBP,GAMMA,SGD,ZUFIS + REAL, DIMENSION(:,:,:), ALLOCATABLE :: CHI,RCAT,RCATI +* + ALB(X)=0.5*(1.0-X)/(1.0+X) +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IJJ(NBMIX),NJJ(NBMIX),IPOS(NBMIX),IND(NGRP)) + ALLOCATE(GAMMA(NALBP,NGRP),SGD(NBMIX,2*NLF),WORK(NBMIX*NGRP), + 1 CHI(NBMIX,NBFIS,NGRP),ZUFIS(NBMIX,NBFIS),RCAT(NGRP,NGRP,NBMIX), + 2 RCATI(NGRP,NGRP,NBMIX)) +*---- +* PROCESS PHYSICAL ALBEDO INFORMATION AND CALCULATION OF +* MULTIGROUP ALBEDO FUNCTIONS (RAVIART-THOMAS CASE). +*---- + IF(NALBP.GT.0) THEN + ALLOCATE(ALBP(NALBP,NGRP)) + CALL LCMGET(IPMACR,'ALBEDO',ALBP) + DO IGR=1,NGRP + GAMMA(:NALBP,IGR)=0.0 + DO IALB=1,NALBP + IF(ALBP(IALB,IGR).NE.1.0) THEN + GAMMA(IALB,IGR)=1.0/ALB(ALBP(IALB,IGR)) + ELSE + GAMMA(IALB,IGR)=1.0E20 + ENDIF + ENDDO + WRITE(TEXT12,'(9HALBEDO-FU,I3.3)') IGR + CALL LCMPUT(IPSYS,TEXT12,NALBP,2,GAMMA(1,IGR)) + ENDDO + DEALLOCATE(ALBP) + ENDIF +*---- +* PROCESS MACROLIB INFORMATION FOR VARIOUS LEGENDRE ORDERS. +*---- + IF(NLF.EQ.0) CALL XABORT('BIVSPS: SPN APPROXIMATION REQUESTED.') + JPMACR=LCMGID(IPMACR,'GROUP') + DO 112 IL=1,NLF + WRITE(CM,'(I2.2)') IL-1 + RCAT(:NGRP,:NGRP,:NBMIX)=0.0 + DO 50 IGR=1,NGRP +* PROCESS SECONDARY GROUP IGR. + KPMACR=LCMGIL(JPMACR,IGR) + SGD(:NBMIX,1)=0.0 + CALL LCMLEN(KPMACR,'SIGW'//CM,LENGT,ITYLCM) + IF((LENGT.GT.0).AND.(IL.LE.NANI)) THEN + IF(LENGT.GT.NBMIX) CALL XABORT('BIVSPS: INVALID LENGTH FOR' + 1 //' SIGW'//CM//' CROSS SECTIONS.') + CALL LCMGET(KPMACR,'SIGW'//CM,SGD(1,1)) + ENDIF + WRITE(TEXT12,'(4HNTOT,I1)') MIN(IL-1,9) + CALL LCMLEN(KPMACR,TEXT12,LENGT,ITYLCM) + CALL LCMLEN(KPMACR,'NTOT1',LENGT1,ITYLCM) + IF((IL.EQ.1).AND.(LENGT.NE.NBMIX)) CALL XABORT('BIVSPS: NO NTOT0' + 1 //' CROSS SECTIONS.') + IF(MOD(IL-1,2).EQ.0) THEN +* macroscopic total cross section in even-parity equations. + IF(LENGT.EQ.NBMIX) THEN + CALL LCMGET(KPMACR,TEXT12,SGD(1,2)) + ELSE + CALL LCMGET(KPMACR,'NTOT0',SGD(1,2)) + ENDIF + ELSE +* macroscopic total cross section in odd-parity equations. + IF(LDIFF) THEN + CALL LCMLEN(KPMACR,'DIFF',LENGT,ITYLCM) + IF(LENGT.EQ.0) CALL XABORT('BIVSPS: DIFFUSION COEFFICIENTS' + 1 //' EXPECTED IN THE MACROLIB.') + IF(LENGT.GT.NBMIX) CALL XABORT('BIVSPS: INVALID LENGTH FOR' + 1 //' DIFFUSION COEFFICIENTS.') + CALL LCMGET(KPMACR,'DIFF',SGD(1,2)) + DO 5 IBM=1,NBMIX + SGD(IBM,2)=1.0/(3.0*SGD(IBM,2)) + 5 CONTINUE + ELSE IF(LENGT.EQ.NBMIX) THEN + CALL LCMGET(KPMACR,TEXT12,SGD(1,2)) + ELSE IF(LENGT1.EQ.NBMIX) THEN + CALL LCMGET(KPMACR,'NTOT1',SGD(1,2)) + ELSE + CALL LCMGET(KPMACR,'NTOT0',SGD(1,2)) + ENDIF + ENDIF + DO 10 IBM=1,NBMIX + IF((MOD(IL-1,2).NE.0).AND.LDIFF) THEN + RCAT(IGR,IGR,IBM)=SGD(IBM,2) + ELSE + IF(SGD(IBM,1).GT.SGD(IBM,2)) THEN + WRITE(HSMG,'(28HBIVSPS: NEGATIVE XS IN GROUP,I5)') IGR + CALL XABORT(HSMG) + ENDIF + RCAT(IGR,IGR,IBM)=SGD(IBM,2)-SGD(IBM,1) + ENDIF + 10 CONTINUE + IF((MOD(IL-1,2).NE.0).AND.LDIFF) GO TO 50 + CALL LCMLEN(KPMACR,'NJJS'//CM,LENGT,ITYLCM) + IF(LENGT.GT.NBMIX) CALL XABORT('BIVSPS: INVALID LENGTH FOR NJJS' + 1 //CM//' INFORMATION.') + IF((LENGT.GT.0).AND.(IL.LE.NANI)) THEN + CALL LCMGET(KPMACR,'NJJS'//CM,NJJ) + CALL LCMGET(KPMACR,'IJJS'//CM,IJJ) + IGMIN=IGR + IGMAX=IGR + DO 20 IBM=1,NBMIX + IGMIN=MIN(IGMIN,IJJ(IBM)-NJJ(IBM)+1) + IGMAX=MAX(IGMAX,IJJ(IBM)) + 20 CONTINUE + CALL LCMGET(KPMACR,'IPOS'//CM,IPOS) + CALL LCMGET(KPMACR,'SCAT'//CM,WORK) + DO 40 JGR=IGMAX,IGMIN,-1 + IF(JGR.EQ.IGR) GO TO 40 + DO 30 IBM=1,NBMIX + IF((JGR.GT.IJJ(IBM)-NJJ(IBM)).AND.(JGR.LE.IJJ(IBM))) THEN + RCAT(IGR,JGR,IBM)=-WORK(IPOS(IBM)+IJJ(IBM)-JGR) + ENDIF + 30 CONTINUE + 40 CONTINUE + ENDIF + 50 CONTINUE +*---- +* INVERSION OF THE REMOVAL MATRIX FOR CASES WITH IELEM > 1. +*---- + DO 70 IBM=1,NBMIX + DO 65 JGR=1,NGRP + DO 60 IGR=1,NGRP + RCATI(IGR,JGR,IBM)=RCAT(IGR,JGR,IBM) + 60 CONTINUE + 65 CONTINUE + CALL ALINV(NGRP,RCATI(1,1,IBM),NGRP,IER,IND) + IF(IER.NE.0) CALL XABORT('BIVSPS: SINGULAR MATRIX.') + 70 CONTINUE +* + DO 111 IGR=1,NGRP + IGMIN=IGR + IGMAX=IGR + DO 85 IBM=1,NBMIX + DO 80 JGR=1,NGRP + IF((RCAT(IGR,JGR,IBM).NE.0.0).OR.(RCATI(IGR,JGR,IBM).NE.0.0)) THEN + IGMIN=MIN(IGMIN,JGR) + IGMAX=MAX(IGMAX,JGR) + ENDIF + 80 CONTINUE + 85 CONTINUE + DO 110 JGR=IGMIN,IGMAX + DO 90 IBM=1,NBMIX + WORK(IBM)=RCAT(IGR,JGR,IBM) + 90 CONTINUE + WRITE(TEXT12,'(4HSCAR,A2,2I3.3)') CM,IGR,JGR + CALL LCMPUT(IPSYS,TEXT12,NBMIX,2,WORK) + DO 100 IBM=1,NBMIX + WORK(IBM)=RCATI(IGR,JGR,IBM) + 100 CONTINUE + WRITE(TEXT12,'(4HSCAI,A2,2I3.3)') CM,IGR,JGR + CALL LCMPUT(IPSYS,TEXT12,NBMIX,2,WORK) + 110 CONTINUE + 111 CONTINUE + 112 CONTINUE +*---- +* COMPUTE AND FACTORIZE THE DIAGONAL SYSTEM MATRICES. +*---- + DO 162 IGR=1,NGRP + DO 140 IL=1,NLF + WRITE(TEXT12,'(4HSCAR,I2.2,2I3.3)') IL-1,IGR,IGR + CALL LCMGET(IPSYS,TEXT12,SGD(1,IL)) + WRITE(TEXT12,'(4HSCAI,I2.2,2I3.3)') IL-1,IGR,IGR + CALL LCMGET(IPSYS,TEXT12,SGD(1,NLF+IL)) + 140 CONTINUE + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL BIVASM(TEXT12,0,IPTRK,IPSYS,IMPX,NBMIX,NEL,NLF,2*NLF,NALBP, + 1 MAT,VOL,GAMMA,SGD) +*---- +* PUT A FLAG IN IPSYS TO IDENTIFY NON-ZERO SCATTERING TERMS. +*---- + DO 161 IL=1,NLF + DO 160 JGR=1,NGRP + WRITE(TEXT12,'(4HSCAR,I2.2,2I3.3)') IL-1,IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,LENGT,ITYLCM) + IF(LENGT.EQ.NBMIX) THEN + WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR + CALL LCMPUT(IPSYS,TEXT12,1,2,0.0) + ENDIF + 160 CONTINUE + 161 CONTINUE + 162 CONTINUE +*---- +* PROCESS FISSION SPECTRUM TERMS. +*---- + KPMACR=LCMGIL(JPMACR,1) + CALL LCMLEN(KPMACR,'CHI',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + IF(LENGT.NE.NBMIX*NBFIS) CALL XABORT('BIVSPS: INVALID LENGTH ' + 1 //'FOR CHI INFORMATION.') + DO 170 IGR=1,NGRP + KPMACR=LCMGIL(JPMACR,IGR) + CALL LCMGET(KPMACR,'CHI',CHI(1,1,IGR)) + 170 CONTINUE + ELSE + DO 182 IBM=1,NBMIX + DO 181 IFISS=1,NBFIS + CHI(IBM,IFISS,1)=1.0 + DO 180 IGR=2,NGRP + CHI(IBM,IFISS,IGR)=0.0 + 180 CONTINUE + 181 CONTINUE + 182 CONTINUE + ENDIF +*---- +* PROCESS FISSION NUSIGF TERMS. +*---- + DO 220 IGR=1,NGRP +* PROCESS SECONDARY GROUP IGR. + LFIS=.FALSE. + DO 195 IBM=1,NBMIX + DO 190 IFISS=1,NBFIS + LFIS=LFIS.OR.(CHI(IBM,IFISS,IGR).NE.0.0) + 190 CONTINUE + 195 CONTINUE + IF(LFIS) THEN + DO 210 JGR=1,NGRP + KPMACR=LCMGIL(JPMACR,JGR) + CALL LCMLEN(KPMACR,'NUSIGF',LENGT,ITYLCM) + IF(LENGT.NE.NBMIX*NBFIS) CALL XABORT('BIVSPS: INVALID LENGTH ' + 1 //'FOR NUSIGF INFORMATION.') + IF(LENGT.GT.0) THEN + CALL LCMGET(KPMACR,'NUSIGF',ZUFIS) + SGD(:NBMIX,:2*NLF)=0.0 + DO 205 IBM=1,NBMIX + DO 200 IFISS=1,NBFIS + SGD(IBM,1)=SGD(IBM,1)+CHI(IBM,IFISS,IGR)*ZUFIS(IBM,IFISS) + 200 CONTINUE + 205 CONTINUE + WRITE(TEXT12,'(4HFISS,2I3.3)') IGR,JGR + CALL LCMPUT(IPSYS,TEXT12,NBMIX,2,SGD(1,1)) + WRITE (TEXT12,'(1HB,2I3.3)') IGR,JGR + CALL BIVASM(TEXT12,1,IPTRK,IPSYS,IMPX,NBMIX,NEL,2,4,NALBP, + 1 MAT,VOL,GAMMA,SGD) + ENDIF + 210 CONTINUE + ENDIF + 220 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IJJ,NJJ,IPOS,IND) + DEALLOCATE(GAMMA,SGD,WORK,CHI,ZUFIS,RCAT,RCATI) + RETURN + END diff --git a/Trivac/src/BIVSYS.f b/Trivac/src/BIVSYS.f new file mode 100755 index 0000000..26f7d56 --- /dev/null +++ b/Trivac/src/BIVSYS.f @@ -0,0 +1,243 @@ +*DECK BIVSYS + SUBROUTINE BIVSYS(IPTRK,IPMACR,IPSYS,IMPX,NGRP,NEL,NBFIS,NALBP, + 1 MAT,VOL,NBMIX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover the diffusion coefficient and cross-section data in LCM +* object with pointer IPMACR, compute and store the corresponding +* system matrices. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK L_TRACK pointer to the bivac tracking information. +* IPMACR L_MACROLIB pointer to the cross sections. +* IPSYS L_SYSTEM pointer to system matrices. +* IMPX print parameter (equal to zero for no print). +* NGRP number of energy groups. +* NEL total number of finite elements. +* NBFIS number of fissionable isotopes. +* NALBP number of physical albedos per energy group. +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* NBMIX total number of material mixtures in the macrolib. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPMACR,IPSYS + INTEGER IMPX,NGRP,NEL,NBFIS,NALBP,MAT(NEL),NBMIX + REAL VOL(NEL) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + INTEGER ISTATE(NSTATE) + CHARACTER TEXT12*12,HSMG*131 + LOGICAL LFIS + TYPE(C_PTR) JPMACR,KPMACR + INTEGER, DIMENSION(:), ALLOCATABLE :: IJJ,NJJ,IPOS + REAL, DIMENSION(:), ALLOCATABLE :: WORK + REAL, DIMENSION(:,:), ALLOCATABLE :: ALBP,GAMMA,SGD,ZUFIS + REAL, DIMENSION(:,:,:), ALLOCATABLE :: CHI +* + ALB(X)=0.5*(1.0-X)/(1.0+X) +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IJJ(NBMIX),NJJ(NBMIX),IPOS(NBMIX)) + ALLOCATE(GAMMA(NALBP,NGRP),SGD(NBMIX,3),WORK(NBMIX*NGRP), + 1 CHI(NBMIX,NBFIS,NGRP),ZUFIS(NBMIX,NBFIS)) +*---- +* PROCESS PHYSICAL ALBEDO INFORMATION AND CALCULATION OF +* MULTIGROUP ALBEDO FUNCTIONS +*---- + IF(NALBP.GT.0) THEN + ALLOCATE(ALBP(NALBP,NGRP)) + CALL LCMGET(IPMACR,'ALBEDO',ALBP) + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + IELEM=ISTATE(8) + ICOL=ISTATE(9) + DO IGR=1,NGRP + GAMMA(:NALBP,IGR)=0.0 + DO IALB=1,NALBP + IF((IELEM.LT.0).OR.(ICOL.EQ.4)) THEN + GAMMA(IALB,IGR)=ALB(ALBP(IALB,IGR)) + ELSE IF(ALBP(IALB,IGR).NE.1.0) THEN + GAMMA(IALB,IGR)=1.0/ALB(ALBP(IALB,IGR)) + ELSE + GAMMA(IALB,IGR)=1.0E20 + ENDIF + ENDDO + WRITE(TEXT12,'(9HALBEDO-FU,I3.3)') IGR + CALL LCMPUT(IPSYS,TEXT12,NALBP,2,GAMMA(1,IGR)) + ENDDO + DEALLOCATE(ALBP) + ENDIF +* + JPMACR=LCMGID(IPMACR,'GROUP') + DO 70 IGR=1,NGRP +* PROCESS SECONDARY GROUP IGR. + KPMACR=LCMGIL(JPMACR,IGR) +*---- +* PROCESS LEAKAGE AND REMOVAL TERMS +*---- + CALL LCMLEN(KPMACR,'NTOT0',LENGT,ITYLCM) + IF(LENGT.EQ.0) THEN + CALL XABORT('BIVSYS: NO TOTAL CROSS SECTIONS.') + ELSE IF(LENGT.GT.NBMIX) THEN + CALL XABORT('BIVSYS: INVALID LENGTH FOR TOTAL CROSS SECTIONS.') + ENDIF + CALL LCMGET(KPMACR,'NTOT0',SGD(1,3)) + CALL LCMLEN(KPMACR,'SIGW00',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + IF(LENGT.GT.NBMIX) CALL XABORT('BIVSYS: INVALID LENGTH FOR ' + 1 //'''SIGW00'' CROSS SECTIONS.') + CALL LCMGET(KPMACR,'SIGW00',SGD(1,1)) + DO 10 IBM=1,NBMIX + SGD(IBM,3)=SGD(IBM,3)-SGD(IBM,1) + 10 CONTINUE + ENDIF + CALL LCMLEN(KPMACR,'DIFF',LENGT1,ITYLCM) + IF(LENGT1.GT.0) THEN + IF(LENGT1.GT.NBMIX) CALL XABORT('BIVSYS: INVALID LENGTH FOR' + 1 //' DIFF (ISOTROPIC DIFFUSION COEFFICIENT).') + CALL LCMGET(KPMACR,'DIFF',SGD(1,1)) + DO 20 IBM=1,NBMIX + SGD(IBM,2)=SGD(IBM,1) + 20 CONTINUE + ENDIF + CALL LCMLEN(KPMACR,'DIFFX',LENGT2,ITYLCM) + IF(LENGT2.GT.0) THEN + IF(LENGT2.GT.NBMIX) CALL XABORT('BIVSYS: INVALID LENGTH FOR' + 1 //' DIFFX (ANISOTROPIC DIFFUSION COEFFICIENT).') + CALL LCMGET(KPMACR,'DIFFX',SGD(1,1)) + DO 30 IBM=1,NBMIX + SGD(IBM,2)=SGD(IBM,1) + 30 CONTINUE + ENDIF + CALL LCMLEN(KPMACR,'DIFFY',LENGT3,ITYLCM) + IF(LENGT3.GT.0) THEN + IF(LENGT3.GT.NBMIX) CALL XABORT('BIVSYS: INVALID LENGTH FOR' + 1 //' DIFFY (ANISOTROPIC DIFFUSION COEFFICIENT).') + CALL LCMGET(KPMACR,'DIFFY',SGD(1,2)) + ENDIF + IF((LENGT1.EQ.0).AND.(LENGT2.EQ.0)) THEN + CALL XABORT('BIVSYS: NO DIFFUSION COEFFICIENTS.') + ENDIF + DO 35 IBM=1,NBMIX + IF((SGD(IBM,1).LT.0.0).OR.(SGD(IBM,3).LT.0.0)) THEN + WRITE(HSMG,'(28HBIVSYS: NEGATIVE XS IN GROUP,I5)') IGR + CALL XABORT(HSMG) + ENDIF + 35 CONTINUE + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL BIVASM(TEXT12,0,IPTRK,IPSYS,IMPX,NBMIX,NEL,0,3,NALBP,MAT, + 1 VOL,GAMMA(1,IGR),SGD) +*---- +* PROCESS SCATTERING TERMS +*---- + CALL LCMLEN(KPMACR,'NJJS00',LENGT,ITYLCM) + IF(LENGT.GT.NBMIX) CALL XABORT('BIVSYS: INVALID LENGTH FOR ' + 1 //'NJJS00 INFORMATION.') + IF(LENGT.GT.0) THEN + CALL LCMGET(KPMACR,'NJJS00',NJJ) + CALL LCMGET(KPMACR,'IJJS00',IJJ) + JGRMIN=IGR + JGRMAX=IGR + DO 40 IBM=1,NBMIX + JGRMIN=MIN(JGRMIN,IJJ(IBM)-NJJ(IBM)+1) + JGRMAX=MAX(JGRMAX,IJJ(IBM)) + 40 CONTINUE + CALL LCMGET(KPMACR,'IPOS00',IPOS) + CALL LCMGET(KPMACR,'SCAT00',WORK) + DO 60 JGR=JGRMAX,JGRMIN,-1 + IF(JGR.EQ.IGR) GO TO 60 + DO 50 IBM=1,NBMIX + IF((JGR.GT.IJJ(IBM)-NJJ(IBM)).AND.(JGR.LE.IJJ(IBM))) THEN + SGD(IBM,1)=WORK(IPOS(IBM)+IJJ(IBM)-JGR) + ELSE + SGD(IBM,1)=0.0 + ENDIF + 50 CONTINUE + WRITE (TEXT12,'(1HA,2I3.3)') IGR,JGR + CALL BIVASM(TEXT12,1,IPTRK,IPSYS,IMPX,NBMIX,NEL,0,1,NALBP,MAT, + 1 VOL,GAMMA(1,IGR),SGD) + 60 CONTINUE + ENDIF + 70 CONTINUE +*---- +* PROCESS FISSION SPECTRUM TERMS +*---- + KPMACR=LCMGIL(JPMACR,1) + CALL LCMLEN(KPMACR,'CHI',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + IF(LENGT.NE.NBMIX*NBFIS) CALL XABORT('BIVSYS: INVALID LENGTH ' + 1 //'FOR CHI INFORMATION.') + DO 80 IGR=1,NGRP + KPMACR=LCMGIL(JPMACR,IGR) + CALL LCMGET(KPMACR,'CHI',CHI(1,1,IGR)) + 80 CONTINUE + ELSE + DO 92 IBM=1,NBMIX + DO 91 IFISS=1,NBFIS + CHI(IBM,IFISS,1)=1.0 + DO 90 IGR=2,NGRP + CHI(IBM,IFISS,IGR)=0.0 + 90 CONTINUE + 91 CONTINUE + 92 CONTINUE + ENDIF +*---- +* PROCESS FISSION NUSIGF TERMS +*---- + DO 130 IGR=1,NGRP +* PROCESS SECONDARY GROUP IGR. + LFIS=.FALSE. + DO 105 IBM=1,NBMIX + DO 100 IFISS=1,NBFIS + LFIS=LFIS.OR.(CHI(IBM,IFISS,IGR).NE.0.0) + 100 CONTINUE + 105 CONTINUE + IF(LFIS) THEN + DO 120 JGR=1,NGRP + KPMACR=LCMGIL(JPMACR,JGR) + CALL LCMLEN(KPMACR,'NUSIGF',LENGT,ITYLCM) + IF(LENGT.NE.NBMIX*NBFIS) CALL XABORT('BIVSYS: INVALID LENGTH ' + 1 //'FOR NUSIGF INFORMATION.') + IF(LENGT.GT.0) THEN + CALL LCMGET(KPMACR,'NUSIGF',ZUFIS) + SGD(:NBMIX,1)=0.0 + DO 115 IBM=1,NBMIX + DO 110 IFISS=1,NBFIS + SGD(IBM,1)=SGD(IBM,1)+CHI(IBM,IFISS,IGR)*ZUFIS(IBM,IFISS) + 110 CONTINUE + 115 CONTINUE + WRITE(TEXT12,'(4HFISS,2I3.3)') IGR,JGR + CALL LCMPUT(IPSYS,TEXT12,NBMIX,2,SGD(1,1)) + WRITE (TEXT12,'(1HB,2I3.3)') IGR,JGR + CALL BIVASM(TEXT12,1,IPTRK,IPSYS,IMPX,NBMIX,NEL,0,1,NALBP, + 1 MAT,VOL,GAMMA(1,IGR),SGD) + ENDIF + 120 CONTINUE + ENDIF + 130 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IJJ,NJJ,IPOS) + DEALLOCATE(GAMMA,SGD,WORK,CHI,ZUFIS) + RETURN + END diff --git a/Trivac/src/BIVTRK.f b/Trivac/src/BIVTRK.f new file mode 100755 index 0000000..0e68e05 --- /dev/null +++ b/Trivac/src/BIVTRK.f @@ -0,0 +1,472 @@ +*DECK BIVTRK + SUBROUTINE BIVTRK (MAXPTS,IPTRK,IPGEOM,IMPX,IELEM,ICOL,NLF,NVD, + 1 ISPN,ISCAT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover of the geometry and tracking for BIVAC. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXPTS allocated storage for arrays of dimension NEL. +* IPTRK L_TRACK pointer to the tracking information. +* IPGEOM L_GEOM pointer to the geometry. +* IMPX print flag. +* IELEM degree of the Lagrangian finite elements: +* <0: order -IELEM primal finite elements; +* >0: order IELEM dual finite elements. +* ICOL type of quadrature used to integrate the mass matrix: +* =1: analytical integration; +* =2: Gauss-Lobatto quadrature (collocation method); +* =3: Gauss Legendre quadrature (superconvergent). +* =4: mesh centered finite differences in hexagonal geometry. +* IELEM=-1 and ICOL=2 : mesh corner finite differences; +* IELEM=1 and ICOL=2 : mesh centered finite differences. +* NLF number of Legendre orders for the flux. Equal to zero for +* diffusion theory. +* NVD type of void boundary condition if NLF>0 and ICOL=3. +* ISPN type of transport solution: +* =0: complete PN method; +* =1: simplified PN method. +* ISCAT source anisotropy: +* =1: isotropic sources in laboratory system; +* =2: linearly anisotropic sources in laboratory system. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPGEOM + INTEGER MAXPTS,IMPX,IELEM,ICOL,NLF,NVD,ISPN,ISCAT +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + LOGICAL ILK,CYLIND + CHARACTER HSMG*131 + INTEGER ISTATE(NSTATE),IGP(NSTATE),NCODE(6),ICODE(6) + REAL ZCODE(6) + INTEGER, DIMENSION(:), ALLOCATABLE :: MAT,IDL,IPERT,KN,IQFR,MU + REAL, DIMENSION(:), ALLOCATABLE :: VOL,XXX,YYY,ZZZ,XX,YY,DD,QFR, + 1 BFR,ISPLX,ISPLY,ISPLZ +* +******************* BIVAC GEOMETRICAL STRUCTURE. *********************** +* * +* ITYPE : =2 : CARTESIAN 1-D GEOMETRY; * +* =3 : TUBE 1-D GEOMETRY; * +* =4 : SPHERICAL 1-D GEOMETRY; * +* =5 : CARTESIAN 2-D GEOMETRY; * +* =6 : TUBE 2-D GEOMETRY; * +* =8 : HEXAGONAL 2-D GEOMETRY. * +* IHEX : TYPE OF HEXAGONAL SYMMETRY. * +* IELEM : .LT.0 : ORDER -IELEM PRIMAL FINITE ELEMENTS; * +* .GT.0 : ORDER IELEM DUAL FINITE ELEMENTS. * +* ICOL : TYPE OF QUADRATURE USED TO INTEGRATE THE MASS MATRIX.* +* =1 : ANALYTICAL INTEGRATION; * +* =2 : GAUSS-LOBATTO QUADRATURE (COLLOCATION METHOD); * +* =3 : GAUSS LEGENDRE QUADRATURE (SUPERCONVERGENT). * +* IELEM=-1 AND ICOL=2 : MESH CORNER FINITE DIFFERENCES. * +* IELEM=1 AND ICOL=2 : MESH CENTERED FINITE DIFFERENCES.* +* ISPLH : TYPE OF HEXAGONAL MESH-SPLITTING. * +* =1 : NO MESH SPLITTING (COMPLETE HEXAGONS); * +* =K : 6*(K-1)*(K-1) TRIANGLES PER HEXAGON. * +* SIDE : SIDE OF THE HEXAGONS. * +* LL4 : ORDER OF THE MATRICES PER GROUP IN BIVAC. * +* NCODE : TYPES OF BOUNDARY CONDITIONS. DIMENSION=6 * +* ZCODE : ALBEDOS. DIMENSION=6 * +* LX : NUMBER OF ELEMENTS ALONG THE X AXIS. * +* LY : NUMBER OF ELEMENTS ALONG THE Y AXIS. * +* XX : X-DIRECTED MESH SPACINGS. DIMENSION=LX*LY * +* YY : Y-DIRECTED MESH SPACINGS. DIMENSION=LX*LY * +* DD : USED WITH CYLINDRICAL GEOMETRIES. DIMENSION=LX*LY * +* KN : ELEMENT-ORDERED UNKNOWN LIST. DIMENSION LX*LY*ICOEF * +* WHERE ICOEF IS THE NUMBER OF UNKNOWN PER ELEMENT. * +* QFR : ELEMENT-ORDERED BOUNDARY CONDITIONS. * +* DIMENSION 4*LX*LY * +* IQFR : ELEMENT-ORDERED PHYSICAL ALBEDO INDICES. * +* DIMENSION 4*LX*LY * +* BFR : ELEMENT-ORDERED SURFACE FRACTIONS. * +* DIMENSION 4*LX*LY * +* MU : INDICES USED WITH COMPRESSED DIAGONAL STORAGE MODE * +* MATRICES. DIMENSION MAXEV * +* * +************************************************************************ +* +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(MAT(MAXPTS),IDL(MAXPTS),VOL(MAXPTS)) +* + CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE) + ITYPE=ISTATE(1) +* + IF(ISTATE(9).EQ.0) THEN + IF((ITYPE.NE.1).AND.(ITYPE.NE.2).AND.(ITYPE.NE.3).AND. + 1 (ITYPE.NE.4).AND.(ITYPE.NE.5).AND.(ITYPE.NE.6).AND. + 2 (ITYPE.NE.8)) THEN + CALL XABORT('BIVTRK: DISCRETIZATION NOT AVAILABLE.') + ENDIF + ALLOCATE(XXX(MAXPTS+1),YYY(MAXPTS+1),ZZZ(MAXPTS+1)) +* + ALLOCATE(ISPLX(MAXPTS),ISPLY(MAXPTS),ISPLZ(MAXPTS)) + CALL READ3D(MAXPTS,MAXPTS,MAXPTS,MAXPTS,IPGEOM,IHEX,IR,ILK, + 1 SIDE,XXX,YYY,ZZZ,IMPX,LX,LY,LZ,MAT,NEL,NCODE,ICODE,ZCODE, + 2 ISPLX,ISPLY,ISPLZ,ISPLH,ISPLL) + DEALLOCATE(ISPLX,ISPLY,ISPLZ) + IF((ITYPE.EQ.8).AND.(IELEM.GT.0).AND.(ICOL.LE.3)) THEN + IF(ISPLL.EQ.0) THEN + CALL XABORT('BIVTRK: SPLITL KEYWORD MISSING IN GEOMETRY.') + ENDIF + ISPLH=ISPLL + ELSE IF(ITYPE.EQ.8) THEN + ISPLH=ISPLH+1 + ENDIF + ELSE + CALL XABORT('BIVTRK: DISCRETIZATION NOT AVAILABLE.') + ENDIF + IF((IMPX.GE.1).AND.(ITYPE.NE.8)) THEN + WRITE (6,'(/39H BIVTRK: TYPE OF FINITE ELEMENT IELEM =,I3, + 1 8H ICOL =,I3/)') IELEM,ICOL + ELSE IF(IMPX.GE.1) THEN + WRITE (6,'(/39H BIVTRK: TYPE OF FINITE ELEMENT IELEM =,I3, + 1 8H ICOL =,I3,9H ISPLH =,I3/)') IELEM,ICOL,ISPLH + ENDIF +* + IF(LX*LY*LZ.GT.MAXPTS) THEN + WRITE (HSMG,'(39HBIVTRK: MAXPTS SHOULD BE INCREASED FROM,I7, + 1 3H TO,I7)') MAXPTS,LX*LY*LZ + CALL XABORT(HSMG) + ENDIF +*---- +* 1-D AND 2-D CYLINDRICAL CASES. +*---- + CYLIND=(ITYPE.EQ.3).OR.(ITYPE.EQ.4).OR.(ITYPE.EQ.6) + IF((ITYPE.EQ.2).OR.(ITYPE.EQ.3)) THEN + NCODE(3)=2 + NCODE(4)=5 + ICODE(3)=0 + ICODE(4)=0 + ZCODE(3)=1.0 + ZCODE(4)=1.0 + YYY(1)=0.0 + YYY(2)=2.0 + ELSE IF(ITYPE.EQ.6) THEN + LY=LZ + DO 10 I=1,LZ+1 + YYY(I)=ZZZ(I) + 10 CONTINUE + NCODE(3)=NCODE(5) + NCODE(4)=NCODE(6) + ICODE(3)=ICODE(5) + ICODE(4)=ICODE(6) + ZCODE(3)=ZCODE(5) + ZCODE(4)=ZCODE(6) + ENDIF +*---- +* UNFOLD THE DOMAIN IN DIAGONAL SYMMETRY CASES. +*---- + IF((NCODE(2).EQ.3).AND.(NCODE(3).EQ.3)) THEN + NCODE(3)=NCODE(1) + NCODE(2)=NCODE(4) + ICODE(3)=ICODE(1) + ICODE(2)=ICODE(4) + ZCODE(3)=ZCODE(1) + ZCODE(2)=ZCODE(4) + K=LX*(LX+1)/2 + DO 35 IY=LY,1,-1 + DO 20 IX=LX,IY+1,-1 + MAT((IY-1)*LX+IX)=MAT((IX-1)*LY+IY) + 20 CONTINUE + DO 30 IX=IY,1,-1 + MAT((IY-1)*LX+IX)=MAT(K) + K=K-1 + 30 CONTINUE + 35 CONTINUE + NEL=LX*LY + IF(K.NE.0) THEN + CALL XABORT('BIVTRK: UNABLE TO UNFOLD THE DOMAIN.') + ENDIF + ELSE IF((NCODE(1).EQ.3).AND.(NCODE(4).EQ.3)) THEN + NCODE(1)=NCODE(3) + NCODE(4)=NCODE(2) + ICODE(1)=ICODE(3) + ICODE(4)=ICODE(2) + ZCODE(1)=ZCODE(3) + ZCODE(4)=ZCODE(2) + K=LX*(LX+1)/2 + DO 45 IY=LY,1,-1 + DO 40 IX=LX,IY,-1 + MAT((IY-1)*LX+IX)=MAT(K) + K=K-1 + 40 CONTINUE + 45 CONTINUE + DO 55 IY=1,LY + DO 50 IX=1,IY-1 + MAT((IY-1)*LX+IX)=MAT((IX-1)*LY+IY) + 50 CONTINUE + 55 CONTINUE + NEL=LX*LY + IF(K.NE.0) THEN + CALL XABORT('BIVTRK: UNABLE TO UNFOLD THE DOMAIN.') + ENDIF + ENDIF + IF(IMPX.GT.5) THEN + WRITE(6,600) 'NCODE',(NCODE(I),I=1,4) + WRITE(6,600) 'MAT',(MAT(I),I=1,LX*LY) + ENDIF +* + IF((IELEM.LT.0).AND.(ITYPE.NE.8)) THEN + IEL=-IELEM + MAXEV=(IEL*LX+1)*(IEL*LY+1) + MAXKN=(IEL+1)*(IEL+1)*NEL + MAXQF=4*NEL + ELSE IF((IELEM.GT.0).AND.(ITYPE.EQ.3).AND.(NLF.NE.0)) THEN +* PN METHOD / 1D CYLINDRICAL GEOMETRY. + MAXEV=(2*LX+1)*(NLF/2)*(NLF/2+1)/2 + MAXKN=3*NEL*(NLF/2)*(NLF/2) + MAXQF=2*NEL + ELSE IF((IELEM.GT.0).AND.(ITYPE.EQ.4).AND.(NLF.NE.0)) THEN +* PN METHOD / 1D SPHERICAL GEOMETRY. + MAXEV=(2*LX+1)*(NLF/2) + MAXKN=3*NEL*(NLF/2) + MAXQF=2*NEL + ELSE IF((IELEM.GT.0).AND.(ITYPE.EQ.5).AND.(NLF.NE.0).AND. + 1 (ISPN.EQ.0)) THEN +* PN METHOD / 2D CARTESIAN GEOMETRY. + MAXEV=0 + DO 60 IL=1,NLF-1,2 + MAXEV=MAXEV+(IL*LX+(IL+1)*(LX+1))*LY+(IL+1)*(LX+1) + 60 CONTINUE + MAXKN=5*NEL*NLF*(NLF/2) + MAXQF=4*NEL + ELSE IF((IELEM.GT.0).AND.(ITYPE.EQ.5).AND.(NLF.NE.0).AND. + 1 (ISPN.EQ.1)) THEN +* SPN METHOD / 2D CARTESIAN GEOMETRY. + MAXEV=(LX+1)*LY*IELEM+LX*(LY+1)*IELEM+LX*LY*IELEM*IELEM + MAXEV=MAXEV*NLF/2 + MAXKN=5*NEL + MAXQF=4*NEL + ELSE IF((IELEM.GT.0).AND.(ITYPE.NE.8)) THEN + MAXEV=(LX+1)*LY*IELEM+LX*(LY+1)*IELEM+LX*LY*IELEM*IELEM + MAXKN=5*NEL + MAXQF=4*NEL + ELSE IF((IELEM.LT.0).AND.(ITYPE.EQ.8)) THEN + IEL=-IELEM + NEL=LX + IF(ISPLH.EQ.1) THEN + MAXEV=6*NEL + MAXKN=7*NEL + ELSE + MAXEV=(1+ISPLH*(ISPLH-1)*3)*NEL + MAXKN=(6*(ISPLH-1)**2)*NEL*4 + ENDIF + MAXQF=MAXKN + ELSE IF((ICOL.EQ.4).AND.(ITYPE.EQ.8)) THEN + NEL=LX + IF(ISPLH.EQ.1) THEN + MAXEV=NEL + MAXKN=7*NEL + ELSE + MAXEV=(6*(ISPLH-1)**2)*NEL + MAXKN=(6*(ISPLH-1)**2)*NEL*4 + ENDIF + MAXQF=MAXKN + ELSE IF((IELEM.GT.0).AND.(ITYPE.EQ.8)) THEN + NEL=LX + LXH=LX/(3*ISPLH**2) + NBLOS=LXH*ISPLH**2 + NBC=INT((SQRT(REAL((4*LXH-1)/3))+1.)/2.) + MAXEV=3*(2*NBLOS*IELEM+(2*NBC-1)*ISPLH)*IELEM+3*NBLOS*IELEM**2 + MAXKN=(LXH*ISPLH**2)*(4+6*IELEM*(IELEM+1)) + MAXQF=(LXH*ISPLH**2)*6 + ELSE + CALL XABORT('BIVTRK: INVALID TYPE OF DISCRETIZATION.') + ENDIF + IF(CYLIND) THEN + MAXDD=NEL + ELSE + MAXDD=1 + ENDIF + IF((ICOL.EQ.4).AND.(ITYPE.EQ.8).AND.(IELEM.NE.1)) THEN + CALL XABORT('BIVTRK: THIS HEXAGONAL MCFD DISCRETIZATIONS IS L' + 1 //'IMITED TO LINEAR ORDER.') + ELSE IF((IELEM.LT.0).AND.(ITYPE.EQ.8).AND.(IELEM.NE.-1)) THEN + CALL XABORT('BIVTRK: THIS HEXAGONAL PRIM DISCRETIZATIONS IS L' + 1 //'IMITED TO LINEAR ORDER.') + ENDIF + IF(ICOL.LE.3) CALL BIVCOL(IPTRK,IMPX,ABS(IELEM),ICOL) + ALLOCATE(XX(NEL),YY(NEL),DD(MAXDD),KN(MAXKN),QFR(MAXQF), + 1 IQFR(MAXQF),BFR(MAXQF),MU(MAXEV)) + KN(:MAXKN)=0 + QFR(:MAXQF)=0.0 + IQFR(:MAXQF)=0 + BFR(:MAXQF)=0.0 + IF((IELEM.LT.0).AND.(ITYPE.NE.8)) THEN + IEL=-IELEM + CALL BIVPKN(MAXEV,IMPX,LX,LY,CYLIND,IEL,LL4,NCODE,ICODE,ZCODE, + 1 MAT,VOL,XXX,YYY,XX,YY,DD,KN,QFR,IQFR,BFR,MU) + ELSE IF(((ITYPE.EQ.2).OR.((ITYPE.EQ.5).AND.(ISPN.EQ.1))).AND. + 1 (IELEM.GT.0).AND.(NLF.NE.0)) THEN +* MIXED-DUAL SPN APPROXIMATION IN 1D OR 2D CARTESIAN GEOMETRY. + CALL BIVDKN(MAXEV,IMPX,LX,LY,CYLIND,IELEM,ICOL,LL4,NCODE, + 1 ICODE,ZCODE,MAT,VOL,XXX,YYY,XX,YY,DD,KN,QFR,IQFR,BFR,IDL,MU) + NUN=LL4*NLF/2 + ELSE IF((IELEM.GT.0).AND.(ITYPE.NE.8)) THEN + CALL BIVDKN(MAXEV,IMPX,LX,LY,CYLIND,IELEM,ICOL,LL4,NCODE, + 1 ICODE,ZCODE,MAT,VOL,XXX,YYY,XX,YY,DD,KN,QFR,IQFR,BFR,IDL,MU) + NUN=LL4 + ELSE IF((IELEM.LT.0).AND.(ITYPE.EQ.8)) THEN +* HEXAGONAL GEOMETRY MESH CORNER FINITE DIFFERENCES. + CALL BIVPRH(MAXEV,MAXKN,IMPX,ISPLH,LX,IHEX,NCODE,ICODE,ZCODE, + 1 MAT,SIDE,LL4,NELEM,VOL,KN,QFR,IQFR,BFR,MU) + IF(ISPLH.EQ.1) THEN + MAXKN=7*NELEM + MAXQF=7*NELEM + ELSE + MAXKN=4*NELEM + MAXQF=4*NELEM + ENDIF + ELSE IF((IELEM.GT.0).AND.(ITYPE.EQ.8).AND.(ICOL.EQ.4)) THEN +* HEXAGONAL GEOMETRY MESH CENTERED FINITE DIFFERENCES. + CALL BIVDFH(MAXEV,MAXKN,IMPX,ISPLH,LX,SIDE,LL4,NUN,IHEX, + 1 NCODE,ICODE,ZCODE,MAT,VOL,IDL,KN,QFR,IQFR,BFR,MU) + IF(ISPLH.EQ.1) THEN + MAXKN=7*LL4 + MAXQF=7*LL4 + ELSE + MAXKN=4*LL4 + MAXQF=4*LL4 + ENDIF + ELSE IF((IELEM.GT.0).AND.(ITYPE.EQ.8)) THEN +* HEXAGONAL GEOMETRY THOMAS-RAVIART-SCHNEIDER FINITE ELEMENTS. + NBLOS=LXH*ISPLH**2 + ALLOCATE(IPERT(NBLOS)) + CALL BIVSFH(MAXEV,NBLOS,IMPX,ISPLH,IELEM,LXH,MAT,SIDE,NCODE, + 1 ICODE,ZCODE,LL4,VOL,IDL,IPERT,KN,QFR,IQFR,BFR,MU) + CALL LCMPUT(IPTRK,'IPERT',NBLOS,1,IPERT) + DEALLOCATE(IPERT) + NUN=LL4 + ENDIF + DEALLOCATE(YYY,ZZZ) +*---- +* APPEND THE PN FLUXES AT THE END OF UNKNOWN VECTOR. +*---- + IF(NLF.GE.2) THEN + IF((ITYPE.EQ.2).OR.((ITYPE.EQ.5).AND.(ISPN.EQ.1))) THEN + NUN=LL4+LL4*(NLF-2)/2 + ELSE IF((ITYPE.EQ.8).AND.(ISPN.EQ.1)) THEN + NUN=NUN+NUN*(NLF-2)/2 + ELSE IF((ITYPE.NE.2).AND.(ITYPE.NE.5).AND.(ITYPE.NE.8)) THEN + CALL XABORT('BIVTRK: GEOMETRY NOT SUPPORTED WITH PN.') + ENDIF + ENDIF +*---- +* APPEND THE AVERAGED FLUXES AT THE END OF UNKNOWN VECTOR. +*---- + IF(IELEM.LT.0) THEN + NUN=LL4 + DO 190 I=1,NEL + IF(MAT(I).EQ.0) THEN + IDL(I)=0 + ELSE + NUN=NUN+1 + IDL(I)=NUN + ENDIF + 190 CONTINUE + ENDIF +*---- +* RESERVE A COMPONENT TO STORE THE SURFACE-AVERAGED FLUX. +*---- + IF(NLF.EQ.0) NUN=NUN+1 + IF(IMPX.GT.0) WRITE (6,'(/34H BIVTRK: ORDER OF LINEAR SYSTEMS =, + 1 I7/9X,37HNUMBER OF UNKNOWNS PER ENERGY GROUP =,I7)') LL4,NUN +* + IF(IMPX.GT.5) THEN + I1=1 + DO 200 I=1,(NEL-1)/8+1 + I2=I1+7 + IF(I2.GT.NEL) I2=NEL + WRITE (6,620) (J,J=I1,I2) + WRITE (6,630) (MAT(J),J=I1,I2) + WRITE (6,640) (IDL(J),J=I1,I2) + WRITE (6,650) (VOL(J),J=I1,I2) + I1=I1+8 + 200 CONTINUE + ENDIF +*---- +* SAVE GENERAL AND BIVAC-SPECIFIC TRACKING INFORMATION. +*---- + IGP(:NSTATE)=0 + IGP(1)=NEL + IGP(2)=NUN + IF(ILK) THEN + IGP(3)=0 + ELSE + IGP(3)=1 + ENDIF + IGP(4)=ISTATE(7) + IGP(5)=1 + IGP(6)=ITYPE + IGP(7)=IHEX + IGP(8)=IELEM + IGP(9)=ICOL + IGP(10)=ISPLH + IGP(11)=LL4 + IGP(12)=LX + IGP(13)=LY + IGP(14)=NLF + IGP(15)=ISPN + IGP(16)=ISCAT + IGP(17)=NVD + CALL LCMPUT(IPTRK,'STATE-VECTOR',NSTATE,1,IGP) + CALL LCMPUT(IPTRK,'MATCOD',NEL,1,MAT) + CALL LCMPUT(IPTRK,'VOLUME',NEL,2,VOL) + CALL LCMPUT(IPTRK,'KEYFLX',NEL,1,IDL) + CALL LCMPUT(IPTRK,'NCODE',6,1,NCODE) + CALL LCMPUT(IPTRK,'ZCODE',6,2,ZCODE) + CALL LCMPUT(IPTRK,'ICODE',6,1,ICODE) + CALL LCMPUT(IPTRK,'BC-REFL+TRAN',1,1,NUN) + IF(ITYPE.EQ.4) CALL LCMPUT(IPTRK,'XXX',LX+1,2,XXX) + DEALLOCATE(XXX) + IF(ITYPE.EQ.8) THEN + CALL LCMPUT(IPTRK,'SIDE',1,2,SIDE) + ELSE + CALL LCMPUT(IPTRK,'XX',LX*LY,2,XX) + CALL LCMPUT(IPTRK,'YY',LX*LY,2,YY) + IF(.NOT.CYLIND) DD(1)=0.0 + CALL LCMPUT(IPTRK,'DD',MAXDD,2,DD) + ENDIF + DEALLOCATE(XX,YY,DD) + CALL LCMPUT(IPTRK,'KN',MAXKN,1,KN) + DEALLOCATE(KN) + CALL LCMPUT(IPTRK,'QFR',MAXQF,2,QFR) + DEALLOCATE(QFR) + CALL LCMPUT(IPTRK,'IQFR',MAXQF,1,IQFR) + DEALLOCATE(IQFR) + CALL LCMPUT(IPTRK,'BFR',MAXQF,2,BFR) + DEALLOCATE(BFR) + CALL LCMPUT(IPTRK,'MU',LL4,1,MU) + DEALLOCATE(MU) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(MAT,IDL,VOL) + RETURN +* + 600 FORMAT(/26H BIVTRK: VALUES OF VECTOR ,A6,4H ARE/(1X,1P,20I6)) + 620 FORMAT (///11H REGION ,8(I8,6X,1HI)) + 630 FORMAT ( 11H MIXTURE ,8(I8,6X,1HI)) + 640 FORMAT ( 11H POINTER ,8(I8,6X,1HI)) + 650 FORMAT ( 11H VOLUME ,8(1P,E13.6,2H I)) + END diff --git a/Trivac/src/DELDRV.f b/Trivac/src/DELDRV.f new file mode 100755 index 0000000..1d4bb77 --- /dev/null +++ b/Trivac/src/DELDRV.f @@ -0,0 +1,120 @@ +*DECK DELDRV + SUBROUTINE DELDRV (IPTRK,IPSYS0,IPSYSP,IPFLU0,IPGPT,NUN,NGRP, + 1 NSTEP) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Driver for the calculation of direct or adjoint sources for a fixed +* source eigenvalue problem. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK L_TRACK pointer to the tracking information. +* IPSYS0 L_SYSTEM pointer to unperturbed system matrices. +* IPSYSP L_SYSTEM pointer to delta system matrices. +* IPFLU0 L_FLUX pointer to the unperturbed solution. +* IPGPT L_GPT pointer to the GPT fixed source. +* NUN total number of unknowns per energy group. +* NGRP number of energy groups. +* NSTEP number of perturbation states in STEP directory. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPSYS0,IPSYSP,IPFLU0,IPGPT + INTEGER NUN,NGRP,NSTEP +*---- +* LOCAL VARIABLES +*---- + LOGICAL ADJ + DOUBLE PRECISION DFLOTT + CHARACTER TEXT4*4 + TYPE(C_PTR) JPFLU1,JPFLU2,JPGPT,KPGPT,JPSYSP,KPSYSP + REAL, DIMENSION(:,:), ALLOCATABLE :: EVECT,ADECT,SUNKNO +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(EVECT(NUN,NGRP),ADECT(NUN,NGRP),SUNKNO(NUN,NGRP)) +*---- +* READ THE INPUT DATA. +*---- +* DEFAULT OPTIONS. + IMPX=1 + ADJ=.FALSE. +* + 10 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.EQ.10) GO TO 20 + IF(INDIC.NE.3) CALL XABORT('DELDRV: CHARACTER DATA EXPECTED.') +* + IF(TEXT4.EQ.'EDIT') THEN + CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('DELDRV: INTEGER DATA EXPECTED.') + ELSE IF(TEXT4.EQ.'ADJ') THEN + ADJ=.TRUE. + ELSE IF(TEXT4.EQ.';') THEN + GO TO 20 + ELSE + CALL XABORT('DELDRV: ; EXPECTED.') + ENDIF + GO TO 10 +*---- +* RECOVER UNPERTURBED K-EFFECTIVE AND FLUXES. +*---- + 20 CALL LCMGET(IPFLU0,'K-EFFECTIVE',FKEFF) + JPFLU1=LCMGID(IPFLU0,'FLUX') + JPFLU2=LCMGID(IPFLU0,'AFLUX') + DO 30 IGR=1,NGRP + CALL LCMGDL(JPFLU1,IGR,EVECT(1,IGR)) + CALL LCMGDL(JPFLU2,IGR,ADECT(1,IGR)) + 30 CONTINUE +*---- +* COMPUTE THE DIRECT OR ADJOINT FIXED SOURCES AND SAVE THE FIXED +* SOURCES. +*---- + IF(NSTEP.EQ.0) THEN + CALL DELPER(IPTRK,IPSYS0,IPSYSP,ADJ,NUN,NGRP,FKEFF,IMPX,EVECT, + 1 ADECT,DELKEF,SUNKNO) + IF(ADJ) THEN + JPGPT=LCMLID(IPGPT,'ASOUR',1) + ELSE + JPGPT=LCMLID(IPGPT,'DSOUR',1) + ENDIF + KPGPT=LCMLIL(JPGPT,1,NGRP) + DO 40 IGR=1,NGRP + CALL LCMPDL(KPGPT,IGR,NUN,2,SUNKNO(1,IGR)) + 40 CONTINUE + ELSE + JPSYSP=LCMGID(IPSYSP,'STEP') + IF(ADJ) THEN + JPGPT=LCMLID(IPGPT,'ASOUR',NSTEP) + ELSE + JPGPT=LCMLID(IPGPT,'DSOUR',NSTEP) + ENDIF + DO 55 ISTEP=1,NSTEP + KPSYSP=LCMGIL(JPSYSP,ISTEP) + CALL DELPER(IPTRK,IPSYS0,KPSYSP,ADJ,NUN,NGRP,FKEFF,IMPX,EVECT, + 1 ADECT,DELKEF,SUNKNO) + KPGPT=LCMLIL(JPGPT,ISTEP,NGRP) + DO 50 IGR=1,NGRP + CALL LCMPDL(KPGPT,IGR,NUN,2,SUNKNO(1,IGR)) + 50 CONTINUE + 55 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(EVECT,ADECT,SUNKNO) + RETURN + END diff --git a/Trivac/src/DELPER.f b/Trivac/src/DELPER.f new file mode 100755 index 0000000..036b003 --- /dev/null +++ b/Trivac/src/DELPER.f @@ -0,0 +1,253 @@ +*DECK DELPER + SUBROUTINE DELPER (IPTRK,IPSYS0,IPSYSP,ADJ,NUN,NGRP,FKEFF,IMPX, + 1 EVECT,ADECT,DELKEF,SOUR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of the source term for a direct or adjoint fixed source +* eigenvalue problem. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK L_TRACK pointer to the tracking information. +* IPSYS0 L_SYSTEM pointer to unperturbed system matrices. +* IPSYSP L_SYSTEM pointer to delta system matrices. +* ADJ adjoint flag. If ADJ=.true., we compute the source term for an +* adjoint fixed source eigenvalue problem. +* NUN total number of unknowns per energy group. +* NGRP number of energy groups. +* FKEFF reference k-effective. +* IMPX delta k-effective is printed if impx.ge.1. +* EVECT reference solution of the associated direct eigenvalue +* problem. +* ADECT reference solution of the associated adjoint eigenvalue +* problem. +* +*Parameters: output +* DELKEF delta k-effective. +* SOUR fixed source term. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPSYS0,IPSYSP + INTEGER NUN,NGRP,IMPX + LOGICAL ADJ + REAL FKEFF,EVECT(NUN,NGRP),ADECT(NUN,NGRP),DELKEF,SOUR(NUN,NGRP) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + PARAMETER (EPS1=1.0E-4) + INTEGER ISTATE(NSTATE) + CHARACTER*12 TEXT12 + DOUBLE PRECISION AIL,BIL,EVAL,DEVAL + REAL, DIMENSION(:), ALLOCATABLE :: WORK,WORK1 + REAL, DIMENSION(:), POINTER :: AGAR + TYPE(C_PTR) AGAR_PTR +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(WORK(NUN)) +* + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + LL4=ISTATE(11) + NLF=ISTATE(30) + IF(NLF.GT.0) LL4=LL4*NLF/2 + ITY=2 + IF(ISTATE(12).EQ.2) ITY=3 + IF((NLF.GT.0).AND.(ITY.GE.3)) ITY=10+ITY + CALL MTOPEN(IMPX,IPTRK,LL4) + IF(LL4.GT.NUN) CALL XABORT('DELPER: INVALID NUMBER OF UNKNOWNS.') +*---- +* COMPUTE THE NON-PERTURBED K-EFFECTIVE. +*---- + AIL=0.0D0 + BIL=0.0D0 + DO 85 IGR=1,NGRP + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL MTLDLM(TEXT12,IPTRK,IPSYS0,LL4,ITY,EVECT(1,IGR),SOUR(1,IGR)) + DO 10 I=1,LL4 + WORK(I)=0.0 + 10 CONTINUE + DO 70 JGR=1,NGRP + IF(JGR.EQ.IGR) GO TO 40 + WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS0,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 40 + IF(ITY.EQ.13) THEN + ALLOCATE(WORK1(LL4)) + CALL MTLDLM(TEXT12,IPTRK,IPSYS0,LL4,ITY,EVECT(1,JGR),WORK1(1)) + DO 20 I=1,LL4 + SOUR(I,IGR)=SOUR(I,IGR)-WORK1(I) + 20 CONTINUE + DEALLOCATE(WORK1) + ELSE + CALL LCMGPD(IPSYS0,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ NUN /)) + DO 30 I=1,ILONG + SOUR(I,IGR)=SOUR(I,IGR)-AGAR(I)*EVECT(I,JGR) + 30 CONTINUE + ENDIF + 40 WRITE(TEXT12,'(1HB,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS0,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 70 + CALL LCMGPD(IPSYS0,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ NUN /)) + DO 50 I=1,ILONG + WORK(I)=WORK(I)+AGAR(I)*EVECT(I,JGR) + 50 CONTINUE + 70 CONTINUE + DO 80 I=1,LL4 + AIL=AIL+ADECT(I,IGR)*SOUR(I,IGR) + BIL=BIL+ADECT(I,IGR)*WORK(I) + 80 CONTINUE + 85 CONTINUE + EVAL=AIL/BIL + IF(ABS(FKEFF-1.0/EVAL).GT.EPS1) CALL XABORT('DELPER: INCOMPATIBIL' + 1 //'ITY BETWEEN THE PROVIDED AND CALCULATED KEFF.') +*---- +* COMPUTE THE DIRECT OR ADJOINT SOURCE TERM. +*---- + IF(ADJ) THEN + DO 155 IGR=1,NGRP + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL MTLDLM(TEXT12,IPTRK,IPSYSP,LL4,ITY,ADECT(1,IGR), + 1 SOUR(1,IGR)) + DO 150 JGR=1,NGRP + IF(JGR.EQ.IGR) GO TO 120 + WRITE(TEXT12,'(1HA,2I3.3)') JGR,IGR + CALL LCMLEN(IPSYSP,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 120 + IF(ITY.EQ.13) THEN + ALLOCATE(WORK1(LL4)) + CALL MTLDLM(TEXT12,IPTRK,IPSYSP,LL4,ITY,ADECT(1,JGR), + 1 WORK1(1)) + DO 100 I=1,LL4 + SOUR(I,IGR)=SOUR(I,IGR)-WORK1(I) + 100 CONTINUE + DEALLOCATE(WORK1) + ELSE + CALL LCMGPD(IPSYSP,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ NUN /)) + DO 110 I=1,ILONG + SOUR(I,IGR)=SOUR(I,IGR)-AGAR(I)*ADECT(I,JGR) + 110 CONTINUE + ENDIF + 120 WRITE(TEXT12,'(1HB,2I3.3)') JGR,IGR + CALL LCMLEN(IPSYSP,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 150 + CALL LCMGPD(IPSYSP,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ NUN /)) + DO 130 I=1,ILONG + SOUR(I,IGR)=SOUR(I,IGR)-REAL(EVAL)*AGAR(I)*ADECT(I,JGR) + 130 CONTINUE + 150 CONTINUE + 155 CONTINUE + AIL=0.0D0 + DO 165 IGR=1,NGRP + DO 160 I=1,LL4 + AIL=AIL+SOUR(I,IGR)*EVECT(I,IGR) + 160 CONTINUE + 165 CONTINUE + DEVAL=AIL/BIL + DO 215 IGR=1,NGRP + DO 170 I=1,LL4 + WORK(I)=0.0 + 170 CONTINUE + DO 200 JGR=1,NGRP + WRITE(TEXT12,'(1HB,2I3.3)') JGR,IGR + CALL LCMLEN(IPSYS0,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 200 + CALL LCMGPD(IPSYS0,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ NUN /)) + DO 180 I=1,ILONG + WORK(I)=WORK(I)+AGAR(I)*ADECT(I,JGR) + 180 CONTINUE + 200 CONTINUE + DO 210 I=1,LL4 + SOUR(I,IGR)=SOUR(I,IGR)-REAL(DEVAL)*WORK(I) + 210 CONTINUE + 215 CONTINUE + ELSE + DO 285 IGR=1,NGRP + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL MTLDLM(TEXT12,IPTRK,IPSYSP,LL4,ITY,EVECT(1,IGR), + 1 SOUR(1,IGR)) + DO 280 JGR=1,NGRP + IF(JGR.EQ.IGR) GO TO 250 + WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYSP,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 250 + IF(ITY.EQ.13) THEN + ALLOCATE(WORK1(LL4)) + CALL MTLDLM(TEXT12,IPTRK,IPSYSP,LL4,ITY,EVECT(1,JGR), + 1 WORK1(1)) + DO 220 I=1,LL4 + SOUR(I,IGR)=SOUR(I,IGR)-WORK1(I) + 220 CONTINUE + DEALLOCATE(WORK1) + ELSE + CALL LCMGPD(IPSYSP,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ NUN /)) + DO 230 I=1,ILONG + SOUR(I,IGR)=SOUR(I,IGR)-AGAR(I)*EVECT(I,JGR) + 230 CONTINUE + ENDIF + 250 WRITE(TEXT12,'(1HB,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYSP,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 280 + CALL LCMGPD(IPSYSP,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ NUN /)) + DO 260 I=1,ILONG + SOUR(I,IGR)=SOUR(I,IGR)-REAL(EVAL)*AGAR(I)*EVECT(I,JGR) + 260 CONTINUE + 280 CONTINUE + 285 CONTINUE + AIL=0.0D0 + DO 295 IGR=1,NGRP + DO 290 I=1,LL4 + AIL=AIL+ADECT(I,IGR)*SOUR(I,IGR) + 290 CONTINUE + 295 CONTINUE + DEVAL=AIL/BIL + DO 345 IGR=1,NGRP + DO 300 I=1,LL4 + WORK(I)=0.0 + 300 CONTINUE + DO 330 JGR=1,NGRP + WRITE(TEXT12,'(1HB,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS0,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 330 + CALL LCMGPD(IPSYS0,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ NUN /)) + DO 310 I=1,ILONG + WORK(I)=WORK(I)+AGAR(I)*EVECT(I,JGR) + 310 CONTINUE + 330 CONTINUE + DO 340 I=1,LL4 + SOUR(I,IGR)=SOUR(I,IGR)-REAL(DEVAL)*WORK(I) + 340 CONTINUE + 345 CONTINUE + ENDIF + DELKEF=-REAL(DEVAL/(EVAL*EVAL)) + IF(IMPX.GE.1) WRITE (6,'(/21H DELPER: DELTA KEFF =,1P,E17.9/)') + 1 DELKEF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(WORK) + RETURN + END diff --git a/Trivac/src/DELTA.f b/Trivac/src/DELTA.f new file mode 100755 index 0000000..0a98e7b --- /dev/null +++ b/Trivac/src/DELTA.f @@ -0,0 +1,177 @@ +*DECK DELTA + SUBROUTINE DELTA(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* calculation of direct or adjoint source components for a fixed source +* eigenvalue problem. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1): create or modification type(L_SOURCE) (GPT source) +* HENTRY(2): read-only type(L_FLUX) => unperturbed solution +* HENTRY(3): read-only type(L_SYSTEM) => unperturbed matrices +* HENTRY(4): read-only type(L_SYSTEM) => perturbed matrices +* HENTRY(5): read-only type(L_TRACK) => tracking. +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*Comments: +* The DELTA: calling specifications are: +* GPT := DELTA: [ GPT ] FLUX0 SYST0 DSYST TRACK :: (delta\_data) ; +* where +* GPT : name of the \emph{lcm} object (type L\_GPT) containing the fixed +* source. If GPT appears on the RHS, this information is used to initialize +* the state vector. +* FLUX0 : name of the \emph{lcm} object (type L\_FLUX) containing the +* unperturbed flux. +* SYST0 : name of the \emph{lcm} object (type L\_SYSTEM) containing the +* unperturbed system matrices. +* DSYST : name of the \emph{lcm} object (type L\_SYSTEM) containing a +* perturbation to the system matrices. +* TRACK : name of the \emph{lcm} object (type L\_TRACK) containing the +* \emph{tracking}. +* delta\_data}] : structure containing the data to module DELTA:} +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 + TYPE(C_PTR) KENTRY(NENTRY) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + CHARACTER TEXT12*12,HSIGN*12,CMODUL*12 + LOGICAL REC + INTEGER ISTATE(NSTATE) + TYPE(C_PTR) IPGPT,IPFLU0,IPSYS0,IPSYSP,IPTRK +*---- +* PARAMETER VALIDATION. +*---- + IF(NENTRY.LE.4) CALL XABORT('DELTA: FIVE PARAMETERS EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('DELTA: LC' + 1 //'M OBJECT EXPECTED AT LHS.') + IF((JENTRY(1).NE.0).AND.(JENTRY(1).NE.1)) CALL XABORT('DELTA: EN' + 1 //'TRY IN CREATE OR MODIFICATION MODE EXPECTED.') + IF((JENTRY(2).NE.2).OR.((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2))) + 1 CALL XABORT('DELTA: LCM OBJECT IN READ-ONLY MODE EXPECTED AT FI' + 2 //'RST RHS.') + IF((JENTRY(3).NE.2).OR.((IENTRY(3).NE.1).AND.(IENTRY(3).NE.2))) + 1 CALL XABORT('DELTA: LCM OBJECT IN READ-ONLY MODE EXPECTED AT SE' + 2 //'COND RHS.') + IF((JENTRY(4).NE.2).OR.((IENTRY(4).NE.1).AND.(IENTRY(4).NE.2))) + 1 CALL XABORT('DELTA: LCM OBJECT IN READ-ONLY MODE EXPECTED AT TH' + 2 //'IRD RHS.') + IF((JENTRY(5).NE.2).OR.((IENTRY(5).NE.1).AND.(IENTRY(5).NE.2))) + 1 CALL XABORT('DELTA: LCM OBJECT IN READ-ONLY MODE EXPECTED AT FO' + 2 //'URTH RHS.') + REC=(JENTRY(1).EQ.1) + IF(REC) THEN + CALL LCMGTC(KENTRY(1),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_SOURCE') THEN + TEXT12=HENTRY(1) + CALL XABORT('DELTA: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_SOURCE EXPECTED.') + ENDIF + ELSE + HSIGN='L_SOURCE' + CALL LCMPTC(KENTRY(1),'SIGNATURE',12,HSIGN) + ENDIF + CALL LCMGTC(KENTRY(2),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_FLUX') THEN + TEXT12=HENTRY(2) + CALL XABORT('DELTA: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_FLUX EXPECTED.') + ENDIF + CALL LCMGTC(KENTRY(3),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_SYSTEM') THEN + TEXT12=HENTRY(3) + CALL XABORT('DELTA: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_SYSTEM EXPECTED.') + ENDIF + CALL LCMGTC(KENTRY(4),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_SYSTEM') THEN + TEXT12=HENTRY(4) + CALL XABORT('DELTA: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_SYSTEM EXPECTED.') + ENDIF + CALL LCMGTC(KENTRY(5),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_TRACK') THEN + TEXT12=HENTRY(5) + CALL XABORT('DELTA: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_TRACK EXPECTED.') + ENDIF + CALL LCMGTC(KENTRY(2),'LINK.SYSTEM',12,TEXT12) + IF(TEXT12.NE.HENTRY(3)) CALL XABORT('DELTA: OBJECT '//HENTRY(3)// + 1 ' IS NOT AN UNPERTURBED SYSTEM OBJECT.') + CALL LCMGTC(KENTRY(2),'LINK.TRACK',12,TEXT12) + IF(TEXT12.NE.HENTRY(5)) CALL XABORT('DELTA: OBJECT '//HENTRY(3)// + 1 ' IS NOT A TRACKING OBJECT.') + TEXT12=HENTRY(2) + CALL LCMPTC(KENTRY(1),'LINK.FLUX',12,TEXT12) + TEXT12=HENTRY(3) + CALL LCMPTC(KENTRY(1),'LINK.SYSTEM',12,TEXT12) + TEXT12=HENTRY(4) + CALL LCMPTC(KENTRY(1),'LINK.TRACK',12,TEXT12) + IPGPT=KENTRY(1) + IPFLU0=KENTRY(2) + IPSYS0=KENTRY(3) + IPSYSP=KENTRY(4) + IPTRK=KENTRY(5) +*---- +* RECOVER GENERAL TRACKING INFORMATION. +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + NUN=ISTATE(2) + CALL LCMGTC(IPTRK,'TRACK-TYPE',12,CMODUL) + IF(CMODUL.NE.'TRIVAC') CALL XABORT('DELTA: TRIVAC TRACKING EXPEC' + 1 //'TED.') + CALL LCMGET(IPSYS0,'STATE-VECTOR',ISTATE) + NGRP=ISTATE(1) + LL4=ISTATE(2) + CALL LCMGET(IPSYSP,'STATE-VECTOR',ISTATE) + IF(ISTATE(1).NE.NGRP) CALL XABORT('DELTA: INVALID NGRP.') + IF(ISTATE(2).NE.LL4) CALL XABORT('DELTA: INVALID LL4.') + NSTEP=ISTATE(6) +*---- +* COMPUTE THE GPT SOLUTION. +*---- + CALL DELDRV(IPTRK,IPSYS0,IPSYSP,IPFLU0,IPGPT,NUN,NGRP,NSTEP) +*---- +* RELEASE GENERAL TRACKING INFORMATION. +*---- + IF(JENTRY(1).EQ.0) THEN + CALL LCMPTC(IPGPT,'TRACK-TYPE',12,CMODUL) + ISTATE(:NSTATE)=0 + ISTATE(1)=NGRP + ISTATE(2)=NUN + CALL LCMLEN(IPGPT,'DSOUR',ILENG,ITYLCM) + IF(ILENG.NE.0) ISTATE(3)=ILENG + CALL LCMLEN(IPGPT,'ASOUR',ILENG,ITYLCM) + IF(ILENG.NE.0) ISTATE(4)=ILENG + CALL LCMPUT(IPGPT,'STATE-VECTOR',NSTATE,1,ISTATE) + ENDIF + RETURN + END diff --git a/Trivac/src/ERRABS.f b/Trivac/src/ERRABS.f new file mode 100755 index 0000000..f851b28 --- /dev/null +++ b/Trivac/src/ERRABS.f @@ -0,0 +1,80 @@ +*DECK ERRABS + SUBROUTINE ERRABS(IPMAC,NREG2,NREG,NGRP,XABS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover absorption cross sections from the macrolib. +* +*Copyright: +* Copyright (C) 2016 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPMAC pointer to the macrolib. +* NREG2 number of regions in the absorption array. +* NREG number of regions in the macrolib. +* NGRP number of energy groups in the macrolib. +* XABS absorption cross sections. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMAC + INTEGER NREG2,NREG,NGRP + REAL XABS(NREG,NGRP) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPMAC,KPMAC + INTEGER, DIMENSION(:), ALLOCATABLE :: NJJ,IJJ,IPOS + REAL, DIMENSION(:), ALLOCATABLE :: TOTAL,XSIGS,XSCAT +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NJJ(NREG),IJJ(NREG),IPOS(NREG)) + ALLOCATE(TOTAL(NREG),XSIGS(NREG),XSCAT(NREG*NGRP)) +* + XABS(:NREG,:NGRP)=0.0 + JPMAC=LCMGID(IPMAC,'GROUP') + DO IGR=1,NGRP + KPMAC=LCMGIL(JPMAC,IGR) + CALL LCMGET(KPMAC,'NTOT0',TOTAL) + CALL LCMLEN(KPMAC,'SIGS00',ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + CALL LCMGET(KPMAC,'SIGS00',XSIGS) + DO I=1,NREG2 + XABS(I,IGR)=XABS(I,IGR)+TOTAL(I)-XSIGS(I) + ENDDO + ELSE + CALL LCMGET(KPMAC,'NJJS00',NJJ) + CALL LCMGET(KPMAC,'IJJS00',IJJ) + CALL LCMGET(KPMAC,'IPOS00',IPOS) + CALL LCMGET(KPMAC,'SCAT00',XSCAT) + DO I=1,NREG2 + XABS(I,IGR)=XABS(I,IGR)+TOTAL(I) + IPO=IPOS(I) + J2=IJJ(I) + J1=IJJ(I)-NJJ(I)+1 + DO JGR=J2,J1,-1 + XABS(I,JGR)=XABS(I,JGR)-XSCAT(IPO) + IPO=IPO+1 + ENDDO + ENDDO + ENDIF + ENDDO +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(XSCAT,XSIGS,TOTAL) + DEALLOCATE(IPOS,IJJ,NJJ) + RETURN + END diff --git a/Trivac/src/ERRDRV.f b/Trivac/src/ERRDRV.f new file mode 100755 index 0000000..b5ac203 --- /dev/null +++ b/Trivac/src/ERRDRV.f @@ -0,0 +1,288 @@ +*DECK ERRDRV + SUBROUTINE ERRDRV(IMPX,IPMAC1,IPMAC2,NREG,NREG2,NGRP,HREAC,ERAMAX, + 1 ERASUM,ERQMAX,ERQSUM,ERGMARR,ERGSARR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform reaction rate statistics between two extended macrolibs. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPMAC1 pointer to the reference extended macrolib. +* IPMAC2 pointer to the approximate extended macrolib. +* NREG number of regions in the macrolib. +* NREG2 number of regions used for statistics. +* NGRP number of energy groups in the macrolib. +* HREAC nuclear reaction used to compute power map +* +*Parameters: output +* ERAMAX maximum relative error on absorption rates. +* ERASUM average relative error on absorption rates. +* ERQMAX maximum relative error on QUANDRY powers. +* ERQSUM average relative error on QUANDRY powers. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMAC1,IPMAC2 + INTEGER IMPX,NREG,NGRP + REAL ERAMAX,ERASUM,ERQMAX,ERQSUM,ERGMARR(NGRP),ERGSARR(NGRP) + CHARACTER HREAC*8 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + CHARACTER HSMG*131 + INTEGER IDATA(NSTATE) + TYPE(C_PTR) JPMAC1,KPMAC1,JPMAC2,KPMAC2 + REAL, DIMENSION(:), ALLOCATABLE :: VOL1,VOL2,TOTAL,GAR,FLUX, + 1 QUAN1,QUAN2,TRABS1,TRABS2 + REAL, DIMENSION(:,:), ALLOCATABLE :: TRA1,TRA2,XABS1,XABS2 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(TRA1(NREG2,NGRP),TRA2(NREG,NGRP),XABS1(NREG,NGRP), + 1 XABS2(NREG,NGRP),VOL1(NREG),VOL2(NREG),TOTAL(NREG),GAR(NREG), + 2 FLUX(NREG),QUAN1(NREG),QUAN2(NREG),TRABS1(NREG),TRABS2(NREG)) +*---- +* RECOVER REFERENCE REACTION RATES: +*---- + CALL LCMGET(IPMAC1,'STATE-VECTOR',IDATA) + IF((NREG.NE.IDATA(2)).OR.(NGRP.NE.IDATA(1))) THEN + CALL XABORT('ERRDRV: INVALID VALUE OF NREG OR NGRP.') + ENDIF + CALL LCMGET(IPMAC1,'VOLUME',VOL1) + VOL1T=0.0 + PWR1T=0.0 + DO 10 I=1,NREG2 + TRABS1(I)=0.0 + QUAN1(I)=0.0 + VOL1T=VOL1T+VOL1(I) + 10 CONTINUE + TRA1(:NREG2,:NGRP)=0.0 + CALL ERRABS(IPMAC1,NREG2,NREG,NGRP,XABS1) + JPMAC1=LCMGID(IPMAC1,'GROUP') + DO 35 IGR=1,NGRP + KPMAC1=LCMGIL(JPMAC1,IGR) + CALL LCMGET(KPMAC1,'NTOT0',TOTAL) + CALL LCMGET(KPMAC1,'SIGW00',GAR) + CALL LCMGET(KPMAC1,'FLUX-INTG',FLUX) + DO 20 I=1,NREG2 + IF(VOL1(I).EQ.0.0) GO TO 20 + TRA1(I,IGR)=(TOTAL(I)-GAR(I))*FLUX(I)/VOL1(I) + TRABS1(I)=TRABS1(I)+XABS1(I,IGR)*FLUX(I)/VOL1(I) + 20 CONTINUE + CALL LCMLEN(KPMAC1,HREAC,ILONG,ITYLCM) + IF(ILONG.EQ.0) THEN + WRITE(HSMG,'(32HERRDRV: UNABLE TO FIND REACTION ,A,1H.)') HREAC + CALL XABORT(HSMG) + ENDIF + CALL LCMGET(KPMAC1,HREAC,GAR) + DO 30 I=1,NREG2 + QUAN1(I)=QUAN1(I)+GAR(I)*FLUX(I) + PWR1T=PWR1T+QUAN1(I) + 30 CONTINUE + 35 CONTINUE +*---- +* RECOVER APPROXIMATE REACTION RATES: +*---- + CALL LCMGET(IPMAC2,'STATE-VECTOR',IDATA) + IF((NREG.NE.IDATA(2)).OR.(NGRP.NE.IDATA(1))) THEN + CALL XABORT('ERRDRV: INVALID VALUE OF NREG OR NGRP.') + ENDIF + CALL LCMGET(IPMAC2,'VOLUME',VOL2) + VOL2T=0.0 + PWR2T=0.0 + DO 50 I=1,NREG2 + TRABS2(I)=0.0 + QUAN2(I)=0.0 + VOL2T=VOL2T+VOL2(I) + 50 CONTINUE + CALL ERRABS(IPMAC2,NREG2,NREG,NGRP,XABS2) + JPMAC2=LCMGID(IPMAC2,'GROUP') + DO 80 IGR=1,NGRP + KPMAC2=LCMGIL(JPMAC2,IGR) + CALL LCMGET(KPMAC2,'NTOT0',TOTAL) + CALL LCMGET(KPMAC2,'SIGW00',GAR) + CALL LCMGET(KPMAC2,'FLUX-INTG',FLUX) + DO 60 I=1,NREG2 + IF(VOL2(I).EQ.0.0) GO TO 60 + TRA2(I,IGR)=(TOTAL(I)-GAR(I))*FLUX(I)/VOL2(I) + TRABS2(I)=TRABS2(I)+XABS2(I,IGR)*FLUX(I)/VOL2(I) + 60 CONTINUE + IF(ILONG.NE.0) THEN + CALL LCMGET(KPMAC2,HREAC,GAR) + DO 70 I=1,NREG2 + QUAN2(I)=QUAN2(I)+GAR(I)*FLUX(I) + PWR2T=PWR2T+QUAN2(I) + 70 CONTINUE + ENDIF + 80 CONTINUE +*---- +* COMPUTE QUANDRY TYPE NORMALIZED POWER DENSITIES. +*---- + IF(ILONG.GT.0) THEN + DO 90 I=1,NREG2 + IF(VOL1(I).NE.0.0) QUAN1(I)=QUAN1(I)/VOL1(I) + IF(VOL2(I).NE.0.0) QUAN2(I)=QUAN2(I)/VOL2(I) + IF(PWR1T.NE.0.0) QUAN1(I)=QUAN1(I)*VOL1T/PWR1T + IF(PWR2T.NE.0.0) QUAN2(I)=QUAN2(I)*VOL2T/PWR2T + 90 CONTINUE + ENDIF +*---- +* PRINT STATISTICS ON GROUPWISE REMOVAL RATES. +*---- + WRITE(6,'(/47H ERRDRV: STATISTICS ON GROUPWISE REMOVAL RATES:)') + SUMREF=0.0 + SUM=0.0 + DO 125 IGR=1,NGRP + DO 120 I=1,NREG2 + SUMREF=SUMREF+TRA1(I,IGR)*VOL1(I) + SUM=SUM+TRA2(I,IGR)*VOL2(I) + 120 CONTINUE + 125 CONTINUE + DO 150 IGR=1,NGRP + WRITE (6,'(/17H PROCESSING GROUP,I3)') IGR + ERGMAX=0.0 + ERGSUM=0.0 + VOLTOT=0.0 + DO 130 I=1,NREG2 + TRA2(I,IGR)=TRA2(I,IGR)*(SUMREF/SUM)*(VOL2T/VOL1T) + IF(TRA1(I,IGR).NE.0.0) THEN + VOLTOT=VOLTOT+VOL1(I) + GAR(I)=100.0*(TRA2(I,IGR)-TRA1(I,IGR))/TRA1(I,IGR) + ELSE + GAR(I)=0.0 + ENDIF + ERGSUM=ERGSUM+VOL1(I)*ABS(GAR(I)) + ERGMAX=MAX(ERGMAX,ABS(GAR(I))) + 130 CONTINUE + ERGSUM=ERGSUM/VOLTOT + ERGMARR(IGR)=ERGMAX + ERGSARR(IGR)=ERGSUM + IF(IMPX.GT.1) WRITE (6,'(/8X,9HREFERENCE,7X,6HAPPROX,7X,5HERROR)') + DO 140 I=1,NREG2 + IF(IMPX.GT.1) WRITE (6,'(4X,I4,1X,1P,2E13.5,0P,F9.3,2H %)') + 1 I,TRA1(I,IGR),TRA2(I,IGR),GAR(I) + 140 CONTINUE + WRITE(6,300) IGR, ERGMAX,ERGMAX,ERGMAX + WRITE(6,310) IGR, ERGSUM,ERGSUM,ERGSUM + 150 CONTINUE + WRITE(6,400) MAXVAL(ERGMARR), MAXVAL(ERGMARR), + 1 MAXVAL(ERGMARR) + WRITE(6,410) MAXVAL(ERGSARR), MAXVAL(ERGSARR), + 1 MAXVAL(ERGSARR) +*---- +* PRINT STATISTICS ON CONDENSED ABSORPTION RATES. +*---- + WRITE(6,'(/40H ERRDRV: STATISTICS ON ABSORPTION RATES:)') + SUMREF=0.0 + SUM=0.0 + DO 160 I=1,NREG2 + SUMREF=SUMREF+TRABS1(I)*VOL1(I) + SUM=SUM+TRABS2(I)*VOL2(I) + 160 CONTINUE + ERAMAX=0.0 + ERASUM=0.0 + VOLTOT=0.0 + DO 165 I=1,NREG2 + TRABS2(I)=TRABS2(I)*(SUMREF/SUM)*(VOL2T/VOL1T) + IF(TRABS1(I).NE.0.0) THEN + VOLTOT=VOLTOT+VOL1(I) + GAR(I)=100.0*(TRABS2(I)-TRABS1(I))/TRABS1(I) + ELSE + GAR(I)=0.0 + ENDIF + ERASUM=ERASUM+VOL1(I)*ABS(GAR(I)) + ERAMAX=MAX(ERAMAX,ABS(GAR(I))) + 165 CONTINUE + ERASUM=ERASUM/VOLTOT + IF(IMPX.GT.1) WRITE (6,'(/8X,9HREFERENCE,7X,6HAPPROX,7X,5HERROR)') + DO 170 I=1,NREG2 + IF(IMPX.GT.1) WRITE (6,'(4X,I4,1X,1P,2E13.5,0P,F9.3,2H %)') + 1 I,TRABS1(I),TRABS2(I),GAR(I) + 170 CONTINUE + WRITE(6,420) ERAMAX,ERAMAX,ERAMAX + WRITE(6,430) ERASUM,ERASUM,ERASUM +*---- +* PRINT STATISTICS ON QUANDRY TYPE NORMALIZED POWER DENSITIES. +*---- + IF(ILONG.NE.0) THEN + WRITE(6,'(/48H ERRDRV: STATISTICS ON QUANDRY TYPE NORMALIZED P, + 1 15HOWER DENSITIES:)') + ERQMAX=0.0 + ERQSUM=0.0 + VOLTOT=0.0 + DO 180 I=1,NREG2 + ERR=ABS(VOL1(I)/VOL1T-VOL2(I)/VOL2T) + IF(ERR.GT.1.0E-4*ABS(VOL1(I)/VOL1T)) THEN + WRITE(HSMG,'(37HERRDRV: INCONSISTENT VOLUME IN REGION,I5, + 1 3H BY,F7.2,2H %)') I,ERR*100.0 + CALL XABORT(HSMG) + ENDIF + GAR(I)=0.0 + IF(QUAN1(I).EQ.0.0) GO TO 180 + VOLTOT=VOLTOT+VOL1(I) + GAR(I)=100.0*(QUAN2(I)-QUAN1(I))/QUAN1(I) + ERQSUM=ERQSUM+VOL1(I)*ABS(QUAN1(I)-QUAN2(I))/QUAN1(I) + ERQMAX=MAX(ERQMAX,ABS(GAR(I))) + 180 CONTINUE + IF(VOLTOT.NE.0.0) ERQSUM=100.0*ERQSUM/VOLTOT + IF(IMPX.GT.1) + 1 WRITE(6,'(/8X,9HREFERENCE,7X,6HAPPROX,7X,5HERROR)') + DO 190 I=1,NREG2 + IF((QUAN1(I).NE.0.0).OR.(QUAN2(I).NE.0.0)) THEN + IF(IMPX.GT.1) WRITE(6,'(4X,I4,1X,1P,2E13.5,0P,F9.3,2H %)') + 1 I,QUAN1(I),QUAN2(I),GAR(I) + ENDIF + 190 CONTINUE + WRITE(6,440) ERQMAX,ERQMAX,ERQMAX + WRITE(6,450) ERQSUM,ERQSUM,ERQSUM + ENDIF +*---- +* PRINT STATISTICS ON K-EFFECTIVE. +*---- + CALL LCMLEN(IPMAC1,'K-EFFECTIVE',LENGT,ITYLCM) + IF(LENGT.EQ.1) THEN + CALL LCMGET(IPMAC1,'K-EFFECTIVE',FKEFF1) + CALL LCMGET(IPMAC2,'K-EFFECTIVE',FKEFF2) + WRITE(6,'(/5X,22HREFERENCE K-EFFECTIVE=,F9.6/8X,11HAPPROX K-EF, + 1 8HFECTIVE=,F9.6,8H ERROR=,F9.1,4H PCM)') FKEFF1,FKEFF2, + 2 (FKEFF2-FKEFF1)*1.0E5 + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(XABS2,XABS1,TRA1,TRA2,VOL1,VOL2,TOTAL,GAR,FLUX,QUAN2, + 1 QUAN1,TRABS2,TRABS1) + RETURN +* + 300 FORMAT(/1X,37HGROUPWISE REM. RATE MAX ERR FOR GROUP,I4,2H =, + 1 F9.3,2H %,F9.2,2H %,F9.1,2H %) + 310 FORMAT( 1X,37HGROUPWISE REM. RATE AV. ERR FOR GROUP,I4,2H =, + 1 F9.3,2H %,F9.2,2H %,F9.1,2H %/) + 400 FORMAT(/1X,30HMAXIMUM ERROR OVER ALL GROUPS=,F9.3,2H %,F9.2,2H %, + 1 F9.1,2H %) + 410 FORMAT( 1X,30HAVERAGE ERROR OVER ALL GROUPS=,F9.3,2H %,F9.2,2H %, + 1 F9.1,2H %/) + 420 FORMAT(/1X,30HABSORPTION RATE MAXIMUM ERROR=,F9.3,2H %,F9.2,2H %, + 1 F9.1,2H %) + 430 FORMAT( 1X,30HABSORPTION RATE AVERAGE ERROR=,F9.3,2H %,F9.2,2H %, + 1 F9.1,2H %/) + 440 FORMAT(/1X,28HPOWER DENSITY MAXIMUM ERROR=,F9.3,2H %,F9.2,2H %, + 1 F9.1,2H %) + 450 FORMAT( 1X,28HPOWER DENSITY AVERAGE ERROR=,F9.3,2H %,F9.2,2H %, + 1 F9.1,2H %/) + END diff --git a/Trivac/src/ERROR.f b/Trivac/src/ERROR.f new file mode 100755 index 0000000..7e87f6b --- /dev/null +++ b/Trivac/src/ERROR.f @@ -0,0 +1,198 @@ +*DECK ERROR + SUBROUTINE ERROR(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Reaction rate comparison operator. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1): read-only reference macrolib type(L_MACROLIB); +* HENTRY(2): read-only macrolib type(L_MACROLIB); +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*Comments: +* The ERROR: calling specifications are: +* ERROR: MACRO1 MACRO2 :: [ HREA hname ] [ NREG nreg ] ; +* where +* MACRO1 : name of the \emph{lcm} object (type L\_MACROLIB) containing the +* extended \emph{macrolib} used to compute the reference reaction rates. +* MACRO2 : name of the \emph{lcm} object (type L\_MACROLIB) containing the +* extended \emph{macrolib} used to compute the approximate reaction rates. +* HREA : keyword used to set the character name hname. +* hname : name of the nuclear reaction used to compute the power map. By +* default, reaction H-FACTOR is used. +* NREG : keyword used to set the nreg number. +* nreg : integer number set to the number of regions used in statistics. By +* default, all available regions are used. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + CHARACTER TITLE*72,TEXT12*12,HSIGN*12,TEXT4*4,TEXT6*6,HREAC*8 + INTEGER IDATA(NSTATE) + DOUBLE PRECISION DFLOTT + REAL,ALLOCATABLE,DIMENSION(:) :: ERGMARR, ERGSARR + TYPE(C_PTR) IPMAC1,IPMAC2 +*---- +* PARAMETER VALIDATION. +*---- + IF(NENTRY.LE.1) CALL XABORT('ERROR: TWO PARAMETERS EXPECTED.') + IF((JENTRY(1).NE.2).OR.(IENTRY(1).LT.1).OR.(IENTRY(1).GT.4)) + 1 CALL XABORT('ERROR: LINKED LIST OR FILE IN READ-ONLY MODE EXPE' + 2 //'CTED AT FIRST RHS.') + IF((JENTRY(2).NE.2).OR.(IENTRY(2).LT.1).OR.(IENTRY(2).GT.4)) + 1 CALL XABORT('ERROR: LINKED LIST OR FILE IN READ-ONLY MODE EXPE' + 2 //'CTED AT SECOND RHS.') +*---- +* PROCESS FIRST AND SECOND RHS. +*---- + IF(IENTRY(1).GE.3) THEN + IFTRAK=FILUNIT(KENTRY(1)) + CALL LCMOP(IPMAC1,'COPY1',0,1,0) + CALL LCMEXP(IPMAC1,0,IFTRAK,IENTRY(1)-2,2) + ELSE + IPMAC1=KENTRY(1) + ENDIF + CALL LCMGTC(IPMAC1,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_MACROLIB') THEN + TEXT12=HENTRY(1) + CALL XABORT('ERROR: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_MACROLIB EXPECTED.') + ENDIF + IF(IENTRY(2).GE.3) THEN + IFTRAK=FILUNIT(KENTRY(2)) + CALL LCMOP(IPMAC2,'COPY2',0,1,0) + CALL LCMEXP(IPMAC2,0,IFTRAK,IENTRY(2)-2,2) + ELSE + IPMAC2=KENTRY(2) + ENDIF + CALL LCMGTC(IPMAC2,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_MACROLIB') THEN + TEXT12=HENTRY(2) + CALL XABORT('ERROR: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_MACROLIB EXPECTED.') + ENDIF + CALL LCMLEN(IPMAC2,'TITLE',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + CALL LCMGTC(IPMAC2,'TITLE',72,TITLE) + ELSE + TITLE='*** NO TITLE PROVIDED ***' + ENDIF + WRITE(6,'(/1X,A72)') TITLE +* + CALL LCMGET(IPMAC1,'STATE-VECTOR',IDATA) + NGRP=IDATA(1) + NREG=IDATA(2) + CALL LCMGET(IPMAC2,'STATE-VECTOR',IDATA) + IF((NREG.NE.IDATA(2)).OR.(NGRP.NE.IDATA(1))) THEN + WRITE (6,'(/16H REFERENCE NREG=,I7,6H NGRP=,I7)') NREG,NGRP + WRITE (6,'(/16H APPROX. NREG=,I7,6H NGRP=,I7)') IDATA(2), + 1 IDATA(1) + CALL XABORT('ERROR: REFERENCE AND APPROX. DATA ARE NOT COMPA' + 1 //'TIBLE.') + ENDIF +*---- +* READ THE MAC: MODULE OPTIONS. +*---- + NREG2=NREG + IMPX=1 + IPICK=0 + HREAC='H-FACTOR' + 10 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.EQ.10) GO TO 20 + IF(INDIC.NE.3) CALL XABORT('ERROR: CHARACTER DATA EXPECTED.') + IF(TEXT4.EQ.'EDIT') THEN +* SET EDITION + CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('ERROR: INTEGER DATA EXPECTED.') + ELSE IF(TEXT4.EQ.'NREG') THEN +* SET NUMBER OF REGIONS + CALL REDGET(INDIC,NREG2,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('ERROR: INTEGER DATA EXPECTED.') + IF((NREG2.LE.0).OR.(NREG2.GT.NREG)) THEN + CALL XABORT('ERROR: INVALID NUMBER OF REGIONS AFTER NREG.') + ENDIF + ELSE IF(TEXT4.EQ.'HREA') THEN + CALL REDGET(INDIC,NITMA,FLOTT,HREAC,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('ERROR: CHARACTER DATA EXPECTED.') + ELSE IF(TEXT4.EQ.'PICK') THEN + IPICK=1 + GO TO 20 + ELSE IF(TEXT4.EQ.';') THEN + GO TO 20 + ELSE + CALL XABORT('ERROR: '//TEXT4//' IS AN INVALID KEY-WORD.') + ENDIF + GO TO 10 +*---- +* COMPUTE STATISTICS +*---- + 20 ALLOCATE(ERGMARR(NGRP),ERGSARR(NGRP)) + ERGMARR(:NGRP)=0.0 + ERGSARR(:NGRP)=0.0 + CALL ERRDRV(IMPX,IPMAC1,IPMAC2,NREG,NREG2,NGRP,HREAC,ERAMAX, + 1 ERASUM,ERQMAX,ERQSUM,ERGMARR,ERGSARR) + IF(IENTRY(1).GE.3) CALL LCMCL(IPMAC1,2) + IF(IENTRY(2).GE.3) CALL LCMCL(IPMAC2,2) +*---- +* PICK STATISTICS AS CLE200 VARIABLES +*---- + IF(IPICK.EQ.1) THEN + 30 CALL REDGET(INDIC,NITMA,FLOTT,TEXT6,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('ERROR: CHARACTER DATA EXPECTED.') + IF(TEXT6.EQ.';') RETURN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.-2) CALL XABORT('ERROR: OUTPUT REAL EXPECTED.') + INDIC=2 + IF(TEXT6.EQ.'ERAMAX') THEN + FLOTT=ERAMAX + ELSE IF(TEXT6.EQ.'ERASUM') THEN + FLOTT=ERASUM + ELSE IF(TEXT6.EQ.'ERQMAX') THEN + FLOTT=ERQMAX + ELSE IF(TEXT6.EQ.'ERQSUM') THEN + FLOTT=ERQSUM + ELSE IF(TEXT6.EQ.'ERGMAX') THEN + FLOTT=MAXVAL(ERGMARR) + ELSE IF(TEXT6.EQ.'ERGSUM') THEN + FLOTT=MAXVAL(ERGSARR) + ELSE + CALL XABORT('ERROR: INVALID KEYWORD: '//TEXT6//'.') + ENDIF + IF(IMPX.GT.0) WRITE(6,40) TEXT6,FLOTT + CALL REDPUT(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + GO TO 30 + ENDIF + DEALLOCATE(ERGMARR,ERGSARR) + RETURN + 40 FORMAT(/13H ERROR: PICK ,A,1H=,1P,E12.4,2H %) + END diff --git a/Trivac/src/FLD.f b/Trivac/src/FLD.f new file mode 100755 index 0000000..6900797 --- /dev/null +++ b/Trivac/src/FLD.f @@ -0,0 +1,178 @@ +*DECK FLD + SUBROUTINE FLD(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Multigroup flux solution operator for BIVAC and TRIVAC. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1): create or modification type(L_FLUX); +* HENTRY(2): read-only type(L_SYSTEM); +* HENTRY(3): read-only type(L_TRACK); +* HENTRY(4): optional read-only type(L_MACROLIB). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*Comments: +* The FLUD: calling specifications are: +* FLUX := FLUD: [ FLUX ] SYST TRACK [ MACRO ] :: (flud\_data) ; +* where +* FLUX : name of the \emph{lcm} object (type L\_FLUX) containing the +* solution. If FLUX appears on the RHS, the solution previously stored in +* FLUX is used to initialize the new iterative process; otherwise, a uniform +* unknown vector is used. +* SYST : name of the \emph{lcm} object (type L\_SYSTEM) containing the +* system matrices. +* TRACK : name of the \emph{lcm} object (type L\_TRACK) containing the +* \emph{tracking}. +* MACRO : name of the optional \emph{lcm} object (type L\_MACROLIB) +* containing the cross sections. This object is only used to set a link to +* the \emph{macrolib} name inside the \emph{flux} object. By default, the +* name of the \emph{macrolib} is recovered from the link in the +* \emph{system} object. +* flud\_data}] : structure containing the data to module FLUD:} +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + CHARACTER TEXT12*12,TITLE*72,CMODUL*12,HSIGN*12 + LOGICAL REC,LREL + INTEGER IGP(NSTATE),ITR(NSTATE) + TYPE(C_PTR) IPTRK,IPSYS,IPFLUX + INTEGER, DIMENSION(:), ALLOCATABLE :: MAT,IDL + REAL, DIMENSION(:), ALLOCATABLE :: VOL +*---- +* PARAMETER VALIDATION +*---- + LREL=(JENTRY(1).EQ.1) + IF(NENTRY.LE.1) CALL XABORT('FLD: TWO PARAMETERS EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('FLD: LCM ' + 1 //'OBJECT EXPECTED AT LHS.') + IF((JENTRY(1).NE.0).AND.(JENTRY(1).NE.1)) CALL XABORT('FLD: ENTR' + 1 //'Y IN CREATE OR MODIFICATION MODE EXPECTED.') + IF((JENTRY(2).NE.2).OR.((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2))) + 1 CALL XABORT('FLD: LCM OBJECT IN READ-ONLY MODE EXPECTED AT RHS.') + IF(JENTRY(1).EQ.1) THEN + CALL LCMGTC(KENTRY(1),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_FLUX') THEN + TEXT12=HENTRY(1) + CALL XABORT('FLD: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_FLUX EXPECTED.') + ENDIF + ENDIF + CALL LCMGTC(KENTRY(2),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_SYSTEM') THEN + TEXT12=HENTRY(2) + CALL XABORT('FLD: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_SYSTEM EXPECTED.') + ENDIF + HSIGN='L_FLUX' + CALL LCMPTC(KENTRY(1),'SIGNATURE',12,HSIGN) + TEXT12=HENTRY(2) + CALL LCMPTC(KENTRY(1),'LINK.SYSTEM',12,TEXT12) + IPFLUX=KENTRY(1) + IPSYS=KENTRY(2) + REC=(JENTRY(1).EQ.1) +*---- +* RECOVER IPTRK POINTER AND VALIDATE IT +*---- + IF(NENTRY.EQ.4) THEN + CALL LCMGTC(KENTRY(4),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_MACROLIB') THEN + TEXT12=HENTRY(4) + CALL XABORT('FLD: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_MACROLIB EXPECTED.') + ENDIF + TEXT12=HENTRY(4) + ELSE + CALL LCMGTC(IPSYS,'LINK.MACRO',12,TEXT12) + ENDIF + CALL LCMPTC(KENTRY(1),'LINK.MACRO',12,TEXT12) + CALL LCMGTC(IPSYS,'LINK.TRACK',12,TEXT12) + CALL LCMPTC(KENTRY(1),'LINK.TRACK',12,TEXT12) + DO 10 I=1,NENTRY + IF(HENTRY(I).EQ.TEXT12) THEN + IPTRK=KENTRY(I) + CALL LCMGTC(IPTRK,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_TRACK') THEN + TEXT12=HENTRY(I) + CALL XABORT('FLD: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_TRACK EXPECTED.') + ENDIF + CALL LCMGTC(IPTRK,'TRACK-TYPE',12,CMODUL) + IF((IENTRY(I).NE.1).AND.(IENTRY(I).NE.2)) CALL XABORT('FLD: L' + 1 //'CM OBJECT EXPECTED TO CONTAIN THE TRACKING.') + GO TO 20 + ENDIF + 10 CONTINUE + CALL XABORT('FLD: UNABLE TO FIND A POINTER TO TRACKING.') +*---- +* RECOVER GENERAL TRACKING INFORMATION +*---- + 20 CALL LCMGET(IPTRK,'STATE-VECTOR',IGP) + NEL=IGP(1) + NUN=IGP(2) + NLF=0 + IF(CMODUL.EQ.'BIVAC') THEN + NLF=IGP(14) + ELSE IF(CMODUL.EQ.'TRIVAC') THEN + NLF=IGP(30) + ENDIF + ALLOCATE(MAT(NEL),VOL(NEL),IDL(NEL)) + CALL LCMGET(IPTRK,'MATCOD',MAT) + CALL LCMGET(IPTRK,'VOLUME',VOL) + CALL LCMGET(IPTRK,'KEYFLX',IDL) + CALL LCMLEN(IPTRK,'TITLE',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + CALL LCMGTC(IPTRK,'TITLE',72,TITLE) + ELSE + TITLE='*** NO TITLE PROVIDED ***' + ENDIF +*---- +* RECOVER GENERAL L_SYSTEM INFORMATION +*---- + CALL LCMGET(IPSYS,'STATE-VECTOR',ITR) + NGRP=ITR(1) + LL4=ITR(2) + ITY=ITR(4) + NBMIX=ITR(7) + IF((ITY.EQ.11).OR.(ITY.EQ.13)) LL4=LL4*NLF/2 +*---- +* COMPUTE THE FLUX +*---- + CALL FLDDRV(CMODUL,IPTRK,IPSYS,REC,NEL,LL4,ITY,NUN,NBMIX,MAT,VOL, + 1 IDL,NGRP,TITLE,LREL,IPFLUX) +*---- +* RELEASE GENERAL TRACKING INFORMATION +*---- + DEALLOCATE(IDL,VOL,MAT) + RETURN + END diff --git a/Trivac/src/FLD2AC.f b/Trivac/src/FLD2AC.f new file mode 100755 index 0000000..371358d --- /dev/null +++ b/Trivac/src/FLD2AC.f @@ -0,0 +1,78 @@ +*DECK FLD2AC + SUBROUTINE FLD2AC(NG,NUN,IG0,FLUX,ZMU) +* +*----------------------------------------------------------------------- +* +*Purpose: +* one-factor variationnal acceleration of the flux. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* NG number of energy groups. +* NUN number of unknowns per energy group. +* IG0 first group to accelerate. +* +*Parameters: input/output +* FLUX neutron flux: +* FLUX(:,:,1) <=old; +* FLUX(:,:,2) <=present; +* FLUX(:,:,3) <=new. +* +*Parameters: output +* ZMU acceleration factor. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NG, NUN, IG0 + REAL FLUX(NUN,NG,3), ZMU +*---- +* LOCAL VARIABLES +*---- + INTEGER IG, IR + DOUBLE PRECISION DMU, R1, R2 + DOUBLE PRECISION DONE, DZERO, NOM, DENOM + PARAMETER ( DONE=1.0D0, DZERO=0.0D0 ) +*---- +* ZMU CALCULATION +*---- + NOM = DZERO + DENOM = DZERO + DO 3 IG= IG0,NG + DO 2 IR=1,NUN + R1 = FLUX(IR,IG,2) - FLUX(IR,IG,1) + R2 = FLUX(IR,IG,3) - FLUX(IR,IG,2) + NOM = NOM + R1*(R2-R1) + DENOM = DENOM + (R2-R1)*(R2-R1) + 2 CONTINUE + 3 CONTINUE +* + DMU = - NOM / DENOM + ZMU = REAL(DMU) + IF( DMU.GT.DZERO )THEN + DO 13 IG= IG0,NG + DO 12 IR=1,NUN +* +* ACCELERATED VALUES FOR PHI(2) ET PHI(3) + FLUX(IR,IG,3) = FLUX(IR,IG,2) + REAL(DMU) * + > (FLUX(IR,IG,3) - FLUX(IR,IG,2)) + FLUX(IR,IG,2) = FLUX(IR,IG,1) + REAL(DMU) * + > (FLUX(IR,IG,2) - FLUX(IR,IG,1)) + 12 CONTINUE + 13 CONTINUE + ELSE + ZMU= 1.0 + ENDIF + RETURN + END diff --git a/Trivac/src/FLDADI.f b/Trivac/src/FLDADI.f new file mode 100755 index 0000000..8c01e18 --- /dev/null +++ b/Trivac/src/FLDADI.f @@ -0,0 +1,78 @@ +*DECK FLDADI + SUBROUTINE FLDADI (NAMP,IPTRK,IPSYS,LL4,ITY,F1,NADI) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform NADI inner iterations with the ADI preconditionning method. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NAMP name of the ADI-splitted matrix. +* IPTRK L_TRACK pointer to the tracking information. +* IPSYS L_SYSTEM pointer to system matrices. +* LL4 order of the matrix. +* ITY type of coefficient matrix (2: classical Trivac; +* 3: Thomas-Raviart; 13: SPN/Thomas-Raviart). +* F1 source term of the linear system. +* NADI number of inner ADI iterations. +* +*Parameters: output +* F1 solution of the linear system after NADI iterations. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPSYS + CHARACTER NAMP*12 + INTEGER LL4,ITY,NADI + REAL F1(LL4) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + INTEGER ITP(NSTATE) + REAL, DIMENSION(:), ALLOCATABLE :: S1,GAR +* + ALLOCATE(S1(LL4)) + S1(:LL4)=F1(:LL4) ! SOURCE TERM + F1(:LL4)=0.0 + IF(ITY.EQ.2) THEN +* CLASSICAL TREATMENT + ALLOCATE(GAR(LL4)) + DO IADI=1,NADI + IF(IADI.EQ.1) THEN + GAR(:LL4)=S1(:LL4) + ELSE + CALL MTLDLM(NAMP,IPTRK,IPSYS,LL4,ITY,F1,GAR) + GAR(:LL4)=S1(:LL4)-GAR(:LL4) + ENDIF + CALL MTLDLS(NAMP,IPTRK,IPSYS,LL4,ITY,GAR) + F1(:LL4)=F1(:LL4)+GAR(:LL4) + ENDDO + DEALLOCATE(GAR) + ELSE IF(ITY.EQ.3) THEN +* THOMAS-RAVIART/DIFFUSION TRIVAC TRACKING. + CALL FLDTRS(NAMP,IPTRK,IPSYS,LL4,S1,F1,NADI) + ELSE IF(ITY.EQ.13) THEN +* THOMAS-RAVIART/SIMPLIFIED PN TRIVAC TRACKING. + CALL LCMGET(IPSYS,'STATE-VECTOR',ITP) + NBMIX=ITP(7) + NAN=ITP(8) + IF(NAN.EQ.0) CALL XABORT('FLDADI: SPN-ONLY ALGORITHM.') + CALL FLDSPN(NAMP,IPTRK,IPSYS,LL4,NBMIX,NAN,S1,F1,NADI) + ENDIF + DEALLOCATE(S1) + RETURN + END diff --git a/Trivac/src/FLDADJ.f b/Trivac/src/FLDADJ.f new file mode 100755 index 0000000..4be5481 --- /dev/null +++ b/Trivac/src/FLDADJ.f @@ -0,0 +1,478 @@ +*DECK FLDADJ + SUBROUTINE FLDADJ(IPTRK,IPSYS,IPFLUX,LL4,ITY,NUN,NGRP,ICL1,ICL2, + 1 IMPX,EPS2,NADI,MAXOUT,MAXINR,EPSINR,ADECT,FKEFF) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solution of a multigroup eigenvalue system for the calculation of the +* adjoint neutron flux in TRIVAC. Use the preconditionned power method +* with a two-parameter SVAT acceleration technique. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK L_TRACK pointer to the tracking information. +* IPSYS L_SYSTEM pointer to system matrices. +* IPFLUX L_FLUX pointer to the solution. +* LL4 order of the system matrices. +* ITY type of solution (2: classical Trivac; 3: Thomas-Raviart). +* NUN number of unknowns in each energy group. +* NGRP number of energy groups. +* ICL1 number of free iterations in one cycle of the inverse power +* method. +* ICL2 number of accelerated iterations in one cycle. +* IMPX print parameter: =0: no print ; =1: minimum printing; +* =2: iteration history is printed; =3: solution is printed. +* TITR title. +* EPS2 convergence criteria for the flux. +* NADI number of inner ADI iterations per outer iteration. +* MAXOUT maximum number of outer iterations. +* MAXINR maximum number of thermal iterations. +* EPSINR thermal iteration epsilon. +* ADECT initial estimate of the unknown vector. +* +*Parameters: output +* FKEFF effective multiplication factor. +* ADECT converged unknown vector. +* +*Reference: +* A. H\'ebert, 'Preconditioning the power method for reactor +* calculations', Nucl. Sci. Eng., 94, 1 (1986). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPSYS,IPFLUX + INTEGER LL4,ITY,NUN,NGRP,ICL1,ICL2,IMPX,NADI,MAXOUT,MAXINR + REAL FKEFF,EPS2,EPSINR,ADECT(NUN,NGRP) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (EPS1=1.0E-5) + CHARACTER*12 TEXT12 + LOGICAL LOGTES + DOUBLE PRECISION AEAE,AEAG,AEAH,AGAG,AGAH,AHAH,BEBE,BEBG,BEBH, + 1 BGBG,BGBH,BHBH,AEBE,AEBG,AEBH,AGBE,AGBG,AGBH,AHBE,AHBG,AHBH, + 2 X,DXDA,DXDB,Y,DYDA,DYDB,Z,DZDA,DZDB,F,D2F(2,3),EVAL,ALP,BET, + 3 FMIN + DOUBLE PRECISION, PARAMETER :: ALP_TAB(24) = (/ 0.2, 0.4, 0.6, + 1 0.8, 1.0, 1.2, 1.5, 2.0, 10.0, 15.0, 20.0, 25.0, 30.0, 35.0, + 2 40.0, 45.0, 50.0, 55.0, 60.0, 65.0, 70.0, 75.0, 80.0, 85.0 /) + DOUBLE PRECISION, PARAMETER :: BET_TAB(11) = (/ -1.0, -0.8, -0.6, + 1 -0.4, -0.2, 0.0, 0.2, 0.4, 0.6, 0.8, 1.0 /) + REAL, DIMENSION(:,:), ALLOCATABLE :: GRAD1,GRAD2,GAR1,GAR2,GAR3 + REAL, DIMENSION(:), ALLOCATABLE :: GAF1,GAF2,GAF3 + REAL, DIMENSION(:), POINTER :: AGAR + TYPE(C_PTR) AGAR_PTR +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(GRAD1(NUN,NGRP),GRAD2(NUN,NGRP),GAR1(NUN,NGRP), + 1 GAR2(NUN,NGRP),GAR3(NUN,NGRP),GAF1(NUN),GAF2(NUN),GAF3(NUN)) +* +* TKT : CPU TIME FOR THE SOLUTION OF LINEAR SYSTEMS. +* TKB : CPU TIME FOR BILINEAR PRODUCT EVALUATIONS. + TKT=0.0 + TKB=0.0 + CALL KDRCPU(TK1) + CALL MTOPEN(IMPX,IPTRK,LL4) + IF(LL4.GT.NUN) CALL XABORT('FLDADJ: INVALID NUMBER OF UNKNOWNS.') +*---- +* PRECONDITIONED POWER METHOD +*---- + EVAL=1.0D0 + VVV=0.0 + ISTART=1 + NNADI=NADI + TEST=0.0 + IF(IMPX.GE.1) WRITE (6,600) NADI + IF(IMPX.GE.2) WRITE (6,610) + DO 35 IGR=1,NGRP + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,ADECT(1,IGR),GAR1(1,IGR)) + DO 30 JGR=1,NGRP + IF(JGR.EQ.IGR) GO TO 30 + WRITE(TEXT12,'(1HA,2I3.3)') JGR,IGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 30 + IF(ITY.EQ.13) THEN + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,ADECT(1,JGR),GAF1(1)) + DO 10 I=1,LL4 + GAR1(I,IGR)=GAR1(I,IGR)-GAF1(I) + 10 CONTINUE + ELSE + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ ILONG /)) + DO 20 I=1,ILONG + GAR1(I,IGR)=GAR1(I,IGR)-AGAR(I)*ADECT(I,JGR) + 20 CONTINUE + ENDIF + 30 CONTINUE + 35 CONTINUE + CALL KDRCPU(TK2) + TKB=TKB+(TK2-TK1) +* + M=0 + 40 M=M+1 +*---- +* EIGENVALUE EVALUATION +*---- + CALL KDRCPU(TK1) + AEBE=0.0D0 + BEBE=0.0D0 + DO 95 IGR=1,NGRP + DO 50 I=1,LL4 + GAF1(I)=0.0 + 50 CONTINUE + DO 80 JGR=1,NGRP + WRITE(TEXT12,'(1HB,2I3.3)') JGR,IGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 80 + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ ILONG /)) + DO 60 I=1,ILONG + GAF1(I)=GAF1(I)+AGAR(I)*ADECT(I,JGR) + 60 CONTINUE + 80 CONTINUE + DO 90 I=1,LL4 + AEBE=AEBE+GAR1(I,IGR)*GAF1(I) + BEBE=BEBE+GAF1(I)**2 + GRAD1(I,IGR)=GAF1(I) + 90 CONTINUE + 95 CONTINUE + EVAL=AEBE/BEBE + CALL KDRCPU(TK2) + TKB=TKB+(TK2-TK1) +*---- +* DIRECTION EVALUATION +*---- + DO 140 IGR=NGRP,1,-1 + CALL KDRCPU(TK1) + DO 100 I=1,LL4 + GRAD1(I,IGR)=REAL(EVAL)*GRAD1(I,IGR)-GAR1(I,IGR) + 100 CONTINUE + DO 130 JGR=NGRP,IGR+1,-1 + WRITE(TEXT12,'(1HA,2I3.3)') JGR,IGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 130 + IF(ITY.EQ.13) THEN + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD1(1,JGR),GAF1(1)) + DO 110 I=1,LL4 + GRAD1(I,IGR)=GRAD1(I,IGR)+GAF1(I) + 110 CONTINUE + ELSE + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ ILONG /)) + DO 120 I=1,ILONG + GRAD1(I,IGR)=GRAD1(I,IGR)+AGAR(I)*GRAD1(I,JGR) + 120 CONTINUE + ENDIF + 130 CONTINUE + CALL KDRCPU(TK2) + TKB=TKB+(TK2-TK1) +* + CALL KDRCPU(TK1) + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL FLDADI(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD1(1,IGR),NNADI) + CALL KDRCPU(TK2) + TKT=TKT+(TK2-TK1) + 140 CONTINUE +*---- +* PERFORM THERMAL (UP-SCATTERING) ITERATIONS +*---- + IF(MAXINR.GT.1) THEN + CALL FLDTHR(IPTRK,IPSYS,IPFLUX,.TRUE.,LL4,ITY,NUN,NGRP,ICL1, + 1 ICL2,IMPX,NNADI,0,MAXINR,EPSINR,ITER,TKT,TKB,GRAD1) + ENDIF +*---- +* DISPLACEMENT EVALUATION +*---- + F=0.0D0 + DELS=ABS(REAL((EVAL-VVV)/EVAL)) + VVV=REAL(EVAL) + CALL KDRCPU(TK1) +*---- +* EVALUATION OF THE TWO ACCELERATION PARAMETERS ALP AND BET +*---- + ALP=1.0D0 + BET=0.0D0 + N=0 + AEAE=0.0D0 + AEAG=0.0D0 + AEAH=0.0D0 + AGAG=0.0D0 + AGAH=0.0D0 + AHAH=0.0D0 + BEBG=0.0D0 + BEBH=0.0D0 + BGBG=0.0D0 + BGBH=0.0D0 + BHBH=0.0D0 + AEBG=0.0D0 + AEBH=0.0D0 + AGBE=0.0D0 + AGBG=0.0D0 + AGBH=0.0D0 + AHBE=0.0D0 + AHBG=0.0D0 + AHBH=0.0D0 + DO 175 IGR=1,NGRP + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD1(1,IGR),GAR2(1,IGR)) + DO 170 JGR=1,NGRP + IF(JGR.EQ.IGR) GO TO 170 + WRITE(TEXT12,'(1HA,2I3.3)') JGR,IGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 170 + IF(ITY.EQ.13) THEN + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD1(1,JGR),GAF1(1)) + DO 150 I=1,LL4 + GAR2(I,IGR)=GAR2(I,IGR)-GAF1(I) + 150 CONTINUE + ELSE + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ ILONG /)) + DO 160 I=1,ILONG + GAR2(I,IGR)=GAR2(I,IGR)-AGAR(I)*GRAD1(I,JGR) + 160 CONTINUE + ENDIF + 170 CONTINUE + 175 CONTINUE + IF(1+MOD(M-ISTART,ICL1+ICL2).GT.ICL1) THEN + DO 205 IGR=1,NGRP + GAF1(:LL4)=0.0 + GAF2(:LL4)=0.0 + GAF3(:LL4)=0.0 + DO 190 JGR=1,NGRP + WRITE(TEXT12,'(1HB,2I3.3)') JGR,IGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 190 + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ ILONG /)) + DO 180 I=1,ILONG + GAF1(I)=GAF1(I)+AGAR(I)*ADECT(I,JGR) + GAF2(I)=GAF2(I)+AGAR(I)*GRAD1(I,JGR) + GAF3(I)=GAF3(I)+AGAR(I)*GRAD2(I,JGR) + 180 CONTINUE + 190 CONTINUE + DO 200 I=1,LL4 +* COMPUTE (A ,A ) + AEAE=AEAE+GAR1(I,IGR)**2 + AEAG=AEAG+GAR1(I,IGR)*GAR2(I,IGR) + AEAH=AEAH+GAR1(I,IGR)*GAR3(I,IGR) + AGAG=AGAG+GAR2(I,IGR)**2 + AGAH=AGAH+GAR2(I,IGR)*GAR3(I,IGR) + AHAH=AHAH+GAR3(I,IGR)**2 +* COMPUTE (B ,B ) + BEBG=BEBG+GAF1(I)*GAF2(I) + BEBH=BEBH+GAF1(I)*GAF3(I) + BGBG=BGBG+GAF2(I)**2 + BGBH=BGBH+GAF2(I)*GAF3(I) + BHBH=BHBH+GAF3(I)**2 +* COMPUTE (A ,B ) + AEBG=AEBG+GAR1(I,IGR)*GAF2(I) + AEBH=AEBH+GAR1(I,IGR)*GAF3(I) + AGBE=AGBE+GAR2(I,IGR)*GAF1(I) + AGBG=AGBG+GAR2(I,IGR)*GAF2(I) + AGBH=AGBH+GAR2(I,IGR)*GAF3(I) + AHBE=AHBE+GAR3(I,IGR)*GAF1(I) + AHBG=AHBG+GAR3(I,IGR)*GAF2(I) + AHBH=AHBH+GAR3(I,IGR)*GAF3(I) + 200 CONTINUE + 205 CONTINUE +* + 210 N=N+1 + IF(N.GT.10) GO TO 215 +* COMPUTE X(M+1) + X=BEBE+ALP*ALP*BGBG+BET*BET*BHBH+2.0D0*(ALP*BEBG+BET*BEBH + 1 +ALP*BET*BGBH) + DXDA=2.0D0*(BEBG+ALP*BGBG+BET*BGBH) + DXDB=2.0D0*(BEBH+ALP*BGBH+BET*BHBH) +* COMPUTE Y(M+1) + Y=AEAE+ALP*ALP*AGAG+BET*BET*AHAH+2.0D0*(ALP*AEAG+BET*AEAH + 1 +ALP*BET*AGAH) + DYDA=2.0D0*(AEAG+ALP*AGAG+BET*AGAH) + DYDB=2.0D0*(AEAH+ALP*AGAH+BET*AHAH) +* COMPUTE Z(M+1) + Z=AEBE+ALP*ALP*AGBG+BET*BET*AHBH+ALP*(AEBG+AGBE) + 1 +BET*(AEBH+AHBE)+ALP*BET*(AGBH+AHBG) + DZDA=AEBG+AGBE+2.0D0*ALP*AGBG+BET*(AGBH+AHBG) + DZDB=AEBH+AHBE+ALP*(AGBH+AHBG)+2.0D0*BET*AHBH +* COMPUTE F(M+1) + F=X*Y-Z*Z + D2F(1,1)=2.0D0*(BGBG*Y+DXDA*DYDA+X*AGAG-DZDA**2-2.0D0*Z*AGBG) + D2F(1,2)=2.0D0*BGBH*Y+DXDA*DYDB+DXDB*DYDA+2.0D0*X*AGAH + 1 -2.0D0*DZDA*DZDB-2.0D0*Z*(AGBH+AHBG) + D2F(2,2)=2.0D0*(BHBH*Y+DXDB*DYDB+X*AHAH-DZDB**2-2.0D0*Z*AHBH) + D2F(2,1)=D2F(1,2) + D2F(1,3)=DXDA*Y+X*DYDA-2.0D0*Z*DZDA + D2F(2,3)=DXDB*Y+X*DYDB-2.0D0*Z*DZDB +* SOLUTION OF A LINEAR SYSTEM. + CALL ALSBD(2,1,D2F,IER,2) + IF(IER.NE.0) GO TO 215 + ALP=ALP-D2F(1,3) + BET=BET-D2F(2,3) + IF(ALP.GT.100.0) GO TO 215 + IF((ABS(D2F(1,3)).LE.1.0D-4).AND.(ABS(D2F(2,3)).LE.1.0D-4)) + 1 GO TO 220 + GO TO 210 +* +* alternative algorithm in case of Newton-Raphton failure + 215 IF(IMPX.GT.0) WRITE(6,'(/30H FLDADJ: FAILURE OF THE NEWTON, + 1 55H-RAPHTON ALGORIHTHM FOR COMPUTING THE OVERRELAXATION PA, + 2 9HRAMETERS.)') + IAMIN=999 + IBMIN=999 + FMIN=HUGE(FMIN) + DO IA=1,SIZE(ALP_TAB) + ALP=ALP_TAB(IA) + DO IB=1,SIZE(BET_TAB) + BET=BET_TAB(IB) +* COMPUTE X + X=BEBE+ALP*ALP*BGBG+BET*BET*BHBH+2.0D0*(ALP*BEBG+BET*BEBH + 1 +ALP*BET*BGBH) +* COMPUTE Y + Y=AEAE+ALP*ALP*AGAG+BET*BET*AHAH+2.0D0*(ALP*AEAG+BET*AEAH + 1 +ALP*BET*AGAH) +* COMPUTE Z + Z=AEBE+ALP*ALP*AGBG+BET*BET*AHBH+ALP*(AEBG+AGBE) + 1 +BET*(AEBH+AHBE)+ALP*BET*(AGBH+AHBG) +* COMPUTE F + F=X*Y-Z*Z + IF(F.LT.FMIN) THEN + IAMIN=IA + IBMIN=IB + FMIN=F + ENDIF + ENDDO + ENDDO + ALP=ALP_TAB(IAMIN) + BET=BET_TAB(IBMIN) + 220 BET=BET/ALP + IF((ALP.LT.1.0D0).AND.(ALP.GT.0.0D0)) THEN + ALP=1.0D0 + BET=0.0D0 + ELSE IF(ALP.LE.0.0D0) THEN + ISTART=M+1 + ALP=1.0D0 + BET=0.0D0 + ENDIF + DO 235 IGR=1,NGRP + DO 230 I=1,LL4 + GRAD1(I,IGR)=REAL(ALP)*(GRAD1(I,IGR)+REAL(BET)*GRAD2(I,IGR)) + GAR2(I,IGR)=REAL(ALP)*(GAR2(I,IGR)+REAL(BET)*GAR3(I,IGR)) + 230 CONTINUE + 235 CONTINUE + ENDIF + CALL KDRCPU(TK2) + TKB=TKB+(TK2-TK1) +* + LOGTES=(M.LT.ICL1).OR.(MOD(M-ISTART,ICL1+ICL2).EQ.ICL1-1) + IF(LOGTES.AND.(DELS.LE.EPS1))THEN + DELT=0.0 + DO 290 IGR=1,NGRP + GAF1(:LL4)=0.0 + GAF2(:LL4)=0.0 + DO 250 JGR=1,NGRP + WRITE(TEXT12,'(1HB,2I3.3)') JGR,IGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 250 + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ ILONG /)) + DO 240 I=1,ILONG + GAF1(I)=GAF1(I)+AGAR(I)*ADECT(I,JGR) + GAF2(I)=GAF2(I)+AGAR(I)*GRAD1(I,JGR) + 240 CONTINUE + 250 CONTINUE + DELN=0.0 + DELD=0.0 + DO 280 I=1,LL4 + ADECT(I,IGR)=ADECT(I,IGR)+GRAD1(I,IGR) + GAR1(I,IGR)=GAR1(I,IGR)+GAR2(I,IGR) + GRAD2(I,IGR)=GRAD1(I,IGR) + GAR3(I,IGR)=GAR2(I,IGR) + DELN=MAX(DELN,ABS(GAF2(I))) + DELD=MAX(DELD,ABS(GAF1(I))) + 280 CONTINUE + IF(DELD.NE.0.0) DELT=MAX(DELT,DELN/DELD) + 290 CONTINUE + IF(IMPX.GE.2) WRITE (6,615) M,AEAE,AEAG,AEAH,AGAG,AGAH,AHAH, + 1 BEBE,ALP,BET,EVAL,F,DELS,DELT,N,BEBG,BEBH,BGBG,BGBH,BHBH,AEBE, + 2 AEBG,AEBH,AGBE,AGBG,AGBH,AHBE,AHBG,AHBH + IF(DELT.LE.EPS2) GO TO 310 + ELSE + DO 305 IGR=1,NGRP + DO 300 I=1,LL4 + ADECT(I,IGR)=ADECT(I,IGR)+GRAD1(I,IGR) + GAR1(I,IGR)=GAR1(I,IGR)+GAR2(I,IGR) + GRAD2(I,IGR)=GRAD1(I,IGR) + GAR3(I,IGR)=GAR2(I,IGR) + 300 CONTINUE + 305 CONTINUE + IF(IMPX.GE.2) WRITE (6,620) M,AEAE,AEAG,AEAH,AGAG,AGAH,AHAH, + 1 BEBE,ALP,BET,EVAL,F,DELS,N,BEBG,BEBH,BGBG,BGBH,BHBH,AEBE, + 2 AEBG,AEBH,AGBE,AGBG,AGBH,AHBE,AHBG,AHBH + ENDIF + IF(M.EQ.1) TEST=DELS + IF((M.GT.5).AND.(DELS.GT.TEST)) CALL XABORT('FLDADJ: CONVERGENCE' + 1 //' FAILURE.') + IF(M.GE.MAXOUT) THEN + WRITE (6,690) + GO TO 310 + ENDIF + IF(MOD(M,36).EQ.0) THEN + ISTART=M+1 + NNADI=NNADI+1 + IF(IMPX.GE.1) WRITE (6,700) NNADI + ENDIF + GO TO 40 +*---- +* SOLUTION EDITION +*---- + 310 FKEFF=REAL(1.0D0/EVAL) + IF(IMPX.EQ.1) WRITE (6,640) M + IF(IMPX.GE.1) THEN + WRITE (6,650) TKT,TKB,TKT+TKB + WRITE (6,670) FKEFF + ENDIF + IF(IMPX.EQ.3) THEN + DO 320 IGR=1,NGRP + WRITE (6,680) IGR,(ADECT(I,IGR),I=1,LL4) + 320 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(GRAD1,GRAD2,GAR1,GAR2,GAR3,GAF1,GAF2,GAF3) + RETURN +* + 600 FORMAT(1H1/50H FLDADJ: ITERATIVE PROCEDURE BASED ON PRECONDITION, + 1 17HED POWER METHOD (,I2,37H ADI ITERATIONS PER OUTER ITERATION)./ + 2 9X,17HADJOINT EQUATION.) + 610 FORMAT(//5X,17HBILINEAR PRODUCTS,48X,5HALPHA,3X,4HBETA,3X, + 1 12HEIGENVALUE..,12X,8HACCURACY,11(1H.),2X,1HN) + 615 FORMAT(1X,I3,1P,7E9.1,0P,2F8.3,E14.6,3E10.2,I4/(4X,1P,7E9.1)) + 620 FORMAT(1X,I3,1P,7E9.1,0P,2F8.3,E14.6,2E10.2,10X,I4/(4X,1P,7E9.1)) + 640 FORMAT(/23H FLDADJ: CONVERGENCE IN,I4,12H ITERATIONS.) + 650 FORMAT(/53H FLDADJ: CPU TIME USED TO SOLVE THE TRIANGULAR LINEAR, + 1 10H SYSTEMS =,F10.3/23X,34HTO COMPUTE THE BILINEAR PRODUCTS =, + 2 F10.3,20X,16HTOTAL CPU TIME =,F10.3) + 670 FORMAT(//42H FLDADJ: EFFECTIVE MULTIPLICATION FACTOR =,1P,E17.10/) + 680 FORMAT(//53H FLDADJ: ADJOINT EIGENVECTOR CORRESPONDING TO THE GRO, + 1 2HUP,I4//(5X,1P,8E14.5)) + 690 FORMAT(/53H FLDADJ: ***WARNING*** THE MAXIMUM NUMBER OF OUTER IT, + 1 20HERATIONS IS REACHED.) + 700 FORMAT(/53H FLDADJ: INCREASING THE NUMBER OF INNER ITERATIONS TO, + 1 I3,36H ADI ITERATIONS PER OUTER ITERATION./) + END diff --git a/Trivac/src/FLDARN.f b/Trivac/src/FLDARN.f new file mode 100755 index 0000000..471e250 --- /dev/null +++ b/Trivac/src/FLDARN.f @@ -0,0 +1,184 @@ +*DECK FLDARN + SUBROUTINE FLDARN (FLDATV,IPTRK,IPSYS,IPFLUX,LL4,NUN,NGRP,LMOD, + 1 IBLSZ,ADJ,IMPX,EPSOUT,MAXOUT,EVECT,FKEFFV) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solution of a multigroup eigenvalue system for the calculation of the +* LMOD first orthogonal harmonics of the diffusion or SPN equation. +* Use the implicit restarted Arnoldi method (IRAM). +* +*Copyright: +* Copyright (C) 2020 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* FLDATV function pointer for the multiplication of A^(-1)B times the +* harmonic flux +* IPTRK L_TRACK pointer to the BIVAC tracking information. +* IPSYS L_SYSTEM pointer to system matrices. +* IPFLUX L_FLUX pointer to the solution. +* LL4 order of the system matrices. +* NUN number of unknowns in each energy group. +* NGRP number of energy groups. +* LMOD number of orthogonal harmonics to compute. +* IBLSZ block size of the Arnoldi Hessenberg matrix. +* ADJ adjoint calculation flag. +* IMPX print parameter: =0: no print; =1: minimum printing. +* EPSOUT convergence criteria for the flux. +* MAXOUT maximum number of outer iterations. +* EVECT initial estimate of the unknown vector. +* +*Parameters: output +* EVECT converged unknown vector. +* FKEFFV effective multiplication factor of each harmonic. +* +*Reference: +* J. BAGLAMA, "Augmented Block Householder Arnoldi Method," +* Linear Algebra Appl., 429, Issue 10, 2315-2334 (2008). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPSYS,IPFLUX + INTEGER LL4,NUN,NGRP,LMOD,IBLSZ,IMPX,MAXOUT + LOGICAL ADJ + REAL EPSOUT + COMPLEX EVECT(NUN,NGRP,LMOD),FKEFFV(LMOD) +*---- +* LOCAL VARIABLES +*---- + INTERFACE + FUNCTION FLDATV(F,N,IBLSZ,ITER,IPTRK,IPSYS,IPFLUX) RESULT(X) + USE GANLIB + INTEGER, INTENT(IN) :: N,IBLSZ,ITER + REAL(KIND=8), DIMENSION(N,IBLSZ), INTENT(IN) :: F + REAL(KIND=8), DIMENSION(N,IBLSZ) :: X + TYPE(C_PTR) IPTRK,IPSYS,IPFLUX + END FUNCTION FLDATV + END INTERFACE + REAL TIME(2) + REAL(KIND=8) DEPSOUT + CHARACTER(LEN=8) TEXT8 + TYPE(C_PTR) JPFLUX,KPFLUX,MPFLUX +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: GAR + COMPLEX(KIND=8), ALLOCATABLE, DIMENSION(:,:) :: V, D +*---- +* SCRATCH STORAGE ALLOCATION +*---- + N=LL4*NGRP + ALLOCATE(V(N,LMOD),D(LMOD,LMOD),GAR(NUN)) +*---- +* SET TIMER +*---- +* TIME(1) : CPU TIME FOR THE SOLUTION OF LINEAR SYSTEMS. +* TIME(2) : CPU TIME FOR BILINEAR PRODUCT EVALUATIONS. + TIME(1)=0.0 + TIME(2)=0.0 + CALL LCMPUT(IPFLUX,'CPU-TIME',2,2,TIME) +*---- +* FLUX INITIALIZATION +*---- + DO IMOD=1,LMOD + V(:N,IMOD)=1.0D0 + V(1:MIN(IBLSZ,IMOD)-1,IMOD)=0.0D0 + ENDDO + CALL LCMLEN(IPFLUX,'MODE',ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + DO IMOD=1,LMOD + JPFLUX=LCMGID(IPFLUX,'MODE') + CALL LCMLEL(JPFLUX,IMOD,ILONG,ITYLCM) + IF(ILONG.EQ.0) CYCLE + KPFLUX=LCMGIL(JPFLUX,IMOD) + IF(ADJ) THEN + CALL LCMLEN(KPFLUX,'AFLUX',LENA,ITYLCM) + IF(LENA.EQ.0) CYCLE + MPFLUX=LCMGID(KPFLUX,'AFLUX') + DO IGR=1,NGRP + IF(ITYLCM.EQ.2) THEN + CALL LCMGDL(MPFLUX,IGR,GAR) + EVECT(:NUN,IGR,IMOD)=GAR(:NUN) + ELSE IF(ITYLCM.EQ.6) THEN + CALL LCMGDL(MPFLUX,IGR,EVECT(1,IGR,IMOD)) + ENDIF + ENDDO + ELSE + CALL LCMLEN(KPFLUX,'FLUX',LEND,ITYLCM) + IF(LEND.EQ.0) CYCLE + MPFLUX=LCMGID(KPFLUX,'FLUX') + DO IGR=1,NGRP + IF(ITYLCM.EQ.2) THEN + CALL LCMGDL(MPFLUX,IGR,GAR) + EVECT(:NUN,IGR,IMOD)=GAR(:NUN) + ELSE IF(ITYLCM.EQ.6) THEN + CALL LCMGDL(MPFLUX,IGR,EVECT(1,IGR,IMOD)) + ENDIF + ENDDO + ENDIF + DO IGR=1,NGRP + DO IUN=1,LL4 + IOF=(IGR-1)*LL4+IUN + V(IOF,IMOD)=EVECT(IUN,IGR,IMOD) + ENDDO + ENDDO + ENDDO + ENDIF +*---- +* CALL IRAM SOLVER +*---- + DEPSOUT=EPSOUT + CALL ALBEIGS(FLDATV,N,IBLSZ,LMOD,MAXOUT,DEPSOUT,IMPX,ITER,V,D, + 1 IPTRK,IPSYS,IPFLUX) + DO IMOD=1,LMOD + FKEFFV(IMOD)=CMPLX(D(IMOD,IMOD),KIND=4) + DO IGR=1,NGRP + DO IUN=1,LL4 + IOF=(IGR-1)*LL4+IUN + EVECT(IUN,IGR,IMOD)=CMPLX(V(IOF,IMOD),KIND=4) + ENDDO + ENDDO + ENDDO +*---- +* PRINTOUTS +*---- + IF(IMPX.GE.1) THEN + CALL LCMGET(IPFLUX,'CPU-TIME',TIME) + WRITE (6,650) ITER,TIME(1),TIME(2),TIME(1)+TIME(2) + WRITE (6,670) (FKEFFV(IMOD),IMOD=1,LMOD) + ENDIF + IF(IMPX.GE.3) THEN + TEXT8=' DIRECT' + IF(ADJ) TEXT8=' ADJOINT' + DO IMOD=1,LMOD + WRITE (6,'(/A8,13H HARMONIC NB.,I3/)') TEXT8,IMOD + DO IGR=1,NGRP + WRITE (6,680) IGR,(REAL(EVECT(I,IGR,IMOD)),I=1,LL4) + ENDDO + ENDDO + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(GAR,D,V) + RETURN +* + 650 FORMAT(/31H FLDARN: CONVERGENCE OF IRAM IN,I5,11H ITERATIONS/ + 1 9X,54HCPU TIME USED TO SOLVE THE TRIANGULAR LINEAR SYSTEMS =, + 2 F10.3/23X,34HTO COMPUTE THE BILINEAR PRODUCTS =,F10.3,20X, + 3 16HTOTAL CPU TIME =,F10.3) + 670 FORMAT(//21H FLDARN: EIGENVALUES:/(5X,1P,E17.10,3H + ,E17.10,1Hi)) + 680 FORMAT(43H FLDARN: EIGENVECTOR CORRESPONDING TO GROUP,I4// + 1 (5X,1P,8E14.5)) + END diff --git a/Trivac/src/FLDBH1.f b/Trivac/src/FLDBH1.f new file mode 100755 index 0000000..aea864f --- /dev/null +++ b/Trivac/src/FLDBH1.f @@ -0,0 +1,55 @@ +*DECK FLDBH1 + SUBROUTINE FLDBH1 (NEL,NUN,LL4,EVECT,VOL,IDL,KN,QFR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of the averaged flux with a mesh centered finite +* difference method in hexagonal geometry with triangular +* mesh-splitting. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NEL number of hexagons. +* NUN number of unknowns per energy group. +* LL4 order of the system matrices. +* EVECT variational coefficients of the flux. The information is +* contained in position EVECT(1) to EVECT(LL4). +* VOL volume of each element. +* IDL position of the average flux component associated with each +* volume. +* KN element-ordered unknown list. +* QFR element-ordered information. +* +*Parameters: output +* EVECT averaged fluxes. The information is contained in positions +* EVECT(IDL(I)). +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NEL,NUN,LL4,IDL(NEL),KN(4*LL4) + REAL EVECT(NUN),VOL(NEL),QFR(4*LL4) +* + NSURF=3 + DO 10 K=1,NEL + IF(IDL(K).NE.0) EVECT(IDL(K))=0.0 + 10 CONTINUE + NUM1=0 + DO 20 IND1=1,LL4 + K=KN(NUM1+NSURF+1) + EVECT(IDL(K))=EVECT(IDL(K))+QFR(NUM1+NSURF+1)*EVECT(IND1)/VOL(K) + NUM1=NUM1+NSURF+1 + 20 CONTINUE + RETURN + END diff --git a/Trivac/src/FLDBH2.f b/Trivac/src/FLDBH2.f new file mode 100755 index 0000000..7dd7db4 --- /dev/null +++ b/Trivac/src/FLDBH2.f @@ -0,0 +1,95 @@ +*DECK FLDBH2 + SUBROUTINE FLDBH2 (ISPLH,NEL,NUN,NELEM,EVECT,VOL,IDL,KN,QFR,RH,RT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of the averaged flux with a linear Lagrangian finite +* element or mesh corner finite difference method in hexagonal geometry. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* ISPLH type of hexagonal mesh-splitting: =1 for complete hexagons; +* >1 for triangular mesh-splitting. +* NEL number of hexagons. +* NUN number of unknowns per energy group. +* NELEM number of finite elements (hexagons or triangles) excluding +* the virtual elements. +* EVECT variational coefficients of the flux. The information is +* contained in position EVECT(1) to EVECT(LL4) where LL4 is the +* order of the system matrices. +* VOL volume of each hexagon. +* IDL position of the average flux component associated with each +* hexagon. +* KN element-ordered unknown list. The dimension of KN is equal +* to (LC+1)*NELEM where LC=6 (hexagons) or 3 (triangles). +* QFR element-ordered albedo information. The dimension of QFR is +* equal to (LC+1)*NELEM. +* RH unit matrix +* RT unit matrix +* +*Parameters: output +* EVECT averaged fluxes. The information is contained in positions +* EVECT(IDL(I)). +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER ISPLH,NEL,NUN,NELEM,IDL(NEL),KN(*) + REAL EVECT(NUN),VOL(NEL),QFR(*),RH(6,6),RT(3,3) +*---- +* LOCAL VARIABLES +*---- + REAL T(6) +*---- +* COMPUTE THE LINEAR PRODUCT VECTOR T +*---- + IF(ISPLH.EQ.1) THEN +* HEXAGONAL BASIS. + LC=6 + DO 15 I=1,6 + T(I)=0.0 + DO 10 J=1,6 + T(I)=T(I)+RH(I,J) + 10 CONTINUE + 15 CONTINUE + CONST=1.5*SQRT(3.0) + ELSE +* TRIANGULAR BASIS. + LC=3 + DO 25 I=1,3 + T(I)=0.0 + DO 20 J=1,3 + T(I)=T(I)+RT(I,J) + 20 CONTINUE + 25 CONTINUE + CONST=0.25*SQRT(3.0) + ENDIF +* + DO 30 KHEX=1,NEL + IF(IDL(KHEX).NE.0) EVECT(IDL(KHEX))=0.0 + 30 CONTINUE + NUM1=0 + DO 60 K=1,NELEM + KHEX=KN(NUM1+LC+1) + IF(VOL(KHEX).EQ.0.0) GO TO 50 + DO 40 I=1,LC + IND1=KN(NUM1+I) + IF(IND1.EQ.0) GO TO 40 + SS=T(I)*QFR(NUM1+LC+1)/(CONST*VOL(KHEX)) + EVECT(IDL(KHEX))=EVECT(IDL(KHEX))+SS*EVECT(IND1) + 40 CONTINUE + 50 NUM1=NUM1+LC+1 + 60 CONTINUE + RETURN + END diff --git a/Trivac/src/FLDBHR.f b/Trivac/src/FLDBHR.f new file mode 100755 index 0000000..b04b8ce --- /dev/null +++ b/Trivac/src/FLDBHR.f @@ -0,0 +1,225 @@ +*DECK FLDBHR + SUBROUTINE FLDBHR(IPTRK,IPSYS,LADJ,LL4,ITY,NUN,NGRP,ICL1,ICL2, + 1 IMPX,NADI,MAXINR,EPSINR,ITER,TKT,TKB,GRAD1) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform thermal (up-scattering) iterations in Bivac. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK L_TRACK pointer to the tracking information. +* IPSYS L_SYSTEM pointer to system matrices. +* LADJ flag set to .TRUE. for adjoint solution acceleration. +* LL4 order of the system matrices. +* ITY type of solution (2: classical Bivac; 3: Thomas-Raviart). +* NUN number of unknowns in each energy group. +* NGRP number of energy groups. +* ICL1 number of free iretations in one cycle of the up-scattering +* iterations. +* ICL2 number of accelerated up-scattering iterations in one cycle. +* IMPX print parameter (set to 0 for no printing). +* NADI number of inner ADI iterations per outer iteration (used with +* SPN approximations). +* MAXINR maximum number of thermal iterations. +* EPSINR thermal iteration epsilon. +* +*Parameters: input/output +* ITER actual number of thermal iterations. +* TKT CPU time spent to compute the solution of linear systems. +* TKB CPU time spent to compute the bilinear products. +* GRAD1 delta flux for this outer iteration. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPSYS + INTEGER LL4,ITY,NUN,NGRP,ICL1,ICL2,IMPX,NADI,MAXINR,ITER + REAL EPSINR,TKT,TKB,GRAD1(NUN,NGRP) + LOGICAL LADJ +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + INTEGER ISTATE(NSTATE) + CHARACTER TEXT12*12,TEXT3*3 +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, DIMENSION(:), ALLOCATABLE :: WORK2 + REAL, DIMENSION(:,:), ALLOCATABLE :: GAR2 + REAL, DIMENSION(:,:,:), ALLOCATABLE :: WORK +*---- +* SCRATCH STORAGE ALLOCATION +*---- + IF(MAXINR.EQ.0) RETURN + ALLOCATE(GAR2(NUN,NGRP),WORK(LL4,NGRP,3),WORK2(LL4)) +* + CALL LCMGET(IPSYS,'STATE-VECTOR',ISTATE) + NAN=ISTATE(8) + NCTOT=ICL1+ICL2 + IF(ICL2.EQ.0) THEN + NCPTM=NCTOT+1 + ELSE + NCPTM=ICL1 + ENDIF + DO 15 IGR=1,NGRP + DO 10 I=1,LL4 + WORK(I,IGR,1)=0.0 + WORK(I,IGR,2)=0.0 + WORK(I,IGR,3)=GRAD1(I,IGR) + 10 CONTINUE + 15 CONTINUE + IGDEB=1 +*---- +* PERFORM THERMAL (UP-SCATTERING) ITERATIONS +*---- + TEXT3='NO ' + ITER=2 + DO + CALL KDRCPU(TK1) + IF(LADJ) THEN +* ADJOINT SOLUTION + DO 35 IGR=IGDEB,NGRP + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,WORK(1,IGR,3), + 1 GAR2(1,IGR)) + DO 30 JGR=1,NGRP + IF(JGR.EQ.IGR) GO TO 30 + WRITE(TEXT12,'(1HA,2I3.3)') JGR,IGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 30 + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,WORK(1,JGR,3),WORK2(1)) + DO 20 I=1,LL4 + GAR2(I,IGR)=GAR2(I,IGR)-WORK2(I) + 20 CONTINUE + 30 CONTINUE + 35 CONTINUE + DO 65 IGR=NGRP,IGDEB,-1 + DO 50 JGR=NGRP,IGR+1,-1 + WRITE(TEXT12,'(1HA,2I3.3)') JGR,IGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 50 + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,GAR2(1,JGR),WORK2(1)) + DO 40 I=1,LL4 + GAR2(I,IGR)=GAR2(I,IGR)+WORK2(I) + 40 CONTINUE + 50 CONTINUE + CALL KDRCPU(TK2) + TKB=TKB+(TK2-TK1) +* + CALL KDRCPU(TK1) + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + IF(ITY.EQ.11) THEN +* SIMPLIFIED PN BIVAC TRACKING. + IF(NAN.EQ.0) CALL XABORT('FLDBHR: SPN-ONLY ALGORITHM.') + CALL FLDBSS(TEXT12,IPTRK,IPSYS,LL4,NBMIX,NAN,GAR2(1,IGR), + 1 NADI) + ELSE + CALL MTLDLS(TEXT12,IPTRK,IPSYS,LL4,ITY,GAR2(1,IGR)) + ENDIF + DO 60 I=1,LL4 + WORK(I,IGR,1)=WORK(I,IGR,2) + WORK(I,IGR,2)=WORK(I,IGR,3) + WORK(I,IGR,3)=GRAD1(I,IGR)+(WORK(I,IGR,2)-GAR2(I,IGR)) + 60 CONTINUE + 65 CONTINUE + ELSE +* DIRECT SOLUTION + DO 85 IGR=IGDEB,NGRP + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,WORK(1,IGR,3), + 1 GAR2(1,IGR)) + DO 80 JGR=1,NGRP + IF(JGR.EQ.IGR) GO TO 80 + WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 80 + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,WORK(1,JGR,3),WORK2(1)) + DO 70 I=1,LL4 + GAR2(I,IGR)=GAR2(I,IGR)-WORK2(I) + 70 CONTINUE + 80 CONTINUE + 85 CONTINUE + DO 115 IGR=IGDEB,NGRP + DO 100 JGR=1,IGR-1 + WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 100 + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,GAR2(1,JGR),WORK2(1)) + DO 90 I=1,LL4 + GAR2(I,IGR)=GAR2(I,IGR)+WORK2(I) + 90 CONTINUE + 100 CONTINUE + CALL KDRCPU(TK2) + TKB=TKB+(TK2-TK1) +* + CALL KDRCPU(TK1) + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + IF(ITY.EQ.11) THEN +* SIMPLIFIED PN BIVAC TRACKING. + IF(NAN.EQ.0) CALL XABORT('FLDBHR: SPN-ONLY ALGORITHM.') + CALL FLDBSS(TEXT12,IPTRK,IPSYS,LL4,NBMIX,NAN,GAR2(1,IGR), + 1 NADI) + ELSE + CALL MTLDLS(TEXT12,IPTRK,IPSYS,LL4,ITY,GAR2(1,IGR)) + ENDIF + DO 110 I=1,LL4 + WORK(I,IGR,1)=WORK(I,IGR,2) + WORK(I,IGR,2)=WORK(I,IGR,3) + WORK(I,IGR,3)=GRAD1(I,IGR)+(WORK(I,IGR,2)-GAR2(I,IGR)) + 110 CONTINUE + 115 CONTINUE + ENDIF + IF(MOD(ITER-2,NCTOT).GE.NCPTM) THEN + CALL FLD2AC(NGRP,LL4,IGDEB,WORK,ZMU) + ELSE + ZMU=1.0 + ENDIF + IGDEBO=IGDEB + DO 130 IGR=IGDEBO,NGRP + GINN=0.0 + FINN=0.0 + DO 120 I=1,LL4 + GINN=MAX(GINN,ABS(WORK(I,IGR,2)-WORK(I,IGR,3))) + FINN=MAX(FINN,ABS(WORK(I,IGR,3))) + 120 CONTINUE + GINN=GINN/FINN + IF((GINN.LT.EPSINR).AND.(IGDEB.EQ.IGR)) IGDEB=IGDEB+1 + 130 CONTINUE + CALL KDRCPU(TK2) + TKT=TKT+(TK2-TK1) + IF(GINN.LT.EPSINR) TEXT3='YES' + IF(IMPX.GT.2) WRITE(6,1000) ITER,GINN,EPSINR,IGDEB,ZMU,TEXT3 + IF((GINN.LT.EPSINR).OR.(ITER.EQ.MAXINR)) GO TO 160 + ITER=ITER+1 + ENDDO +*---- +* END OF THERMAL ITERATIONS +*---- + 160 DO 175 I=1,LL4 + DO 170 IGR=1,NGRP + GRAD1(I,IGR)=WORK(I,IGR,3) + 170 CONTINUE + 175 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(GAR2,WORK,WORK2) + RETURN +* + 1000 FORMAT (10X,3HIN(,I3,6H) FLX:,5H PRC=,1P,E9.2,5H TAR=,E9.2, + 1 7H IGDEB=, I13,6H ACCE=,0P,F12.5,12H CONVERGED=,A3) + END diff --git a/Trivac/src/FLDBIV.f b/Trivac/src/FLDBIV.f new file mode 100755 index 0000000..c2d5205 --- /dev/null +++ b/Trivac/src/FLDBIV.f @@ -0,0 +1,111 @@ +*DECK FLDBIV + SUBROUTINE FLDBIV(IPTRK,NEL,NUN,EVECT,MAT,VOL,IDL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of the averaged flux in BIVAC. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK L_TRACK pointer to the BIVAC tracking information. +* NEL total number of finite elements. +* NUN total number of unknown per energy group. +* EVECT variational coefficients of the flux. The information is +* contained in position EVECT(1) to EVECT(LL4) where LL4 is +* the order of the system matrices. +* MAT mixture index assigned to each element. +* VOL volume of each element. +* IDL position of the average flux component associated with each +* volume. +* +*Parameters: output +* EVECT averaged fluxes. The information is contained in positions +* EVECT(IDL(I)). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK + INTEGER NEL,NUN,MAT(NEL),IDL(NEL) + REAL EVECT(NUN),VOL(NEL) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + LOGICAL CYLIND + INTEGER ITP(NSTATE) + INTEGER, DIMENSION(:), ALLOCATABLE :: KN + REAL, DIMENSION(:), ALLOCATABLE :: XX,DD,T,TS,QFR + REAL, DIMENSION(:,:), ALLOCATABLE :: RH,RT +*---- +* RECOVER BIVAC SPECIFIC TRACKING INFORMATION +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',ITP) + ITYPE=ITP(6) + CYLIND=(ITYPE.EQ.3).OR.(ITYPE.EQ.6) + IELEM=ITP(8) + ICOL=ITP(9) + ISPLH=ITP(10) + LL4=ITP(11) + LX=ITP(12) + LY=ITP(13) + CALL LCMLEN(IPTRK,'KN',MAXKN,ITYLCM) + ALLOCATE(KN(MAXKN)) + CALL LCMGET(IPTRK,'KN',KN) +* + IF((IELEM.LT.0).AND.(ITYPE.NE.8)) THEN +* LAGRANGIAN FINITE ELEMENTS. + ALLOCATE(XX(LX*LY),DD(LX*LY)) + CALL LCMGET(IPTRK,'XX',XX) + CALL LCMGET(IPTRK,'DD',DD) + CALL LCMSIX(IPTRK,'BIVCOL',1) + CALL LCMLEN(IPTRK,'T',LC,ITYLCM) + ALLOCATE(T(LC),TS(LC)) + CALL LCMGET(IPTRK,'T',T) + CALL LCMGET(IPTRK,'TS',TS) + CALL LCMSIX(IPTRK,' ',2) + CALL FLDBN2(NEL,LL4,-IELEM,CYLIND,EVECT,XX,DD,MAT,VOL,IDL,KN, + 1 LC,T,TS) + DEALLOCATE(TS,T,DD,XX) + ELSE IF((IELEM.LT.0).AND.(ITYPE.EQ.8)) THEN +* MESH CORNER FINITE DIFFERENCES IN HEXAGONAL GEOMETRY. + CALL LCMSIX(IPTRK,'BIVCOL',1) + ALLOCATE(RH(6,6),RT(3,3)) + CALL LCMGET(IPTRK,'RH',RH) + CALL LCMGET(IPTRK,'RT',RT) + CALL LCMSIX(IPTRK,' ',2) + IF(ISPLH.EQ.1) THEN + NELEM=MAXKN/7 + ELSE + NELEM=MAXKN/4 + ENDIF + ALLOCATE(QFR(MAXKN)) + CALL LCMGET(IPTRK,'QFR',QFR) + CALL FLDBH2(ISPLH,NEL,NUN,NELEM,EVECT,VOL,IDL,KN,QFR,RH,RT) + DEALLOCATE(QFR,RT,RH) + ELSE IF((IELEM.GT.0).AND.(ITYPE.EQ.8).AND.(ICOL.EQ.4).AND. + 1 (ISPLH.GT.1)) THEN +* MESH CENTERED FINITE DIFFERENCES IN HEXAGONAL GEOMETRY. + ALLOCATE(QFR(MAXKN)) + CALL LCMGET(IPTRK,'QFR',QFR) + CALL FLDBH1(NEL,NUN,LL4,EVECT,VOL,IDL,KN,QFR) + DEALLOCATE(QFR) + ENDIF +*---- +* RELEASE BIVAC SPECIFIC TRACKING INFORMATION +*---- + DEALLOCATE(KN) + RETURN + END diff --git a/Trivac/src/FLDBMX.f b/Trivac/src/FLDBMX.f new file mode 100755 index 0000000..8aaa075 --- /dev/null +++ b/Trivac/src/FLDBMX.f @@ -0,0 +1,192 @@ +*DECK FLDBMX + FUNCTION FLDBMX(F,N,IBLSZ,ITER,IPTRK,IPSYS,IPFLUX) RESULT(X) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Multiplication of A^(-1)B times the harmonic flux in BIVAC. +* +*Copyright: +* Copyright (C) 2020 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* F harmonic flux vector. +* N number of unknowns in one harmonic. +* IBLSZ block size of the Arnoldi Hessenberg matrix. +* ITER Arnoldi iteration index. +* IPTRK L_TRACK pointer to the tracking information. +* IPSYS L_SYSTEM pointer to system matrices. +* IPFLUX L_FLUX pointer to the solution. +* +*Parameters: output +* X result of the multiplication. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER, INTENT(IN) :: N,IBLSZ,ITER + COMPLEX(KIND=8), DIMENSION(N,IBLSZ), INTENT(IN) :: F + COMPLEX(KIND=8), DIMENSION(N,IBLSZ) :: X + TYPE(C_PTR) IPTRK,IPSYS,IPFLUX +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + INTEGER ISTATE(NSTATE) + REAL EPSCON(5),TIME(2) + CHARACTER TEXT12*12,HSMG*131 + LOGICAL LUPS +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, DIMENSION(:), ALLOCATABLE :: WORK1,WORK2 + REAL, DIMENSION(:,:), ALLOCATABLE :: GAF1,GRAD +* +* TIME(1) : CPU TIME FOR THE SOLUTION OF LINEAR SYSTEMS. +* TIME(2) : CPU TIME FOR BILINEAR PRODUCT EVALUATIONS. + CALL LCMGET(IPFLUX,'CPU-TIME',TIME) + CALL KDRCPU(TK1) +*---- +* RECOVER INFORMATION FROM IPTRK, IPSYS AND IPFLUX +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + NEL=ISTATE(1) + NUN=ISTATE(2) + NLF=ISTATE(14) + CALL LCMGET(IPSYS,'STATE-VECTOR',ISTATE) + NGRP=ISTATE(1) + LL4=ISTATE(2) + ITY=ISTATE(4) + NBMIX=ISTATE(7) + NAN=ISTATE(8) + IF(ITY.EQ.11) LL4=LL4*NLF/2 ! SPN cases + CALL LCMGET(IPFLUX,'STATE-VECTOR',ISTATE) + ICL1=ISTATE(8) + ICL2=ISTATE(9) + IREBAL=ISTATE(10) + MAXINR=ISTATE(11) + NADI=ISTATE(13) + IMPX=ISTATE(40) + CALL LCMGET(IPFLUX,'EPS-CONVERGE',EPSCON) + EPSINR=EPSCON(1) + IF(LL4*NGRP.NE.N) CALL XABORT('FLDBMX: INCONSISTENT UNKNOWNS.') +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(WORK1(NUN),WORK2(NUN),GAF1(NUN,NGRP),GRAD(NUN,NGRP)) +*---- +* CHECK FOR UP-SCATTERING. +*---- + LUPS=.FALSE. + DO 20 IGR=1,NGRP-1 + DO 10 JGR=IGR+1,NGRP + WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + LUPS=.TRUE. + MAXINR=MAX(MAXINR,10) + GO TO 30 + ENDIF + 10 CONTINUE + 20 CONTINUE +*---- +* MAIN LOOP OVER MODES. +*---- + 30 DO 150 IMOD=1,IBLSZ +*---- +* COMPUTE B TIMES THE FLUX. +*---- + DO 80 IGR=1,NGRP + DO 40 I=1,LL4 + GAF1(I,IGR)=0.0 + 40 CONTINUE + DO 70 JGR=1,NGRP + WRITE(TEXT12,'(1HB,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 70 + DO 50 I=1,LL4 + IOF=(JGR-1)*LL4+I + WORK1(I)=REAL(F(IOF,IMOD),KIND=4) + IF(ABS(AIMAG(F(IOF,IMOD))).GT.1.0E-8) THEN + WRITE(HSMG,'(13HFLDBMX: FLUX(,2I8,2H)=,1P,2E12.4, + 1 12H IS COMPLEX.)') IOF,IMOD,F(IOF,IMOD) + CALL XABORT(HSMG) + ENDIF + 50 CONTINUE + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,WORK1(1),WORK2(1)) + DO 60 I=1,LL4 + GAF1(I,IGR)=GAF1(I,IGR)+WORK2(I) + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + CALL KDRCPU(TK2) + TIME(2)=TIME(2)+(TK2-TK1) +*---- +* COMPUTE A^(-1)B WITHOUT UP-SCATTERING. +*---- + DO 120 IGR=1,NGRP + CALL KDRCPU(TK1) + DO 90 I=1,LL4 + GRAD(I,IGR)=GAF1(I,IGR) + 90 CONTINUE + DO 110 JGR=1,IGR-1 + WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 110 + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD(1,JGR),WORK2(1)) + DO 100 I=1,LL4 + GRAD(I,IGR)=GRAD(I,IGR)+WORK2(I) + 100 CONTINUE + 110 CONTINUE + CALL KDRCPU(TK2) + TIME(2)=TIME(2)+(TK2-TK1) +* + CALL KDRCPU(TK1) + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + IF(ITY.EQ.11) THEN +* SIMPLIFIED PN BIVAC TRACKING. + IF(NAN.EQ.0) CALL XABORT('FLDBMX: SPN-ONLY ALGORITHM.') + CALL FLDBSS(TEXT12,IPTRK,IPSYS,LL4,NBMIX,NAN,GRAD(1,IGR),NADI) + ELSE + CALL MTLDLS(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD(1,IGR)) + ENDIF + CALL KDRCPU(TK2) + TIME(1)=TIME(1)+(TK2-TK1) + 120 CONTINUE +*---- +* PERFORM THERMAL (UP-SCATTERING) ITERATIONS. +*---- + KTER=0 + IF((IREBAL.EQ.1).OR.LUPS) THEN + CALL FLDBHR(IPTRK,IPSYS,.FALSE.,LL4,ITY,NUN,NGRP,ICL1,ICL2,IMPX, + 1 MAXINR,EPSINR,KTER,TIME(1),TIME(2),GRAD) + ENDIF + DO 140 IGR=1,NGRP + DO 130 I=1,LL4 + IOF=(IGR-1)*LL4+I + X(IOF,IMOD)=GRAD(I,IGR) + 130 CONTINUE + 140 CONTINUE +*---- +* END OF LOOP OVER MODES. +*---- + 150 CONTINUE + CALL LCMPUT(IPFLUX,'CPU-TIME',2,2,TIME) + IF(IMPX.GT.10) WRITE(6,200) ITER,KTER +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(GRAD,GAF1,WORK2,WORK1) + RETURN + 200 FORMAT(49H FLDBMX: MATRIX MULTIPLICATION AT IRAM ITERATION=,I5, + 1 20H THERMAL ITERATIONS=,I5) + END FUNCTION FLDBMX diff --git a/Trivac/src/FLDBN2.f b/Trivac/src/FLDBN2.f new file mode 100755 index 0000000..073f5ba --- /dev/null +++ b/Trivac/src/FLDBN2.f @@ -0,0 +1,83 @@ +*DECK FLDBN2 + SUBROUTINE FLDBN2 (NEL,LL4,IELEM,CYLIND,EVECT,XX,DD,MAT,VOL,IDL, + 1 KN,LC,T,TS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of the averaged flux with a primal finite element method. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NEL total number of finite elements. +* LL4 order of the system matrices. +* IELEM degree of the Lagrangian finite elements: =1 (linear); +* =2 (parabolic); =3 (cubic); =4 (quartic). +* CYLIND cylindrical geometry flag (set with CYLIND=.true.). +* EVECT variational coefficients of the flux. The information is +* contained in position EVECT(1) to EVECT(LL4). +* XX X-side of each element. +* DD used with cylindrical geometry. +* MAT mixture index assigned to each element. +* VOL volume of each element. +* IDL position of the average flux component associated with each +* volume. +* KN element-ordered unknown list. +* LC order of the finite element basis. +* T linear product vector. +* TS linear product vector. +* +*Parameters: output +* EVECT averaged fluxes. The information is contained in positions +* EVECT(IDL(I)). +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NEL,LL4,IELEM,MAT(NEL),IDL(NEL),KN(NEL*IELEM*IELEM),LC + REAL EVECT(LL4+NEL),XX(NEL),DD(NEL),VOL(NEL),T(LC),TS(LC) + LOGICAL CYLIND +*---- +* LOCAL VARIABLES +*---- + INTEGER IJ1(25),IJ2(25) +*---- +* COMPUTE VECTORS IJ1 AND IJ2 +*---- + LL=LC*LC + DO 10 I=1,LL + IJ1(I)=1+MOD(I-1,LC) + IJ2(I)=1+(I-IJ1(I))/LC + 10 CONTINUE +* + NUM1=0 + DO 40 K=1,NEL + IF(MAT(K).EQ.0) GO TO 40 + EVECT(IDL(K))=0.0 + IF(VOL(K).EQ.0.0) GO TO 30 + DO 20 I=1,LL + IND1=KN(NUM1+I) + IF(IND1.EQ.0) GO TO 20 + I1=IJ1(I) + I2=IJ2(I) + IF(CYLIND) THEN + SS=(T(I1)+TS(I1)*XX(K)/DD(K))*T(I2) + ELSE + SS=T(I1)*T(I2) + ENDIF + EVECT(IDL(K))=EVECT(IDL(K))+SS*EVECT(IND1) + 20 CONTINUE + 30 NUM1=NUM1+LL + 40 CONTINUE + RETURN + END diff --git a/Trivac/src/FLDBSM.f b/Trivac/src/FLDBSM.f new file mode 100755 index 0000000..374a28c --- /dev/null +++ b/Trivac/src/FLDBSM.f @@ -0,0 +1,184 @@ +*DECK FLDBSM + SUBROUTINE FLDBSM(NAMP,IPTRK,IPSYS,LL4,NBMIX,NAN,F2,F3) +* +*----------------------------------------------------------------------- +* +*Purpose: +* LCM driver for the multiplication of a matrix by a vector. +* Special version for the simplified PN method in BIVAC. +* +*Copyright: +* Copyright (C) 2004 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NAMP name of the coefficient matrix. +* IPTRK L_TRACK pointer to the tracking information. +* IPSYS L_SYSTEM pointer to system matrices. +* LL4 order of the matrix. +* NBMIX total number of material mixtures in the macrolib. +* NAN number of Legendre orders in the cross sections. +* F2 vector to multiply. +* +*Parameters: output +* F3 result of the multiplication. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER NAMP*(*) + TYPE(C_PTR) IPTRK,IPSYS + INTEGER LL4,NBMIX,NAN + REAL F2(LL4),F3(LL4) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + CHARACTER NAMT*12,TEXT12*12 + INTEGER IPAR(NSTATE) + INTEGER, DIMENSION(:), ALLOCATABLE :: MAT,KN,IQFR,IPERT + REAL, DIMENSION(:), ALLOCATABLE :: VOL,QFR,XX,YY,GAMMA + REAL, DIMENSION(:,:), ALLOCATABLE :: SGD,V,R,H + INTEGER, DIMENSION(:), POINTER :: MU + REAL, DIMENSION(:), POINTER :: ASS + TYPE(C_PTR) MU_PTR,ASS_PTR +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(SGD(NBMIX,2*NAN)) +*---- +* RECOVER ENERGY GROUP INDICES. +*---- + NAMT=NAMP + READ(NAMT,'(1X,2I3)') IGR,JGR +*---- +* RECOVER PN SPECIFIC PARAMETERS. +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',IPAR) + NREG=IPAR(1) + NUN=IPAR(2) + ITYPE=IPAR(6) + IELEM=IPAR(8) + ICOL=IPAR(9) + ISPLH=IPAR(10) + L4=IPAR(11) + LX=IPAR(12) + NLF=IPAR(14) + ISPN=IPAR(15) + NVD=IPAR(17) + IF(ITYPE.EQ.8) THEN + IF(NUN.GT.(LX+L4)*NLF/2) CALL XABORT('FLDBSM: INVALID NUN OR ' + 1 //'L4.') + ELSE + IF(NUN.NE.L4*NLF/2) CALL XABORT('FLDBSM: INVALID NUN OR L4.') + ENDIF + IF(L4*NLF/2.NE.LL4) CALL XABORT('FLDBSM: INVALID L4 OR LL4.') +*---- +* PROCESS A FISSION MATRIX. +*---- + IF(NAMT(1:1).EQ.'B') THEN + CALL LCMLEN(IPTRK,'MU',LL4TS,ITYLCM) + IF(L4.NE.LL4TS) CALL XABORT('FLDBSM: INVALID L4.') + CALL LCMGPD(IPTRK,'MU',MU_PTR) + CALL LCMGPD(IPSYS,NAMT,ASS_PTR) + CALL C_F_POINTER(MU_PTR,MU,(/ LL4 /)) + CALL C_F_POINTER(ASS_PTR,ASS,(/ MU(L4) /)) + CALL ALLDLM(L4,ASS,F2,F3,MU,1) + RETURN + ELSE IF(NAMT(1:1).NE.'A') THEN + CALL XABORT('FLDBSM: ''A'' OR ''B'' MATRIX EXPECTED.') + ENDIF +*---- +* RECOVER TRACKING INFORMATION. +*---- + ALLOCATE(MAT(NREG),VOL(NREG)) + CALL LCMGET(IPTRK,'MATCOD',MAT) + CALL LCMGET(IPTRK,'VOLUME',VOL) + CALL LCMLEN(IPTRK,'KN',MAXKN,ITYLCM) + CALL LCMLEN(IPTRK,'QFR',MAXQF,ITYLCM) + ALLOCATE(KN(MAXKN),QFR(MAXQF),IQFR(MAXQF)) + CALL LCMGET(IPTRK,'KN',KN) + CALL LCMGET(IPTRK,'QFR',QFR) + CALL LCMGET(IPTRK,'IQFR',IQFR) +*---- +* PROCESS PHYSICAL ALBEDOS +*---- + TEXT12='ALBEDO-FU'//NAMT(2:4) + CALL LCMLEN(IPSYS,TEXT12,NALBP,ITYLCM) + IF(NALBP.GT.0) THEN + ALLOCATE(GAMMA(NALBP)) + CALL LCMGET(IPSYS,TEXT12,GAMMA) + DO IQW=1,MAXQF + IALB=IQFR(IQW) + IF(IALB.NE.0) QFR(IQW)=QFR(IQW)*GAMMA(IALB) + ENDDO + DEALLOCATE(GAMMA) + ENDIF +*---- +* RECOVER THE CROSS SECTIONS. +*---- + DO 20 IL=1,NAN + WRITE(TEXT12,'(4HSCAR,I2.2,A6)') IL-1,NAMT(2:7) + CALL LCMLEN(IPSYS,TEXT12,LENGT,ITYLCM) + IF(LENGT.EQ.0) THEN + SGD(:NBMIX,IL)=0.0 + SGD(:NBMIX,NAN+IL)=0.0 + ELSE + CALL LCMGET(IPSYS,TEXT12,SGD(1,IL)) + WRITE(TEXT12,'(4HSCAI,I2.2,A6)') IL-1,NAMT(2:7) + CALL LCMGET(IPSYS,TEXT12,SGD(1,NAN+IL)) + ENDIF + 20 CONTINUE +*---- +* RECOVER THE FINITE ELEMENT UNIT STIFFNESS MATRIX. +*---- + CALL LCMSIX(IPTRK,'BIVCOL',1) + CALL LCMLEN(IPTRK,'T',LC,ITYLCM) + ALLOCATE(R(LC,LC),V(LC,LC-1)) + CALL LCMGET(IPTRK,'R',R) + CALL LCMGET(IPTRK,'V',V) + CALL LCMSIX(IPTRK,' ',2) +*---- +* COMPUTE THE SOURCE +*---- + ITY=0 + IF(IGR.NE.JGR) ITY=1 + IF((ITYPE.EQ.2).OR.((ITYPE.EQ.5).AND.(ISPN.EQ.1))) THEN + ALLOCATE(XX(NREG),YY(NREG)) + CALL LCMGET(IPTRK,'XX',XX) + CALL LCMGET(IPTRK,'YY',YY) + CALL PNSZ2D(ITY,NREG,IELEM,ICOL,XX,YY,MAT,VOL,NBMIX,NLF,NVD, + 1 NAN,SGD(1,1),SGD(1,NAN+1),L4,KN,QFR,LC,R,V,F2,F3) + DEALLOCATE(YY,XX) + ELSE IF(ITYPE.EQ.8) THEN + NBLOS=LX/3 + CALL LCMGET(IPTRK,'SIDE',SIDE) + ALLOCATE(IPERT(NBLOS),H(LC,LC-1)) + CALL LCMGET(IPTRK,'IPERT',IPERT) + CALL LCMSIX(IPTRK,'BIVCOL',1) + CALL LCMGET(IPTRK,'H',H) + CALL LCMSIX(IPTRK,' ',2) + CALL PNSH2D(ITY,IELEM,ICOL,NBLOS,SIDE,MAT,NBMIX,NLF,NVD, + 1 NAN,SGD(1,1),L4,IPERT,KN,QFR,LC,R,V,H,F2,F3) + DEALLOCATE(H,IPERT) + ENDIF + IF(ITY.EQ.1) THEN + DO 30 I=1,LL4 + F3(I)=-F3(I) + 30 CONTINUE + ENDIF + DEALLOCATE(V,R,IQFR,QFR,KN,VOL,MAT) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SGD) + RETURN + END diff --git a/Trivac/src/FLDBSS.f b/Trivac/src/FLDBSS.f new file mode 100755 index 0000000..d633f9c --- /dev/null +++ b/Trivac/src/FLDBSS.f @@ -0,0 +1,154 @@ +*DECK FLDBSS + SUBROUTINE FLDBSS(NAMP,IPTRK,IPSYS,LL4,NBMIX,NAN,F1,NADI) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform a one-group SPN flux iteration in Cartesian or hexagonal 2D +* geometry in BIVAC. +* +*Copyright: +* Copyright (C) 2004 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NAMP name of the coefficient matrix. +* IPTRK L_TRACK pointer to the tracking information. +* IPSYS L_SYSTEM pointer to system matrices. +* LL4 order of the matrix. +* NBMIX total number of material mixtures in the macrolib. +* NAN number of Legendre orders in the cross sections. +* F1 source term of the linear system. +* NADI number of inner ADI iterations. +* +*Parameters: output +* F1 approached solution of the linear system. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPSYS + CHARACTER NAMP*(*) + INTEGER LL4,NBMIX,NAN,NADI + REAL F1(LL4) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + CHARACTER NAMT*12,TEXT12*12 + INTEGER IPAR(NSTATE) + INTEGER, DIMENSION(:), ALLOCATABLE :: MAT,KEY,MU,KN,IQFR,IPERT + REAL, DIMENSION(:), ALLOCATABLE :: VOL,QFR,SOUR,SYS,XX,YY,GAMMA + REAL, DIMENSION(:,:), ALLOCATABLE :: SGD,R,V +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(SGD(NBMIX,NAN)) +*---- +* RECOVER PN SPECIFIC PARAMETERS. +*---- + NAMT=NAMP + READ(NAMT,'(1X,2I3)') IGR,JGR + IF(IGR.NE.JGR) CALL XABORT('FLDBSS: INVALIB GROUP INDICES.') + IF(NAMT(1:1).NE.'A') CALL XABORT('FLDBSS: ''A'' MATRIX EXPECTED.') + CALL LCMGET(IPTRK,'STATE-VECTOR',IPAR) + NREG=IPAR(1) + NUN=IPAR(2) + ITYPE=IPAR(6) + IELEM=IPAR(8) + ICOL=IPAR(9) + ISPLH=IPAR(10) + L4=IPAR(11) + LX=IPAR(12) + NLF=IPAR(14) + ISPN=IPAR(15) + NVD=IPAR(17) + IF(ITYPE.EQ.8) THEN + IF(NUN.GT.(LX+L4)*NLF/2) CALL XABORT('FLDBSS: INVALID NUN OR ' + 1 //'L4.') + ELSE + IF(NUN.NE.L4*NLF/2) CALL XABORT('FLDBSS: INVALID NUN OR L4.') + ENDIF + IF(L4*NLF/2.NE.LL4) CALL XABORT('FLDBSS: INVALID L4 OR LL4.') + ALLOCATE(MAT(NREG),KEY(NREG),VOL(NREG),MU(L4)) + CALL LCMGET(IPTRK,'MATCOD',MAT) + CALL LCMGET(IPTRK,'KEYFLX',KEY) + CALL LCMGET(IPTRK,'VOLUME',VOL) + CALL LCMGET(IPTRK,'MU',MU) + CALL LCMLEN(IPTRK,'KN',MAXKN,ITYLCM) + CALL LCMLEN(IPTRK,'QFR',MAXQF,ITYLCM) + ALLOCATE(KN(MAXKN),QFR(MAXQF),IQFR(MAXQF)) + CALL LCMGET(IPTRK,'KN',KN) + CALL LCMGET(IPTRK,'QFR',QFR) + CALL LCMGET(IPTRK,'IQFR',IQFR) +*---- +* PROCESS PHYSICAL ALBEDO FUNCTIONS +*---- + TEXT12='ALBEDO-FU'//NAMT(2:4) + CALL LCMLEN(IPSYS,TEXT12,NALBP,ITYLCM) + IF(NALBP.GT.0) THEN + ALLOCATE(GAMMA(NALBP)) + CALL LCMGET(IPSYS,TEXT12,GAMMA) + DO IQW=1,MAXQF + IALB=IQFR(IQW) + IF(IALB.NE.0) QFR(IQW)=QFR(IQW)*GAMMA(IALB) + ENDDO + DEALLOCATE(GAMMA) + ENDIF +*---- +* RECOVER THE CROSS SECTIONS. +*---- + DO 10 IL=1,NAN + WRITE(TEXT12,'(4HSCAI,I2.2,A6)') IL-1,NAMT(2:7) + CALL LCMGET(IPSYS,TEXT12,SGD(1,IL)) + 10 CONTINUE +*---- +* RECOVER THE FINITE ELEMENT UNIT STIFFNESS MATRIX. +*---- + CALL LCMSIX(IPTRK,'BIVCOL',1) + CALL LCMLEN(IPTRK,'T',LC,ITYLCM) + ALLOCATE(R(LC,LC),V(LC,LC-1)) + CALL LCMGET(IPTRK,'R',R) + CALL LCMGET(IPTRK,'V',V) + CALL LCMSIX(IPTRK,' ',2) +*---- +* SOLVE THE LINEAR SYSTEM. +*---- + IIMAX=MU(L4)*NLF/2 + ALLOCATE(SYS(IIMAX),SOUR(NUN)) + CALL LCMGET(IPSYS,'I'//NAMT,SYS) + DO 30 IUN=1,NUN + SOUR(IUN)=F1(IUN) + F1(IUN)=0.0 + 30 CONTINUE + IF((ITYPE.EQ.2).OR.((ITYPE.EQ.5).AND.(ISPN.EQ.1))) THEN + ALLOCATE(XX(NREG),YY(NREG)) + CALL LCMGET(IPTRK,'XX',XX) + CALL LCMGET(IPTRK,'YY',YY) + CALL PNFL2E(NREG,IELEM,ICOL,XX,YY,MAT,VOL,NBMIX,NLF,NVD,NAN, + 1 SGD,L4,KN,QFR,MU,IIMAX,LC,R,V,SYS,SOUR,F1,NADI) + DEALLOCATE(YY,XX) + ELSE IF(ITYPE.EQ.8) THEN + CALL LCMGET(IPTRK,'SIDE',SIDE) + NBLOS=LX/3 + ALLOCATE(IPERT(NBLOS)) + CALL LCMGET(IPTRK,'IPERT',IPERT) + CALL PNFH2E(IELEM,ICOL,NBLOS,SIDE,NLF,NVD,L4,IPERT,KN,QFR,MU, + 1 IIMAX,LC,V,SYS,SOUR,F1,NADI) + DEALLOCATE(IPERT) + ENDIF + DEALLOCATE(SOUR,SYS,V,R,IQFR,QFR,KN,MU,VOL,KEY,MAT) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SGD) + RETURN + END diff --git a/Trivac/src/FLDDEF.f b/Trivac/src/FLDDEF.f new file mode 100755 index 0000000..84a87a0 --- /dev/null +++ b/Trivac/src/FLDDEF.f @@ -0,0 +1,245 @@ +*DECK FLDDEF + SUBROUTINE FLDDEF (MAX,IPTRK,IPSYS,LL4,ITY,NGRP,IMOD,LMOD,EVECT, + 1 ADECT,VEC,IADJ,VEA,VEB) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Multigroup Hotelling deflation procedure (1- multiplication of the +* 'A' matrix by a vector; 2- multiplication of a deflated 'B' matrix +* by the same vector). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAX first dimension of arrays EVECT, ADECT, VEC, VEA and VEB. +* IPTRK L_TRACK pointer to the tracking information. +* IPSYS L_SYSTEM pointer to system matrices. +* LL4 order of the system matrices. +* ITY type of solution (2: classical Trivac; 3: Thomas-Raviart). +* NGRP number of energy groups. +* IMOD number of the harmonic to be deflated. +* LMOD total number of harmonics. +* EVECT direct eigenvector. +* ADECT adjoint eigenvector. +* VEC vector to be multiplied. +* IADJ type of deflation: +* =1 for a direct deflation; =2 for an adjoint deflation. +* +*Parameters: output +* VEA result of the multiplication to the 'A' matrix. +* VEB result of the multiplication to the 'B' matrix. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPSYS + INTEGER MAX,LL4,ITY,NGRP,IMOD,LMOD,IADJ + REAL EVECT(MAX,NGRP,LMOD),ADECT(MAX,NGRP,LMOD),VEC(MAX,NGRP), + 1 VEA(MAX,NGRP),VEB(MAX,NGRP) +*---- +* LOCAL VARIABLES +*---- + CHARACTER*12 TEXT12 + DOUBLE PRECISION DDELN1,DDELD1 + REAL, DIMENSION(:), ALLOCATABLE :: GAF,W + REAL, DIMENSION(:), POINTER :: AGARM + TYPE(C_PTR) AGARM_PTR +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(GAF(LL4)) +* + IF(IADJ.EQ.1) THEN +* DIRECT CASE. + DO 45 IGR=1,NGRP + VEB(:LL4,IGR)=0.0 + DO 40 JGR=1,NGRP + WRITE(TEXT12,'(1HB,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 40 + CALL LCMGPD(IPSYS,TEXT12,AGARM_PTR) + CALL C_F_POINTER(AGARM_PTR,AGARM,(/ ILONG /)) + DO 20 I=1,ILONG + VEB(I,IGR)=VEB(I,IGR)+AGARM(I)*VEC(I,JGR) + 20 CONTINUE + 40 CONTINUE + 45 CONTINUE + DO 132 JMOD=1,IMOD-1 + DDELN1=0.0D0 + DDELD1=0.0D0 + DO 125 IGR=1,NGRP + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,EVECT(1,IGR,JMOD), + 1 VEA(1,IGR)) + GAF(:LL4)=0.0 + DO 110 JGR=1,NGRP + IF(JGR.EQ.IGR) GO TO 80 + WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 80 + IF(ITY.EQ.13) THEN + ALLOCATE(W(LL4)) + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,EVECT(1,JGR,JMOD), + 1 W(1)) + DO 50 I=1,LL4 + VEA(I,IGR)=VEA(I,IGR)-W(I) + 50 CONTINUE + DEALLOCATE(W) + ELSE + CALL LCMGPD(IPSYS,TEXT12,AGARM_PTR) + CALL C_F_POINTER(AGARM_PTR,AGARM,(/ ILONG /)) + DO 60 I=1,ILONG + VEA(I,IGR)=VEA(I,IGR)-AGARM(I)*EVECT(I,JGR,JMOD) + 60 CONTINUE + ENDIF + 80 WRITE(TEXT12,'(1HB,2I3.3)') JGR,IGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 110 + CALL LCMGPD(IPSYS,TEXT12,AGARM_PTR) + CALL C_F_POINTER(AGARM_PTR,AGARM,(/ ILONG /)) + DO 90 I=1,ILONG + GAF(I)=GAF(I)+AGARM(I)*ADECT(I,JGR,JMOD) + 90 CONTINUE + 110 CONTINUE + DO 120 I=1,LL4 + DDELN1=DDELN1+GAF(I)*VEC(I,IGR) + DDELD1=DDELD1+ADECT(I,IGR,JMOD)*VEA(I,IGR) + 120 CONTINUE + 125 CONTINUE + DDELN1=DDELN1/DDELD1 + DO 131 IGR=1,NGRP + DO 130 I=1,LL4 + VEB(I,IGR)=VEB(I,IGR)-VEA(I,IGR)*REAL(DDELN1) + 130 CONTINUE + 131 CONTINUE + 132 CONTINUE + DO 165 IGR=1,NGRP + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,VEC(1,IGR),VEA(1,IGR)) + DO 160 JGR=1,NGRP + IF(JGR.EQ.IGR) GO TO 160 + WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 160 + IF(ITY.EQ.13) THEN + ALLOCATE(W(LL4)) + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,VEC(1,JGR),W(1)) + DO 135 I=1,LL4 + VEA(I,IGR)=VEA(I,IGR)-W(I) + 135 CONTINUE + DEALLOCATE(W) + ELSE + CALL LCMGPD(IPSYS,TEXT12,AGARM_PTR) + CALL C_F_POINTER(AGARM_PTR,AGARM,(/ ILONG /)) + DO 140 I=1,ILONG + VEA(I,IGR)=VEA(I,IGR)-AGARM(I)*VEC(I,JGR) + 140 CONTINUE + ENDIF + 160 CONTINUE + 165 CONTINUE + ELSE IF(IADJ.EQ.2) THEN +* ADJOINT CASE. + DO 205 IGR=1,NGRP + VEB(:LL4,IGR)=0.0 + DO 200 JGR=1,NGRP + WRITE(TEXT12,'(1HB,2I3.3)') JGR,IGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 200 + CALL LCMGPD(IPSYS,TEXT12,AGARM_PTR) + CALL C_F_POINTER(AGARM_PTR,AGARM,(/ ILONG /)) + DO 180 I=1,ILONG + VEB(I,IGR)=VEB(I,IGR)+AGARM(I)*VEC(I,JGR) + 180 CONTINUE + 200 CONTINUE + 205 CONTINUE + DO 292 JMOD=1,IMOD-1 + DDELN1=0.0D0 + DDELD1=0.0D0 + DO 285 IGR=1,NGRP + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,ADECT(1,IGR,JMOD), + 1 VEA(1,IGR)) + GAF(:LL4)=0.0 + DO 270 JGR=1,NGRP + IF(JGR.EQ.IGR) GO TO 240 + WRITE(TEXT12,'(1HA,2I3.3)') JGR,IGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 240 + IF(ITY.EQ.13) THEN + ALLOCATE(W(LL4)) + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,ADECT(1,JGR,JMOD), + 1 W(1)) + DO 210 I=1,LL4 + VEA(I,IGR)=VEA(I,IGR)-W(I) + 210 CONTINUE + DEALLOCATE(W) + ELSE + CALL LCMGPD(IPSYS,TEXT12,AGARM_PTR) + CALL C_F_POINTER(AGARM_PTR,AGARM,(/ ILONG /)) + DO 220 I=1,ILONG + VEA(I,IGR)=VEA(I,IGR)-AGARM(I)*ADECT(I,JGR,JMOD) + 220 CONTINUE + ENDIF + 240 WRITE(TEXT12,'(1HB,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 270 + CALL LCMGPD(IPSYS,TEXT12,AGARM_PTR) + CALL C_F_POINTER(AGARM_PTR,AGARM,(/ ILONG /)) + DO 250 I=1,ILONG + GAF(I)=GAF(I)+AGARM(I)*EVECT(I,JGR,JMOD) + 250 CONTINUE + 270 CONTINUE + DO 280 I=1,LL4 + DDELN1=DDELN1+GAF(I)*VEC(I,IGR) + DDELD1=DDELD1+EVECT(I,IGR,JMOD)*VEA(I,IGR) + 280 CONTINUE + 285 CONTINUE + DDELN1=DDELN1/DDELD1 + DO 291 IGR=1,NGRP + DO 290 I=1,LL4 + VEB(I,IGR)=VEB(I,IGR)-VEA(I,IGR)*REAL(DDELN1) + 290 CONTINUE + 291 CONTINUE + 292 CONTINUE + DO 325 IGR=1,NGRP + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,VEC(1,IGR),VEA(1,IGR)) + DO 320 JGR=1,NGRP + IF(JGR.EQ.IGR) GO TO 320 + WRITE(TEXT12,'(1HA,2I3.3)') JGR,IGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 320 + IF(ITY.EQ.13) THEN + ALLOCATE(W(LL4)) + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,VEC(1,JGR),W(1)) + DO 295 I=1,LL4 + VEA(I,IGR)=VEA(I,IGR)-W(I) + 295 CONTINUE + DEALLOCATE(W) + ELSE + CALL LCMGPD(IPSYS,TEXT12,AGARM_PTR) + CALL C_F_POINTER(AGARM_PTR,AGARM,(/ ILONG /)) + DO 300 I=1,ILONG + VEA(I,IGR)=VEA(I,IGR)-AGARM(I)*VEC(I,JGR) + 300 CONTINUE + ENDIF + 320 CONTINUE + 325 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(GAF) + RETURN + END diff --git a/Trivac/src/FLDDIR.f b/Trivac/src/FLDDIR.f new file mode 100755 index 0000000..51f96e6 --- /dev/null +++ b/Trivac/src/FLDDIR.f @@ -0,0 +1,526 @@ +*DECK FLDDIR + SUBROUTINE FLDDIR(IPTRK,IPSYS,IPFLUX,LL4,ITY,NUN,NGRP,ICL1,ICL2, + 1 IMPX,IMPH,TITR,EPS2,NADI,MAXOUT,MAXINR,EPSINR,EVECT,FKEFF) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solution of a multigroup eigenvalue system for the calculation of the +* direct neutron flux in Trivac. Use the preconditioned power method +* with a two-parameter SVAT acceleration technique. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK L_TRACK pointer to the tracking information. +* IPSYS L_SYSTEM pointer to system matrices. +* IPFLUX L_FLUX pointer to the solution. +* LL4 order of the system matrices. +* ITY type of solution (2: classical Trivac; 3: Thomas-Raviart). +* NUN number of unknowns in each energy group. +* NGRP number of energy groups. +* ICL1 number of free iterations in one cycle of the inverse power +* method. +* ICL2 number of accelerated iterations in one cycle. +* IMPX print parameter: =0: no print; =1: minimum printing; +* =2: iteration history is printed; =3: solution is printed. +* IMPH type of histogram processing: +* =0: no action is taken; +* =1: the flux is compared to a reference flux stored on LCM; +* =2: the convergence histogram is printed; +* =3: the convergence histogram is printed with axis and +* titles. The plotting file is completed; +* =4: the convergence histogram is printed with axis, acce- +* leration factors and titles. The plotting file is +* completed. +* TITR title. +* EPS2 convergence criteria for the flux. +* NADI number of inner ADI iterations per outer iteration. +* MAXOUT maximum number of outer iterations. +* MAXINR maximum number of thermal iterations. +* EPSINR thermal iteration epsilon. +* EVECT initial estimate of the unknown vector. +* +*Parameters: output +* FKEFF effective multiplication factor. +* EVECT converged unknown vector. +* +*Reference: +* A. H\'ebert, 'Preconditioning the power method for reactor +* calculations', Nucl. Sci. Eng., 94, 1 (1986). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPSYS,IPFLUX + CHARACTER TITR*72 + INTEGER LL4,ITY,NUN,NGRP,ICL1,ICL2,IMPX,IMPH,NADI,MAXOUT,MAXINR + REAL FKEFF,EPS2,EPSINR,EVECT(NUN,NGRP) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MMAXX=250,EPS1=1.0E-5) + CHARACTER TEXT12*12 + LOGICAL LOGTES + DOUBLE PRECISION AEAE,AEAG,AEAH,AGAG,AGAH,AHAH,BEBE,BEBG,BEBH, + 1 BGBG,BGBH,BHBH,AEBE,AEBG,AEBH,AGBE,AGBG,AGBH,AHBE,AHBG,AHBH, + 2 X,DXDA,DXDB,Y,DYDA,DYDB,Z,DZDA,DZDB,F,D2F(2,3),EVAL,ALP,BET, + 3 FMIN + REAL ERR(MMAXX),ALPH(MMAXX),BETA(MMAXX) + DOUBLE PRECISION, PARAMETER :: ALP_TAB(24) = (/ 0.2, 0.4, 0.6, + 1 0.8, 1.0, 1.2, 1.5, 2.0, 10.0, 15.0, 20.0, 25.0, 30.0, 35.0, + 2 40.0, 45.0, 50.0, 55.0, 60.0, 65.0, 70.0, 75.0, 80.0, 85.0 /) + DOUBLE PRECISION, PARAMETER :: BET_TAB(11) = (/ -1.0, -0.8, -0.6, + 1 -0.4, -0.2, 0.0, 0.2, 0.4, 0.6, 0.8, 1.0 /) + REAL, DIMENSION(:,:), ALLOCATABLE :: GRAD1,GRAD2,GAR1,GAR2,GAR3 + REAL, DIMENSION(:), ALLOCATABLE :: GAF1,GAF2,GAF3 + REAL, DIMENSION(:), POINTER :: AGAR + TYPE(C_PTR) AGAR_PTR +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(GRAD1(NUN,NGRP),GRAD2(NUN,NGRP),GAR1(NUN,NGRP), + 1 GAR2(NUN,NGRP),GAR3(NUN,NGRP),GAF1(NUN),GAF2(NUN),GAF3(NUN)) +* +* TKT : CPU TIME FOR THE SOLUTION OF LINEAR SYSTEMS. +* TKB : CPU TIME FOR BILINEAR PRODUCT EVALUATIONS. + TKT=0.0 + TKB=0.0 + CALL KDRCPU(TK1) + CALL MTOPEN(IMPX,IPTRK,LL4) + IF(LL4.GT.NUN) CALL XABORT('FLDDIR: INVALID NUMBER OF UNKNOWNS.') +*---- +* PRECONDITIONED POWER METHOD +*---- + EVAL=1.0D0 + VVV=0.0 + ISTART=1 + NNADI=NADI + TEST=0.0 + IF(IMPX.GE.1) WRITE (6,600) NADI + IF(IMPX.GE.2) WRITE (6,610) + DO 35 IGR=1,NGRP + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,EVECT(1,IGR),GAR1(1,IGR)) + DO 30 JGR=1,NGRP + IF(JGR.EQ.IGR) GO TO 30 + WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 30 + IF(ITY.EQ.13) THEN + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,EVECT(1,JGR),GAF1(1)) + DO 10 I=1,LL4 + GAR1(I,IGR)=GAR1(I,IGR)-GAF1(I) + 10 CONTINUE + ELSE + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ ILONG /)) + DO 20 I=1,ILONG + GAR1(I,IGR)=GAR1(I,IGR)-AGAR(I)*EVECT(I,JGR) + 20 CONTINUE + ENDIF + 30 CONTINUE + 35 CONTINUE + CALL KDRCPU(TK2) + TKB=TKB+(TK2-TK1) +* + M=0 + 40 M=M+1 +*---- +* EIGENVALUE EVALUATION +*---- + CALL KDRCPU(TK1) + AEBE=0.0D0 + BEBE=0.0D0 + DO 95 IGR=1,NGRP + DO 50 I=1,LL4 + GAF1(I)=0.0 + 50 CONTINUE + DO 80 JGR=1,NGRP + WRITE(TEXT12,'(1HB,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 80 + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ ILONG /)) + DO 60 I=1,ILONG + GAF1(I)=GAF1(I)+AGAR(I)*EVECT(I,JGR) + 60 CONTINUE + 80 CONTINUE + DO 90 I=1,LL4 + AEBE=AEBE+GAR1(I,IGR)*GAF1(I) + BEBE=BEBE+GAF1(I)**2 + GRAD1(I,IGR)=GAF1(I) + 90 CONTINUE + 95 CONTINUE + EVAL=AEBE/BEBE + CALL KDRCPU(TK2) + TKB=TKB+(TK2-TK1) +*---- +* DIRECTION EVALUATION +*---- + DO 140 IGR=1,NGRP + CALL KDRCPU(TK1) + DO 100 I=1,LL4 + GRAD1(I,IGR)=REAL(EVAL)*GRAD1(I,IGR)-GAR1(I,IGR) + 100 CONTINUE + DO 130 JGR=1,IGR-1 + WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 130 + IF(ITY.EQ.13) THEN + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD1(1,JGR),GAF1(1)) + DO 110 I=1,LL4 + GRAD1(I,IGR)=GRAD1(I,IGR)+GAF1(I) + 110 CONTINUE + ELSE + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ ILONG /)) + DO 120 I=1,ILONG + GRAD1(I,IGR)=GRAD1(I,IGR)+AGAR(I)*GRAD1(I,JGR) + 120 CONTINUE + ENDIF + 130 CONTINUE + CALL KDRCPU(TK2) + TKB=TKB+(TK2-TK1) +* + CALL KDRCPU(TK1) + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL FLDADI(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD1(1,IGR),NNADI) + CALL KDRCPU(TK2) + TKT=TKT+(TK2-TK1) + 140 CONTINUE +*---- +* PERFORM THERMAL (UP-SCATTERING) ITERATIONS +*---- + IF(MAXINR.GT.1) THEN + CALL FLDTHR(IPTRK,IPSYS,IPFLUX,.FALSE.,LL4,ITY,NUN,NGRP,ICL1, + 1 ICL2,IMPX,NNADI,0,MAXINR,EPSINR,ITER,TKT,TKB,GRAD1) + ENDIF +*---- +* DISPLACEMENT EVALUATION +*---- + F=0.0D0 + DELS=ABS(REAL((EVAL-VVV)/EVAL)) + VVV=REAL(EVAL) + CALL KDRCPU(TK1) +*---- +* EVALUATION OF THE TWO ACCELERATION PARAMETERS ALP AND BET +*---- + ALP=1.0D0 + BET=0.0D0 + N=0 + AEAE=0.0D0 + AEAG=0.0D0 + AEAH=0.0D0 + AGAG=0.0D0 + AGAH=0.0D0 + AHAH=0.0D0 + BEBG=0.0D0 + BEBH=0.0D0 + BGBG=0.0D0 + BGBH=0.0D0 + BHBH=0.0D0 + AEBG=0.0D0 + AEBH=0.0D0 + AGBE=0.0D0 + AGBG=0.0D0 + AGBH=0.0D0 + AHBE=0.0D0 + AHBG=0.0D0 + AHBH=0.0D0 + DO 175 IGR=1,NGRP + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD1(1,IGR),GAR2(1,IGR)) + DO 170 JGR=1,NGRP + IF(JGR.EQ.IGR) GO TO 170 + WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 170 + IF(ITY.EQ.13) THEN + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD1(1,JGR),GAF1(1)) + DO 150 I=1,LL4 + GAR2(I,IGR)=GAR2(I,IGR)-GAF1(I) + 150 CONTINUE + ELSE + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ ILONG /)) + DO 160 I=1,ILONG + GAR2(I,IGR)=GAR2(I,IGR)-AGAR(I)*GRAD1(I,JGR) + 160 CONTINUE + ENDIF + 170 CONTINUE + 175 CONTINUE + IF(1+MOD(M-ISTART,ICL1+ICL2).GT.ICL1) THEN + DO 205 IGR=1,NGRP + GAF1(:LL4)=0.0 + GAF2(:LL4)=0.0 + GAF3(:LL4)=0.0 + DO 190 JGR=1,NGRP + WRITE(TEXT12,'(1HB,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 190 + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ ILONG /)) + DO 180 I=1,ILONG + GAF1(I)=GAF1(I)+AGAR(I)*EVECT(I,JGR) + GAF2(I)=GAF2(I)+AGAR(I)*GRAD1(I,JGR) + GAF3(I)=GAF3(I)+AGAR(I)*GRAD2(I,JGR) + 180 CONTINUE + 190 CONTINUE + DO 200 I=1,LL4 +* COMPUTE (A ,A ) + AEAE=AEAE+GAR1(I,IGR)**2 + AEAG=AEAG+GAR1(I,IGR)*GAR2(I,IGR) + AEAH=AEAH+GAR1(I,IGR)*GAR3(I,IGR) + AGAG=AGAG+GAR2(I,IGR)**2 + AGAH=AGAH+GAR2(I,IGR)*GAR3(I,IGR) + AHAH=AHAH+GAR3(I,IGR)**2 +* COMPUTE (B ,B ) + BEBG=BEBG+GAF1(I)*GAF2(I) + BEBH=BEBH+GAF1(I)*GAF3(I) + BGBG=BGBG+GAF2(I)**2 + BGBH=BGBH+GAF2(I)*GAF3(I) + BHBH=BHBH+GAF3(I)**2 +* COMPUTE (A ,B ) + AEBG=AEBG+GAR1(I,IGR)*GAF2(I) + AEBH=AEBH+GAR1(I,IGR)*GAF3(I) + AGBE=AGBE+GAR2(I,IGR)*GAF1(I) + AGBG=AGBG+GAR2(I,IGR)*GAF2(I) + AGBH=AGBH+GAR2(I,IGR)*GAF3(I) + AHBE=AHBE+GAR3(I,IGR)*GAF1(I) + AHBG=AHBG+GAR3(I,IGR)*GAF2(I) + AHBH=AHBH+GAR3(I,IGR)*GAF3(I) + 200 CONTINUE + 205 CONTINUE +* + 210 N=N+1 + IF(N.GT.10) GO TO 215 +* COMPUTE X(M+1) + X=BEBE+ALP*ALP*BGBG+BET*BET*BHBH+2.0D0*(ALP*BEBG+BET*BEBH + 1 +ALP*BET*BGBH) + DXDA=2.0D0*(BEBG+ALP*BGBG+BET*BGBH) + DXDB=2.0D0*(BEBH+ALP*BGBH+BET*BHBH) +* COMPUTE Y(M+1) + Y=AEAE+ALP*ALP*AGAG+BET*BET*AHAH+2.0D0*(ALP*AEAG+BET*AEAH + 1 +ALP*BET*AGAH) + DYDA=2.0D0*(AEAG+ALP*AGAG+BET*AGAH) + DYDB=2.0D0*(AEAH+ALP*AGAH+BET*AHAH) +* COMPUTE Z(M+1) + Z=AEBE+ALP*ALP*AGBG+BET*BET*AHBH+ALP*(AEBG+AGBE) + 1 +BET*(AEBH+AHBE)+ALP*BET*(AGBH+AHBG) + DZDA=AEBG+AGBE+2.0D0*ALP*AGBG+BET*(AGBH+AHBG) + DZDB=AEBH+AHBE+ALP*(AGBH+AHBG)+2.0D0*BET*AHBH +* COMPUTE F(M+1) + F=X*Y-Z*Z + D2F(1,1)=2.0D0*(BGBG*Y+DXDA*DYDA+X*AGAG-DZDA**2-2.0D0*Z*AGBG) + D2F(1,2)=2.0D0*BGBH*Y+DXDA*DYDB+DXDB*DYDA+2.0D0*X*AGAH + 1 -2.0D0*DZDA*DZDB-2.0D0*Z*(AGBH+AHBG) + D2F(2,2)=2.0D0*(BHBH*Y+DXDB*DYDB+X*AHAH-DZDB**2-2.0D0*Z*AHBH) + D2F(2,1)=D2F(1,2) + D2F(1,3)=DXDA*Y+X*DYDA-2.0D0*Z*DZDA + D2F(2,3)=DXDB*Y+X*DYDB-2.0D0*Z*DZDB +* SOLUTION OF A LINEAR SYSTEM. + CALL ALSBD(2,1,D2F,IER,2) + IF(IER.NE.0) GO TO 215 + ALP=ALP-D2F(1,3) + BET=BET-D2F(2,3) + IF(ALP.GT.100.0) GO TO 215 + IF((ABS(D2F(1,3)).LE.1.0D-4).AND.(ABS(D2F(2,3)).LE.1.0D-4)) + 1 GO TO 220 + GO TO 210 +* +* alternative algorithm in case of Newton-Raphton failure + 215 IF(IMPX.GT.0) WRITE(6,'(/30H FLDDIR: FAILURE OF THE NEWTON, + 1 55H-RAPHTON ALGORIHTHM FOR COMPUTING THE OVERRELAXATION PA, + 2 9HRAMETERS.)') + IAMIN=999 + IBMIN=999 + FMIN=HUGE(FMIN) + DO IA=1,SIZE(ALP_TAB) + ALP=ALP_TAB(IA) + DO IB=1,SIZE(BET_TAB) + BET=BET_TAB(IB) +* COMPUTE X + X=BEBE+ALP*ALP*BGBG+BET*BET*BHBH+2.0D0*(ALP*BEBG+BET*BEBH + 1 +ALP*BET*BGBH) +* COMPUTE Y + Y=AEAE+ALP*ALP*AGAG+BET*BET*AHAH+2.0D0*(ALP*AEAG+BET*AEAH + 1 +ALP*BET*AGAH) +* COMPUTE Z + Z=AEBE+ALP*ALP*AGBG+BET*BET*AHBH+ALP*(AEBG+AGBE) + 1 +BET*(AEBH+AHBE)+ALP*BET*(AGBH+AHBG) +* COMPUTE F + F=X*Y-Z*Z + IF(F.LT.FMIN) THEN + IAMIN=IA + IBMIN=IB + FMIN=F + ENDIF + ENDDO + ENDDO + ALP=ALP_TAB(IAMIN) + BET=BET_TAB(IBMIN) + 220 BET=BET/ALP + IF((ALP.LT.1.0D0).AND.(ALP.GT.0.0D0)) THEN + ALP=1.0D0 + BET=0.0D0 + ELSE IF(ALP.LE.0.0D0) THEN + ISTART=M+1 + ALP=1.0D0 + BET=0.0D0 + ENDIF + DO 235 IGR=1,NGRP + DO 230 I=1,LL4 + GRAD1(I,IGR)=REAL(ALP)*(GRAD1(I,IGR)+REAL(BET)*GRAD2(I,IGR)) + GAR2(I,IGR)=REAL(ALP)*(GAR2(I,IGR)+REAL(BET)*GAR3(I,IGR)) + 230 CONTINUE + 235 CONTINUE + ENDIF + CALL KDRCPU(TK2) + TKB=TKB+(TK2-TK1) +* + LOGTES=(M.LT.ICL1).OR.(MOD(M-ISTART,ICL1+ICL2).EQ.ICL1-1) + IF(LOGTES.AND.(DELS.LE.EPS1)) THEN + DELT=0.0 + DO 290 IGR=1,NGRP + GAF1(:LL4)=0.0 + GAF2(:LL4)=0.0 + DO 250 JGR=1,NGRP + WRITE(TEXT12,'(1HB,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 250 + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ ILONG /)) + DO 240 I=1,ILONG + GAF1(I)=GAF1(I)+AGAR(I)*EVECT(I,JGR) + GAF2(I)=GAF2(I)+AGAR(I)*GRAD1(I,JGR) + 240 CONTINUE + 250 CONTINUE + DELN=0.0 + DELD=0.0 + DO 280 I=1,LL4 + EVECT(I,IGR)=EVECT(I,IGR)+GRAD1(I,IGR) + GAR1(I,IGR)=GAR1(I,IGR)+GAR2(I,IGR) + GRAD2(I,IGR)=GRAD1(I,IGR) + GAR3(I,IGR)=GAR2(I,IGR) + DELN=MAX(DELN,ABS(GAF2(I))) + DELD=MAX(DELD,ABS(GAF1(I))) + 280 CONTINUE + IF(DELD.NE.0.0) DELT=MAX(DELT,DELN/DELD) + 290 CONTINUE + IF(IMPX.GE.2) WRITE (6,615) M,AEAE,AEAG,AEAH,AGAG,AGAH,AHAH, + 1 BEBE,ALP,REAL(BET),EVAL,F,DELS,DELT,N,BEBG,BEBH,BGBG,BGBH,BHBH, + 2 AEBE,AEBG,AEBH,AGBE,AGBG,AGBH,AHBE,AHBG,AHBH +* COMPUTE THE CONVERGENCE HISTOGRAM. + IF((IMPH.GE.1).AND.(M.LE.MMAXX)) THEN + CALL FLDXCO(IPFLUX,LL4,NUN,EVECT(1,NGRP),.TRUE.,ERR(M)) + ALPH(M)=REAL(ALP) + BETA(M)=REAL(BET) + ENDIF + IF(DELT.LE.EPS2) GO TO 310 + ELSE + DO 305 IGR=1,NGRP + DO 300 I=1,LL4 + EVECT(I,IGR)=EVECT(I,IGR)+GRAD1(I,IGR) + GAR1(I,IGR)=GAR1(I,IGR)+GAR2(I,IGR) + GRAD2(I,IGR)=GRAD1(I,IGR) + GAR3(I,IGR)=GAR2(I,IGR) + 300 CONTINUE + 305 CONTINUE + IF(IMPX.GE.2) WRITE (6,620) M,AEAE,AEAG,AEAH,AGAG,AGAH,AHAH, + 1 BEBE,ALP,BET,EVAL,F,DELS,N,BEBG,BEBH,BGBG,BGBH,BHBH,AEBE, + 2 AEBG,AEBH,AGBE,AGBG,AGBH,AHBE,AHBG,AHBH +* COMPUTE THE CONVERGENCE HISTOGRAM. + IF((IMPH.GE.1).AND.(M.LE.MMAXX)) THEN + CALL FLDXCO(IPFLUX,LL4,NUN,EVECT(1,NGRP),.TRUE.,ERR(M)) + ALPH(M)=REAL(ALP) + BETA(M)=REAL(BET) + ENDIF + ENDIF +* + IF(M.EQ.1) TEST=DELS + IF((M.GT.5).AND.(DELS.GT.TEST)) CALL XABORT('FLDDIR: CONVERGENCE' + 1 //' FAILURE.') + IF(M.GE.MAXOUT) THEN + WRITE (6,690) + GO TO 310 + ENDIF + IF(MOD(M,36).EQ.0) THEN + ISTART=M+1 + NNADI=NNADI+1 + IF(IMPX.GE.1) WRITE (6,700) NNADI + ENDIF + GO TO 40 +*---- +* SOLUTION EDITION +*---- + 310 FKEFF=REAL(1.0D0/EVAL) + IF(IMPX.EQ.1) WRITE (6,640) M + IF(IMPX.GE.1) THEN + WRITE (6,650) TKT,TKB,TKT+TKB + WRITE (6,670) FKEFF + ENDIF + IF(IMPX.EQ.3) THEN + DO 320 IGR=1,NGRP + WRITE (6,680) IGR,(EVECT(I,IGR),I=1,LL4) + 320 CONTINUE + ENDIF + IF(IMPH.EQ.1) THEN + CALL LCMLEN(IPFLUX,'REF',ILONG,ITYLCM) + IF(ILONG.EQ.0) THEN + WRITE(6,'(40H FLDDIR: STORE A REFERENCE THERMAL FLUX.)') + CALL LCMPUT(IPFLUX,'REF',NUN,2,EVECT(1,NGRP)) + ENDIF + ELSE IF(IMPH.GE.2) THEN + IGRAPH=0 + 330 IGRAPH=IGRAPH+1 + WRITE (TEXT12,'(5HHISTO,I3)') IGRAPH + CALL LCMLEN (IPFLUX,TEXT12,ILENG,ITYLCM) + IF(ILENG.EQ.0) THEN + MM=MIN(M,MMAXX) + CALL LCMSIX (IPFLUX,TEXT12,1) + CALL LCMPTC (IPFLUX,'HTITLE',72,TITR) + CALL LCMPUT (IPFLUX,'ALPHA',MM,2,ALPH) + CALL LCMPUT (IPFLUX,'BETA',MM,2,BETA) + CALL LCMPUT (IPFLUX,'ERROR',MM,2,ERR) + CALL LCMPUT (IPFLUX,'IMPH',1,1,IMPH) + CALL LCMSIX (IPFLUX,' ',2) + ELSE + GO TO 330 + ENDIF + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(GRAD1,GRAD2,GAR1,GAR2,GAR3,GAF1,GAF2,GAF3) + RETURN +* + 600 FORMAT(1H1/50H FLDDIR: ITERATIVE PROCEDURE BASED ON PRECONDITION, + 1 17HED POWER METHOD (,I2,37H ADI ITERATIONS PER OUTER ITERATION)./ + 2 9X,16HDIRECT EQUATION.) + 610 FORMAT(//5X,17HBILINEAR PRODUCTS,48X,5HALPHA,3X,4HBETA,3X, + 1 12HEIGENVALUE..,12X,8HACCURACY,11(1H.),2X,1HN) + 615 FORMAT(1X,I3,1P,7E9.1,0P,2F8.3,E14.6,3E10.2,I4/(4X,1P,7E9.1)) + 620 FORMAT(1X,I3,1P,7E9.1,0P,2F8.3,E14.6,2E10.2,10X,I4/(4X,1P,7E9.1)) + 640 FORMAT(/23H FLDDIR: CONVERGENCE IN,I4,12H ITERATIONS.) + 650 FORMAT(/53H FLDDIR: CPU TIME USED TO SOLVE THE TRIANGULAR LINEAR, + 1 10H SYSTEMS =,F10.3/23X,34HTO COMPUTE THE BILINEAR PRODUCTS =, + 2 F10.3,20X,16HTOTAL CPU TIME =,F10.3) + 670 FORMAT(//42H FLDDIR: EFFECTIVE MULTIPLICATION FACTOR =,1P,E17.10/) + 680 FORMAT(//47H FLDDIR: EIGENVECTOR CORRESPONDING TO THE GROUP,I4 + 1 //(5X,1P,8E14.5)) + 690 FORMAT(/53H FLDDIR: ***WARNING*** THE MAXIMUM NUMBER OF OUTER IT, + 1 20HERATIONS IS REACHED.) + 700 FORMAT(/53H FLDDIR: INCREASING THE NUMBER OF INNER ITERATIONS TO, + 1 I3,36H ADI ITERATIONS PER OUTER ITERATION./) + END diff --git a/Trivac/src/FLDDRV.f b/Trivac/src/FLDDRV.f new file mode 100755 index 0000000..affadc8 --- /dev/null +++ b/Trivac/src/FLDDRV.f @@ -0,0 +1,515 @@ +*DECK FLDDRV + SUBROUTINE FLDDRV (CMODUL,IPTRK,IPSYS,REC,NEL,LL4,ITY,NUN,NBMIX, + 1 MAT,VOL,IDL,NGRP,TITR,LREL,IPFLUX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solution of the neutron flux as an eigenvalue problem. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* CMODUL name of the assembly door ('BIVAC' or 'TRIVAC'). +* IPTRK L_TRACK pointer to the tracking information. +* IPSYS L_SYSTEM pointer to system matrices. +* REC flux recovery flag: +* .true.: recover the existing solution as initial estimate; +* .false.: use a uniform initial estimate. +* NEL total number of finite elements. +* LL4 order of the system matrices. +* ITY type of solution (2: classical Trivac; 3: Thomas-Raviart). +* NUN total number of unknowns per group. +* NBMIX number of material mixtures. +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* IDL position of the average flux component associated with each +* volume. +* NGRP number of energy groups. +* TITR title. +* LREL flag set to .true. if a RHS estimate of the solution is +* available. +* IPFLUX L_FLUX pointer to the solution. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER CMODUL*12,TITR*72 + TYPE(C_PTR) IPTRK,IPSYS,IPFLUX + INTEGER NEL,LL4,ITY,NUN,NBMIX,MAT(NEL),IDL(NEL),NGRP + REAL VOL(NEL) + LOGICAL REC,LREL +*---- +* GENERIC INTERFACE +*---- + INTERFACE + FUNCTION FLDMX_TEMPLATE(F,N,IBLSZ,ITER,IPTRK,IPSYS,IPFLUX) + 1 RESULT(X) + USE GANLIB + INTEGER, INTENT(IN) :: N,IBLSZ,ITER + COMPLEX(KIND=8), DIMENSION(N,IBLSZ), INTENT(IN) :: F + COMPLEX(KIND=8), DIMENSION(N,IBLSZ) :: X + TYPE(C_PTR) IPTRK,IPSYS,IPFLUX + END FUNCTION FLDMX_TEMPLATE + END INTERFACE + PROCEDURE(FLDMX_TEMPLATE) :: FLDBMX,FLDTMX +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40,IOUT=6) + CHARACTER TEXT4*4,HSMG*131 + DOUBLE PRECISION DFLOTT + LOGICAL ADJ,RAND + INTEGER ISTATE(NSTATE) + REAL EPSCON(5),RELAX + REAL, DIMENSION(:), ALLOCATABLE :: FKEFFV + REAL, DIMENSION(:,:), ALLOCATABLE :: EVECT + REAL, DIMENSION(:,:,:), ALLOCATABLE :: EV,AD + COMPLEX, DIMENSION(:), ALLOCATABLE :: CFKEFFV + COMPLEX, DIMENSION(:,:,:), ALLOCATABLE :: CEV + TYPE(C_PTR) JPFLUX,KPFLUX,MPFLUX,NPFLUX +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(EVECT(NUN,NGRP)) +* +*----------------------------------------------------------------------- +* INFORMATION RECOVERED FROM L_SYSTEM AT IPSYS: +* 'A 1 1' : SYSTEM MATRIX RELATED TO FAST LEAKAGE AND REMOVAL. +* 'A 2 2' : SYSTEM MATRIX RELATED TO THERMAL LEAKAGE AND REMOVAL. +* 'A 1 2' : SYSTEM MATRIX RELATED TO UP-SCATTERING. +* 'A 2 1' : SYSTEM MATRIX RELATED TO DOWN-SCATTERING. +* 'B 1 1' : SYSTEM MATRIX RELATED TO FAST FISSION. +* 'B 1 2' : SYSTEM MATRIX RELATED TO THERMAL FISSION. +*----------------------------------------------------------------------- +* +*---- +* READ THE INPUT DATA +*---- + IMPX=1 + IMPH=0 + RAND=.FALSE. + IF(REC) THEN +* RECOVER EXISTING OPTIONS. + CALL LCMGET(IPFLUX,'STATE-VECTOR',ISTATE) + ADJ=MOD(ISTATE(3)/10,10).EQ.1 + LMOD=ISTATE(4) + ICL1=ISTATE(8) + ICL2=ISTATE(9) + IREBAL=ISTATE(10) + MAXINR=ISTATE(11) + MAXOUT=ISTATE(12) + NADI=ISTATE(13) + IBLSZ=ISTATE(14) + NSTARD=ISTATE(15) + CALL LCMGET(IPFLUX,'EPS-CONVERGE',EPSCON) + EPSINR=EPSCON(1) + EPSOUT=EPSCON(2) + EPSMSR=EPSCON(4) + RELAX=EPSCON(5) + ELSE +* DEFAULT OPTIONS. + ADJ=.FALSE. + LMOD=0 + ICL1=3 + ICL2=3 + MAXINR=0 + IREBAL=0 + MAXOUT=200 + IBLSZ=0 + NSTARD=0 + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + NADI=ISTATE(33) + EPSINR=1.0E-5 + EPSOUT=1.0E-4 + EPSMSR=1.0E-6 + RELAX=1.0 + ENDIF +* + 10 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.EQ.10) GO TO 50 + 20 IF(INDIC.NE.3) CALL XABORT('FLDDRV: CHARACTER DATA EXPECTED.') + IF(TEXT4.EQ.'EDIT') THEN + CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('FLDDRV: INTEGER DATA EXPECTED(3).') + ELSE IF((TEXT4.EQ.'VAR1').OR.(TEXT4.EQ.'ACCE')) THEN + CALL REDGET(INDIC,ICL1,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('FLDDRV: INTEGER DATA EXPECTED(1).') + CALL REDGET(INDIC,ICL2,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('FLDDRV: INTEGER DATA EXPECTED(2).') + ELSE IF(TEXT4.EQ.'IRAM') THEN + CALL REDGET(INDIC,IBLSZ,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('FLDDRV: INTEGER DATA EXPECTED(3).') + CALL REDGET(INDIC,LMOD,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('FLDDRV: INTEGER DATA EXPECTED(4).') + NADI=MAX(NADI,5) + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) THEN + IF((ITY.EQ.2).OR.(ITY.EQ.3).OR.(ITY.EQ.11).OR.(ITY.EQ.13)) + 1 NADI=MAX(NADI,20) + GO TO 20 + ENDIF + IF(CMODUL.EQ.'BIVAC') CALL XABORT('FLDDRV: NSTARD OPTION NOT A' + 1 //'VAILABLE WITH BIVAC.') + NSTARD=NITMA + NADI=MAX(NADI,20) + ELSE IF(TEXT4.EQ.'EPSG') THEN + CALL REDGET(INDIC,NITMA,EPSMSR,TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('FLDDRV: REAL DATA EXPECTED.') + ELSE IF(TEXT4.EQ.'ADI') THEN + CALL REDGET(INDIC,NADI,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('FLDDRV: INTEGER DATA EXPECTED(5).') + ELSE IF(TEXT4.EQ.'ADJ') THEN + ADJ=.TRUE. + ELSE IF(TEXT4.EQ.'EXTE') THEN + 30 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.EQ.1) THEN + MAXOUT=NITMA + ELSE IF(INDIC.EQ.2) THEN + EPSOUT=FLOTT + ELSE + GO TO 20 + ENDIF + GO TO 30 + ELSE IF(TEXT4.EQ.'THER') THEN + IREBAL=1 + 40 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.EQ.1) THEN + MAXINR=NITMA + ELSE IF(INDIC.EQ.2) THEN + EPSINR=FLOTT + ELSE + GO TO 20 + ENDIF + GO TO 40 + ELSE IF(TEXT4.EQ.'MONI') THEN + CALL REDGET(INDIC,LMOD,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('FLDDRV: INTEGER DATA EXPECTED(6).') + IF(LMOD.LE.0) CALL XABORT('FLDDRV: INVALID VALUE OF LMOD.') + ELSE IF(TEXT4.EQ.'RAND') THEN + RAND=.TRUE. + ELSE IF(TEXT4.EQ.'HIST') THEN + CALL REDGET(INDIC,IMPH,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('FLDDRV: INTEGER DATA EXPECTED(7).') + ELSE IF(TEXT4.EQ.'RELA') THEN + IF(.NOT.LREL) CALL XABORT('FLDDRV: ENTRY L_FLUX IN MODIFICATIO' + 1 //'N MODE EXPECTED FOR RELAX KEYWORD.') + CALL REDGET(INDIC,NITMA,RELAX,TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('FLDDRV: REAL DATA EXPECTED.') + ELSE IF(TEXT4.EQ.';') THEN + GO TO 50 + ELSE + CALL XABORT('FLDDRV: '//TEXT4//' IS AN INVALID KEY WORD.') + ENDIF + GO TO 10 +*---- +* FLUXES INITIALIZATION +*---- + 50 IF(REC.AND.(IMPH.EQ.0)) THEN + CALL LCMLEN(IPFLUX,'FLUX',ILONG,ITYLCM) + IF(ILONG.NE.NGRP) CALL XABORT('FLDDRV: UNABLE TO RECOVER ''FLU' + 1 //'X''.') + JPFLUX=LCMGID(IPFLUX,'FLUX') + DO 60 IGR=1,NGRP + CALL LCMGDL(JPFLUX,IGR,EVECT(1,IGR)) + 60 CONTINUE + ELSE +* INITIAL ESTIMATE OF THE DIRECT FLUXES. + EVECT(:NUN,:NGRP)=1.0 + ENDIF +* + DNORM=1.0 + ANORM=1.0 + IF((LMOD.GT.0).AND.(IBLSZ.EQ.0)) THEN +* BI-ORTHOGONAL HARMONIC CALCULATION. + IF(CMODUL.NE.'TRIVAC') CALL XABORT('FLDDRV: HARMONIC CALCULAT' + 1 //'ION IS ONLY POSSIBLE WITH TRIVAC.') + ALLOCATE(FKEFFV(LMOD),EV(NUN,NGRP,LMOD),AD(NUN,NGRP,LMOD)) + CALL FLDMON(IPTRK,IPSYS,IPFLUX,LL4,ITY,NUN,NGRP,LMOD,ICL1, + 1 ICL2,IMPX,IMPH,TITR,EPSOUT,NADI,MAXOUT,MAXINR,EPSINR,RAND, + 2 FKEFFV,EV,AD) + JPFLUX=LCMLID(IPFLUX,'MODE',LMOD) + DO 90 IMOD=1,LMOD +* CREATE A DIRECTORY AT IMOD-TH LIST ELEMENT. + KPFLUX=LCMDIL(JPFLUX,IMOD) +* PUT NODES IN DIRECTORY KPFLUX. + CALL LCMPUT(KPFLUX,'K-EFFECTIVE',1,2,FKEFFV(IMOD)) + CALL LCMPUT(KPFLUX,'K-INFINITY',1,2,FKEFFV(IMOD)) + MPFLUX=LCMLID(KPFLUX,'FLUX',NGRP) + NPFLUX=LCMLID(KPFLUX,'AFLUX',NGRP) +* STORE FLUX AND ADJOINT FLUX IN THE IGR-TH COMPONENT OF EACH +* LIST. + DO 70 IGR=1,NGRP + CALL FLDTRI(IPTRK,NEL,NUN,EV(1,IGR,IMOD),MAT,VOL,IDL) + CALL FLDTRI(IPTRK,NEL,NUN,AD(1,IGR,IMOD),MAT,VOL,IDL) + 70 CONTINUE + IF(IMOD.EQ.1) THEN + CALL FLDNOR(IPSYS,NUN,NGRP,NEL,NBMIX,MAT,VOL,IDL,'DIRE', + 1 EV(1,1,IMOD),DNORM) + CALL FLDNOR(IPSYS,NUN,NGRP,NEL,NBMIX,MAT,VOL,IDL,'ADJO', + 1 AD(1,1,IMOD),ANORM) + ELSE + EV(:NUN,:NGRP,IMOD)=EV(:NUN,:NGRP,IMOD)*DNORM + AD(:NUN,:NGRP,IMOD)=AD(:NUN,:NGRP,IMOD)*DNORM + ENDIF + IF(LREL) THEN + CALL FLDREL(RELAX,MPFLUX,NGRP,NUN,EV(1,1,IMOD)) + CALL FLDREL(RELAX,NPFLUX,NGRP,NUN,AD(1,1,IMOD)) + ENDIF + DO 80 IGR=1,NGRP + CALL LCMPDL(MPFLUX,IGR,NUN,2,EV(1,IGR,IMOD)) + CALL LCMPDL(NPFLUX,IGR,NUN,2,AD(1,IGR,IMOD)) + 80 CONTINUE + 90 CONTINUE + CALL LCMPUT(IPFLUX,'K-EFFECTIVE',1,2,FKEFFV(1)) + DEALLOCATE(AD,EV,FKEFFV) + IF(IMPX.GT.1) THEN +* TEST ORTHOGONALITY OF EIGENVECTORS. + CALL FLDORT(IPSYS,IPFLUX,NUN,NGRP,LMOD) + ENDIF + ELSE IF(IBLSZ.GT.0) THEN +* IMPLICIT RESTARTED ARNOLDI METHOD (IRAM). + IF(LMOD.EQ.0) CALL XABORT('FLDDRV: LMOD>0 EXPECTED WITH IRAM.') + ALLOCATE(CFKEFFV(LMOD),CEV(NUN,NGRP,LMOD)) + EPSCON(1)=EPSINR + EPSCON(4)=EPSMSR + CALL LCMPUT(IPFLUX,'EPS-CONVERGE',5,2,EPSCON) + ISTATE(:NSTATE)=0 + ISTATE(3)=1 + ISTATE(8)=ICL1 + ISTATE(9)=ICL2 + ISTATE(10)=IREBAL + ISTATE(11)=MAXINR + ISTATE(13)=NADI + ISTATE(15)=NSTARD + ISTATE(40)=IMPX +* +* DIRECT CALCULATION + CALL LCMPUT(IPFLUX,'STATE-VECTOR',NSTATE,1,ISTATE) + IF(CMODUL.EQ.'BIVAC') THEN + CALL FLDARN(FLDBMX,IPTRK,IPSYS,IPFLUX,LL4,NUN,NGRP,LMOD, + 1 IBLSZ,.FALSE.,IMPX,EPSOUT,MAXOUT,CEV,CFKEFFV) + ELSE IF(CMODUL.EQ.'TRIVAC') THEN + CALL FLDARN(FLDTMX,IPTRK,IPSYS,IPFLUX,LL4,NUN,NGRP,LMOD, + 1 IBLSZ,.FALSE.,IMPX,EPSOUT,MAXOUT,CEV,CFKEFFV) + ENDIF + JPFLUX=LCMLID(IPFLUX,'MODE',LMOD) + DO 120 IMOD=1,LMOD + IF(AIMAG(CFKEFFV(IMOD)).NE.0.0) THEN + WRITE(HSMG,'(8H FLDDRV:,I4,27H-TH DIRECT MODE IS COMPLEX.)') + 1 IMOD + WRITE(IOUT,'(A)') HSMG + IF(IMOD.EQ.1)CALL XABORT('FLDDRV: COMPLEX FUNDAMENTAL MODE.') + GO TO 120 + ENDIF +* CREATE A DIRECTORY AT IMOD-TH LIST ELEMENT. + KPFLUX=LCMDIL(JPFLUX,IMOD) +* PUT NODES IN DIRECTORY KPFLUX. + EVECT(:NUN,:NGRP)=REAL(CEV(:NUN,:NGRP,IMOD)) + CALL LCMPUT(KPFLUX,'K-EFFECTIVE',1,2,REAL(CFKEFFV(IMOD))) + CALL LCMPUT(KPFLUX,'K-INFINITY',1,2,REAL(CFKEFFV(IMOD))) +* STORE FLUX IN THE IGR-TH COMPONENT OF EACH LIST. + DO 100 IGR=1,NGRP + IF(CMODUL.EQ.'BIVAC') THEN + CALL FLDBIV(IPTRK,NEL,NUN,EVECT(1,IGR),MAT,VOL,IDL) + ELSE IF(CMODUL.EQ.'TRIVAC') THEN + CALL FLDTRI(IPTRK,NEL,NUN,EVECT(1,IGR),MAT,VOL,IDL) + ENDIF + 100 CONTINUE + IF(IMOD.EQ.1) THEN + CALL FLDNOR(IPSYS,NUN,NGRP,NEL,NBMIX,MAT,VOL,IDL,'DIRE', + 1 EVECT(1,1),DNORM) + ELSE + EVECT(:NUN,:NGRP)=EVECT(:NUN,:NGRP)*DNORM + ENDIF + MPFLUX=LCMLID(KPFLUX,'FLUX',NGRP) + IF(LREL) CALL FLDREL(RELAX,MPFLUX,NGRP,NUN,EVECT(1,1)) + DO 110 IGR=1,NGRP + CALL LCMPDL(MPFLUX,IGR,NUN,2,EVECT(1,IGR)) + 110 CONTINUE + 120 CONTINUE + CALL LCMPUT(IPFLUX,'K-EFFECTIVE',1,2,REAL(CFKEFFV(1))) + IF(.NOT.ADJ) GO TO 160 +* +* ADJOINT CALCULATION + IF(CMODUL.NE.'TRIVAC') CALL XABORT('FLDDRV: ADJOINT CALCULATI' + 1 //'ON IS ONLY POSSIBLE WITH TRIVAC.') + ISTATE(3)=10 + CALL LCMPUT(IPFLUX,'STATE-VECTOR',NSTATE,1,ISTATE) + CALL FLDARN(FLDTMX,IPTRK,IPSYS,IPFLUX,LL4,NUN,NGRP,LMOD,IBLSZ, + 1 .TRUE.,IMPX,EPSOUT,MAXOUT,CEV,CFKEFFV) + JPFLUX=LCMLID(IPFLUX,'MODE',LMOD) + DO 150 IMOD=1,LMOD + IF(AIMAG(CFKEFFV(IMOD)).NE.0.0) THEN + WRITE(HSMG,'(8H FLDDRV:,I4,28H-TH ADJOINT MODE IS COMPLEX.)') + 1 IMOD + WRITE(IOUT,'(A)') HSMG + IF(IMOD.EQ.1)CALL XABORT('FLDDRV: COMPLEX FUNDAMENTAL MODE.') + GO TO 150 + ENDIF +* CREATE A DIRECTORY AT IMOD-TH LIST ELEMENT. + KPFLUX=LCMDIL(JPFLUX,IMOD) +* PUT NODES IN DIRECTORY KPFLUX. + EVECT(:NUN,:NGRP)=REAL(CEV(:NUN,:NGRP,IMOD)) + CALL LCMPUT(KPFLUX,'AK-EFFECTIVE',1,2,REAL(CFKEFFV(IMOD))) + CALL LCMPUT(KPFLUX,'AK-INFINITY',1,2,REAL(CFKEFFV(IMOD))) +* STORE FLUX IN THE IGR-TH COMPONENT OF EACH LIST. + DO 130 IGR=1,NGRP + CALL FLDTRI(IPTRK,NEL,NUN,EVECT(1,IGR),MAT,VOL,IDL) + 130 CONTINUE + IF(IMOD.EQ.1) THEN + CALL FLDNOR(IPSYS,NUN,NGRP,NEL,NBMIX,MAT,VOL,IDL,'ADJO', + 1 EVECT(1,1),ANORM) + ELSE + EVECT(:NUN,:NGRP)=EVECT(:NUN,:NGRP)*ANORM + ENDIF + NPFLUX=LCMLID(KPFLUX,'AFLUX',NGRP) + IF(LREL) CALL FLDREL(RELAX,NPFLUX,NGRP,NUN,EVECT(1,1)) + DO 140 IGR=1,NGRP + CALL LCMPDL(NPFLUX,IGR,NUN,2,EVECT(1,IGR)) + 140 CONTINUE + 150 CONTINUE + 160 DEALLOCATE(CEV,CFKEFFV) + IF(ADJ.AND.(IMPX.GT.1)) THEN +* TEST ORTHOGONALITY OF EIGENVECTORS. + CALL FLDORT(IPSYS,IPFLUX,NUN,NGRP,LMOD) + ENDIF + ELSE +* DIRECT NEUTRON FLUX CALCULATION WITH SVAT. + IF(CMODUL.EQ.'BIVAC') THEN + CALL FLDSMB(IPTRK,IPSYS,IPFLUX,LL4,ITY,NUN,NGRP,ICL1,ICL2, + 1 IMPX,IMPH,TITR,EPSOUT,MAXOUT,MAXINR,EPSINR,EVECT,FKEFF) + DO 210 IGR=1,NGRP + CALL FLDBIV(IPTRK,NEL,NUN,EVECT(1,IGR),MAT,VOL,IDL) + 210 CONTINUE + ELSE IF(CMODUL.EQ.'TRIVAC') THEN + CALL FLDDIR(IPTRK,IPSYS,IPFLUX,LL4,ITY,NUN,NGRP,ICL1,ICL2, + 1 IMPX,IMPH,TITR,EPSOUT,NADI,MAXOUT,MAXINR,EPSINR,EVECT,FKEFF) + DO 220 IGR=1,NGRP + CALL FLDTRI(IPTRK,NEL,NUN,EVECT(1,IGR),MAT,VOL,IDL) + 220 CONTINUE + ENDIF + CALL FLDNOR(IPSYS,NUN,NGRP,NEL,NBMIX,MAT,VOL,IDL,'DIRE', + 1 EVECT(1,1),DNORM) + CALL LCMPUT(IPFLUX,'K-EFFECTIVE',1,2,FKEFF) + CALL LCMPUT(IPFLUX,'K-INFINITY',1,2,FKEFF) + JPFLUX=LCMLID(IPFLUX,'FLUX',NGRP) + IF(LREL) CALL FLDREL(RELAX,JPFLUX,NGRP,NUN,EVECT(1,1)) + DO 230 IGR=1,NGRP + CALL LCMPDL(JPFLUX,IGR,NUN,2,EVECT(1,IGR)) + 230 CONTINUE + IF(.NOT.ADJ) GO TO 280 +* + IF(CMODUL.NE.'TRIVAC') CALL XABORT('FLDDRV: ADJOINT CALCULATI' + 1 //'ON IS ONLY POSSIBLE WITH TRIVAC.') +* ADJOINT FLUX INITIALIZATION. + IF(REC.AND.(IMPH.EQ.0)) THEN + CALL LCMLEN(IPFLUX,'AFLUX',ILONG,ITYLCM) + IF(ILONG.NE.NGRP) CALL XABORT('FLDDRV: UNABLE TO RECOVER AF' + 1 //'LUX.') + JPFLUX=LCMGID(IPFLUX,'AFLUX') + DO 240 IGR=1,NGRP + CALL LCMGDL(JPFLUX,IGR,EVECT(1,IGR)) + 240 CONTINUE + ELSE +* INITIAL ESTIMATE OF THE ADJOINT FLUXES. + EVECT(:NUN,:NGRP)=1.0 + ENDIF +* + CALL FLDADJ(IPTRK,IPSYS,IPFLUX,LL4,ITY,NUN,NGRP,ICL1,ICL2,IMPX, + 1 EPSOUT,NADI,MAXOUT,MAXINR,EPSINR,EVECT,FKEFF) + CALL LCMPUT(IPFLUX,'AK-EFFECTIVE',1,2,FKEFF) + CALL LCMPUT(IPFLUX,'AK-INFINITY',1,2,FKEFF) + JPFLUX=LCMLID(IPFLUX,'AFLUX',NGRP) + DO 260 IGR=1,NGRP + CALL FLDTRI(IPTRK,NEL,NUN,EVECT(1,IGR),MAT,VOL,IDL) + 260 CONTINUE + CALL FLDNOR(IPSYS,NUN,NGRP,NEL,NBMIX,MAT,VOL,IDL,'ADJO', + 1 EVECT(1,1),ANORM) + IF(LREL) CALL FLDREL(RELAX,JPFLUX,NGRP,NUN,EVECT(1,1)) + DO 270 IGR=1,NGRP + CALL LCMPDL(JPFLUX,IGR,NUN,2,EVECT(1,IGR)) + 270 CONTINUE + ENDIF +*---- +* SET STATE-VECTOR AND EPS-CONVERGE +*---- + 280 ISTATE(:NSTATE)=0 + ISTATE(1)=NGRP + ISTATE(2)=NUN + ISTATE(3)=1 + IF(ADJ) ISTATE(3)=11 + ISTATE(4)=LMOD + ISTATE(5)=0 + ISTATE(6)=2 + ISTATE(7)=0 + ISTATE(8)=ICL1 + ISTATE(9)=ICL2 + ISTATE(10)=IREBAL + ISTATE(11)=MAXINR + ISTATE(12)=MAXOUT + ISTATE(13)=NADI + ISTATE(14)=IBLSZ + ISTATE(15)=NSTARD + ISTATE(17)=NBMIX + CALL LCMPUT(IPFLUX,'STATE-VECTOR',NSTATE,1,ISTATE) + EPSCON(1)=EPSINR + EPSCON(2)=EPSOUT + EPSCON(3)=EPSOUT + EPSCON(4)=EPSMSR + EPSCON(5)=RELAX + CALL LCMPUT(IPFLUX,'EPS-CONVERGE',5,2,EPSCON) + CALL LCMPUT(IPFLUX,'KEYFLX',NEL,1,IDL) +*---- +* PRINT STATE-VECTOR +*---- + IF(IMPX.GT.0) THEN + WRITE (IOUT,300) IMPX,(ISTATE(I),I=1,9) + WRITE (IOUT,310) (ISTATE(I),I=10,15),ISTATE(17) + WRITE (IOUT,320) (EPSCON(I),I=1,5) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(EVECT) + RETURN + 300 FORMAT(/8H OPTIONS/8H -------/ + 1 7H IMPX ,I9,29H (0=NO PRINT/1=SHORT/2=MORE)/ + 2 7H NGRO ,I9,27H (NUMBER OF ENERGY GROUPS)/ + 3 7H NUN ,I9,39H (NUMBER OF UNKNOWNS PER ENERGY GROUP)/ + 4 7H IADJ ,I9,43H (1=DIRECT KEFF OR SOURCE/10=ADJOINT KEFF/, + 5 31H100=DIRECT GPT/100=ADJOINT GPT)/ + 6 7H LMOD ,I9,23H (NUMBER OF HARMONICS)/ + 7 7H NGPT ,I9,27H (NUMBER OF GPT EQUATIONS)/ + 8 7H ITYPE ,I9,46H (TYPE OF SOLUTION: 0=FIXED SOURCE/1=FIXED SO, + 9 57HURCE EIGENVALUE/2=TYPE K/3=TYPE K BUCK/4=TYPE B/5=TYPE L)/ + 1 7H ILEAK ,I9,25H (TYPE OF LEAKAGE MODEL)/ + 2 7H ICL1 ,I9,46H (NUMBER OF FREE ITERATIONS PER ACCELERATION , + 3 6HCYCLE)/ + 4 7H ICL2 ,I9,46H (NUMBER OF ACCELERATED ITERATIONS PER ACCELE, + 5 14H RATION CYCLE)) + 310 FORMAT(7H IREBAL,I9,34H (0/1: THERMAL ITERATIONS OFF/ON)/ + 1 7H MAXINR,I9,40H (MAXIMUM NUMBER OF THERMAL ITERATIONS)/ + 2 7H MAXOUT,I9,38H (MAXIMUM NUMBER OF OUTER ITERATIONS)/ + 3 7H NADI ,I9,46H (INITIAL NUMBER OF ADI ITERATIONS IN TRIVAC)/ + 4 7H IBLSZ ,I9,46H (BLOCK SIZE OF THE ARNOLDI HESSENBERG MATRIX, + 5 11H WITH IRAM)/ + 6 7H NSTARD,I9,46H (NUMBER OF RESTARTING ITERATIONS WITH GMRES , + 7 51HFOR SOLVING THE ADI-PRECONDITIONNED LINEAR SYSTEMS)/ + 8 7H NBMIX ,I9,31H (NUMBER OF MATERIAL MIXTURES)) + 320 FORMAT(7H EPSINR,1P,E9.2,29H (THERMAL ITERATION EPSILON)/ + 1 7H EPSOUT,1P,E9.2,32H (OUTER ITERATION KEFF EPSILON)/ + 2 7H EPSOUT,1P,E9.2,32H (OUTER ITERATION FLUX EPSILON)/ + 3 7H EPSMSR,1P,E9.2,33H (INNER ITERATION GMRES EPSILON)/ + 4 7H RELAX ,1P,E9.2,21H (RELAXATION FACTOR)/) + END diff --git a/Trivac/src/FLDMON.f b/Trivac/src/FLDMON.f new file mode 100755 index 0000000..8504eb9 --- /dev/null +++ b/Trivac/src/FLDMON.f @@ -0,0 +1,793 @@ +*DECK FLDMON + SUBROUTINE FLDMON (IPTRK,IPSYS,IPFLUX,LL4,ITY,NUN,NGRP,LMOD,ICL1, + 1 ICL2,IMPX,IMPH,TITR,EPS2,NADI,MAXOUT,MAXINR,EPSINR,RAND,FKEFF, + 2 EVECT,ADECT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solution of multigroup eigenvalue systems for the calculation of the +* LMOD first bi-orthogonal harmonics of the diffusion equation in +* Trivac. Use the preconditionned power method with Hotelling deflation +* and a two-parameter SVAT acceleration technique. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK L_TRACK pointer to the tracking information. +* IPSYS L_SYSTEM pointer to system matrices. +* IPFLUX L_FLUX pointer to the solution. +* LL4 order of the system matrices. +* ITY type of solution (2: classical Trivac; 3: Thomas-Raviart). +* NUN number of unknowns in each energy group. +* NGRP number of energy groups. +* LMOD number of bi-orthogonal harmonics to compute. +* ICL1 number of free iterations in one cycle of the inverse power +* method. +* ICL2 number of accelerated iterations in one cycle. +* IMPX print parameter: =0: no print ; =1: minimum printing; +* =2: iteration history is printed; =3: solution is printed. +* IMPH type of histogram processing: +* =0: no action is taken; +* =1: the flux is compared to a reference flux stored on LCM +* =2: the convergence histogram is printed; +* =3: the convergence histogram is printed with axis and +* titles. The plotting file is completed; +* =4: the convergence histogram is printed with axis, acce- +* leration factors and titles. The plotting file is +* completed. +* TITR title. +* EPS2 convergence criteria for the flux. +* NADI number of inner ADI iterations per outer iteration. +* MAXOUT maximum number of outer iterations. +* MAXINR maximum number of thermal iterations. +* EPSINR thermal iteration epsilon. +* RAND initialization flag: +* =.true. use an initial random flux; =.false. use a flat flux. +* +*Parameters: output +* FKEFF effective multiplication factor of each harmonic. +* EVECT converged direct harmonic vector. +* ADECT converged adjoint harmonic vector. +* +*References: +* A. H\'ebert, 'Preconditioning the power method for reactor +* calculations', Nucl. Sci. Eng., 94, 1 (1986). +* J. H. Wilkinson, "The algebraic eigenvalue problem", Clarendon +* Press, Oxford, p. 584, 1965. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPSYS,IPFLUX + CHARACTER TITR*72 + INTEGER LL4,ITY,NUN,NGRP,LMOD,ICL1,ICL2,IMPX,IMPH,NADI,MAXOUT, + 1 MAXINR + REAL EPS2,EPSINR,FKEFF(LMOD),EVECT(NUN,NGRP,LMOD), + 1 ADECT(NUN,NGRP,LMOD) + LOGICAL RAND +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MMAXX=250,EPS1=1.0E-5) + PARAMETER (IM=714025,ID=1366,IC=150889,RM=1.4005112E-6) + CHARACTER*12 TEXT12 + LOGICAL LOGTES + DOUBLE PRECISION AEAE,AEAG,AEAH,AGAG,AGAH,AHAH,BEBE,BEBG,BEBH, + 1 BGBG,BGBH,BHBH,AEBE,AEBG,AEBH,AGBE,AGBG,AGBH,AHBE,AHBG,AHBH, + 2 X,DXDA,DXDB,Y,DYDA,DYDB,Z,DZDA,DZDB,F,D2F(2,3),EVAL,ALP,BET,Z1, + 3 FMIN + TYPE(C_PTR) JPFLUX,KPFLUX,MPFLUX,NPFLUX + REAL ERR(MMAXX),ALPH(MMAXX),BETA(MMAXX) + DOUBLE PRECISION, PARAMETER :: ALP_TAB(24) = (/ 0.2, 0.4, 0.6, + 1 0.8, 1.0, 1.2, 1.5, 2.0, 10.0, 15.0, 20.0, 25.0, 30.0, 35.0, + 2 40.0, 45.0, 50.0, 55.0, 60.0, 65.0, 70.0, 75.0, 80.0, 85.0 /) + DOUBLE PRECISION, PARAMETER :: BET_TAB(11) = (/ -1.0, -0.8, -0.6, + 1 -0.4, -0.2, 0.0, 0.2, 0.4, 0.6, 0.8, 1.0 /) + REAL, DIMENSION(:), ALLOCATABLE :: AGAR + REAL, DIMENSION(:,:), ALLOCATABLE :: GRAD1,GRAD2,VEA1,VEA2,VEA3, + 1 VEB1,VEB2,VEB3 + REAL, DIMENSION(:), POINTER :: AGARM + TYPE(C_PTR) AGARM_PTR +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(AGAR(LL4),GRAD1(NUN,NGRP),GRAD2(NUN,NGRP),VEA1(NUN,NGRP), + 1 VEA2(NUN,NGRP),VEA3(NUN,NGRP),VEB1(NUN,NGRP),VEB2(NUN,NGRP), + 2 VEB3(NUN,NGRP)) +* +* TKT : CPU TIME FOR THE SOLUTION OF LINEAR SYSTEMS. +* TKB : CPU TIME FOR BILINEAR PRODUCT EVALUATIONS. + TKT=0.0 + TKB=0.0 + CALL MTOPEN(IMPX,IPTRK,LL4) + IF(LL4.GT.NUN) CALL XABORT('FLDMON: INVALID NUMBER OF UNKNOWNS.') +* + DO 390 IMOD=1,LMOD + CALL KDRCPU(TK1) + IF(IMPX.GE.1) WRITE (6,'(1H1//13H HARMONIC NB.,I3//)') IMOD + CALL LCMLEN(IPFLUX,'MODE',ILONG,ITYLCM) + IF((ILONG.NE.0).AND.(IMPH.EQ.0)) THEN + JPFLUX=LCMGID(IPFLUX,'MODE') + KPFLUX=LCMGIL(JPFLUX,IMOD) + MPFLUX=LCMGID(KPFLUX,'FLUX') + NPFLUX=LCMGID(KPFLUX,'AFLUX') + DO 10 IGR=1,NGRP + CALL LCMGDL(MPFLUX,IGR,EVECT(1,IGR,IMOD)) + CALL LCMGDL(NPFLUX,IGR,ADECT(1,IGR,IMOD)) + 10 CONTINUE + ELSE IF((IMOD.EQ.1).OR.(.NOT.RAND)) THEN +* UNIFORM UNKNOWN VECTOR. + DO 25 IGR=1,NGRP + DO 20 I=1,NUN + EVECT(I,IGR,IMOD)=1.0 + ADECT(I,IGR,IMOD)=1.0 + 20 CONTINUE + 25 CONTINUE + ELSE +* RANDOM UNKNOWN VECTOR. + ISEED=0 + DO 35 IGR=1,NGRP + DO 30 I=1,NUN + ISEED=MOD(ISEED*ID+IC,IM) + RAN=REAL(ISEED)*RM + EVECT(I,IGR,IMOD)=RAN + ADECT(I,IGR,IMOD)=RAN + 30 CONTINUE + 35 CONTINUE + ENDIF +*---- +* PRECONDITIONED POWER METHOD FOR THE DIRECT PROBLEM +*---- + EVAL=1.0D0 + VVV=0.0 + ISTART=1 + NNADI=NADI + TEST=0.0 + IF(IMPX.GE.1) WRITE (6,600) NADI,'DIRECT' + IF(IMPX.GE.2) WRITE (6,610) + CALL FLDDEF(NUN,IPTRK,IPSYS,LL4,ITY,NGRP,IMOD,LMOD,EVECT,ADECT, + 1 EVECT(1,1,IMOD),1,VEA1,VEB1) + CALL KDRCPU(TK2) + TKB=TKB+(TK2-TK1) + M=0 + 50 M=M+1 +*---- +* EIGENVALUE EVALUATION +*---- + CALL KDRCPU(TK1) + AEBE=0.0D0 + BEBE=0.0D0 + DO 65 IGR=1,NGRP + DO 60 I=1,LL4 + AEBE=AEBE+VEA1(I,IGR)*VEB1(I,IGR) + BEBE=BEBE+VEB1(I,IGR)**2 + 60 CONTINUE + 65 CONTINUE + EVAL=AEBE/BEBE + CALL KDRCPU(TK2) + TKB=TKB+(TK2-TK1) +*---- +* DIRECTION EVALUATION +*---- + DO 110 IGR=1,NGRP + CALL KDRCPU(TK1) + DO 70 I=1,LL4 + GRAD1(I,IGR)=REAL(EVAL)*VEB1(I,IGR)-VEA1(I,IGR) + 70 CONTINUE + DO 100 JGR=1,IGR-1 + WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 100 + IF(ITY.EQ.13) THEN + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD1(1,JGR),AGAR) + DO 80 I=1,LL4 + GRAD1(I,IGR)=GRAD1(I,IGR)+AGAR(I) + 80 CONTINUE + ELSE + CALL LCMGPD(IPSYS,TEXT12,AGARM_PTR) + CALL C_F_POINTER(AGARM_PTR,AGARM,(/ ILONG /)) + DO 90 I=1,ILONG + GRAD1(I,IGR)=GRAD1(I,IGR)+AGARM(I)*GRAD1(I,JGR) + 90 CONTINUE + ENDIF + 100 CONTINUE + CALL KDRCPU(TK2) + TKB=TKB+(TK2-TK1) +* + CALL KDRCPU(TK1) + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL FLDADI(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD1(1,IGR),NNADI) + CALL KDRCPU(TK2) + TKT=TKT+(TK2-TK1) + 110 CONTINUE +*---- +* PERFORM THERMAL (UP-SCATTERING) ITERATIONS +*---- + IF(MAXINR.GT.1) THEN + CALL FLDTHR(IPTRK,IPSYS,IPFLUX,.FALSE.,LL4,ITY,NUN,NGRP,ICL1, + 1 ICL2,IMPX,NNADI,0,MAXINR,EPSINR,ITER,TKT,TKB,GRAD1) + ENDIF +*---- +* DISPLACEMENT EVALUATION +*---- + CALL KDRCPU(TK1) + F=0.0D0 + DELS=ABS(REAL((EVAL-VVV)/EVAL)) + VVV=REAL(EVAL) +*---- +* EVALUATION OF THE TWO ACCELERATION PARAMETERS ALP AND BET +*---- + ALP=1.0D0 + BET=0.0D0 + N=0 + AEAE=0.0D0 + AEAG=0.0D0 + AEAH=0.0D0 + AGAG=0.0D0 + AGAH=0.0D0 + AHAH=0.0D0 + BEBG=0.0D0 + BEBH=0.0D0 + BGBG=0.0D0 + BGBH=0.0D0 + BHBH=0.0D0 + AEBG=0.0D0 + AEBH=0.0D0 + AGBE=0.0D0 + AGBG=0.0D0 + AGBH=0.0D0 + AHBE=0.0D0 + AHBG=0.0D0 + AHBH=0.0D0 + CALL FLDDEF(NUN,IPTRK,IPSYS,LL4,ITY,NGRP,IMOD,LMOD,EVECT,ADECT, + 1 GRAD1(1,1),1,VEA2,VEB2) + IF(1+MOD(M-ISTART,ICL1+ICL2).GT.ICL1) THEN + DO 125 IGR=1,NGRP + DO 120 I=1,LL4 +* COMPUTE (A ,A ) + AEAE=AEAE+VEA1(I,IGR)**2 + AEAG=AEAG+VEA1(I,IGR)*VEA2(I,IGR) + AEAH=AEAH+VEA1(I,IGR)*VEA3(I,IGR) + AGAG=AGAG+VEA2(I,IGR)**2 + AGAH=AGAH+VEA2(I,IGR)*VEA3(I,IGR) + AHAH=AHAH+VEA3(I,IGR)**2 +* COMPUTE (B ,B ) + BEBG=BEBG+VEB1(I,IGR)*VEB2(I,IGR) + BEBH=BEBH+VEB1(I,IGR)*VEB3(I,IGR) + BGBG=BGBG+VEB2(I,IGR)**2 + BGBH=BGBH+VEB2(I,IGR)*VEB3(I,IGR) + BHBH=BHBH+VEB3(I,IGR)**2 +* COMPUTE (A ,B ) + AEBG=AEBG+VEA1(I,IGR)*VEB2(I,IGR) + AEBH=AEBH+VEA1(I,IGR)*VEB3(I,IGR) + AGBE=AGBE+VEA2(I,IGR)*VEB1(I,IGR) + AGBG=AGBG+VEA2(I,IGR)*VEB2(I,IGR) + AGBH=AGBH+VEA2(I,IGR)*VEB3(I,IGR) + AHBE=AHBE+VEA3(I,IGR)*VEB1(I,IGR) + AHBG=AHBG+VEA3(I,IGR)*VEB2(I,IGR) + AHBH=AHBH+VEA3(I,IGR)*VEB3(I,IGR) + 120 CONTINUE + 125 CONTINUE +* + 130 N=N+1 + IF(N.GT.10) GO TO 135 +* COMPUTE X(M+1) + X=BEBE+ALP*ALP*BGBG+BET*BET*BHBH+2.0D0*(ALP*BEBG+BET*BEBH + 1 +ALP*BET*BGBH) + DXDA=2.0D0*(BEBG+ALP*BGBG+BET*BGBH) + DXDB=2.0D0*(BEBH+ALP*BGBH+BET*BHBH) +* COMPUTE Y(M+1) + Y=AEAE+ALP*ALP*AGAG+BET*BET*AHAH+2.0D0*(ALP*AEAG+BET*AEAH + 1 +ALP*BET*AGAH) + DYDA=2.0D0*(AEAG+ALP*AGAG+BET*AGAH) + DYDB=2.0D0*(AEAH+ALP*AGAH+BET*AHAH) +* COMPUTE Z(M+1) + Z=AEBE+ALP*ALP*AGBG+BET*BET*AHBH+ALP*(AEBG+AGBE) + 1 +BET*(AEBH+AHBE)+ALP*BET*(AGBH+AHBG) + DZDA=AEBG+AGBE+2.0D0*ALP*AGBG+BET*(AGBH+AHBG) + DZDB=AEBH+AHBE+ALP*(AGBH+AHBG)+2.0D0*BET*AHBH +* COMPUTE F(M+1) + F=X*Y-Z*Z + D2F(1,1)=2.0D0*(BGBG*Y+DXDA*DYDA+X*AGAG-DZDA**2-2.0D0*Z*AGBG) + D2F(1,2)=2.0D0*BGBH*Y+DXDA*DYDB+DXDB*DYDA+2.0D0*X*AGAH + 1 -2.0D0*DZDA*DZDB-2.0D0*Z*(AGBH+AHBG) + D2F(2,2)=2.0D0*(BHBH*Y+DXDB*DYDB+X*AHAH-DZDB**2-2.0D0*Z*AHBH) + D2F(2,1)=D2F(1,2) + D2F(1,3)=DXDA*Y+X*DYDA-2.0D0*Z*DZDA + D2F(2,3)=DXDB*Y+X*DYDB-2.0D0*Z*DZDB +* SOLUTION OF A LINEAR SYSTEM. + CALL ALSBD(2,1,D2F,IER,2) + IF(IER.NE.0) GO TO 135 + ALP=ALP-D2F(1,3) + BET=BET-D2F(2,3) + IF(ALP.GT.100.0) GO TO 135 + IF((ABS(D2F(1,3)).LE.1.0D-4).AND.(ABS(D2F(2,3)).LE.1.0D-4)) + 1 GO TO 140 + GO TO 130 +* +* alternative algorithm in case of Newton-Raphton failure + 135 IF(IMPX.GT.0) WRITE(6,'(/30H FLDMON: FAILURE OF THE NEWTON, + 1 55H-RAPHTON ALGORIHTHM FOR COMPUTING THE OVERRELAXATION PA, + 2 12HRAMETERS(1).)') + IAMIN=999 + IBMIN=999 + FMIN=HUGE(FMIN) + DO IA=1,SIZE(ALP_TAB) + ALP=ALP_TAB(IA) + DO IB=1,SIZE(BET_TAB) + BET=BET_TAB(IB) +* COMPUTE X + X=BEBE+ALP*ALP*BGBG+BET*BET*BHBH+2.0D0*(ALP*BEBG+BET*BEBH + 1 +ALP*BET*BGBH) +* COMPUTE Y + Y=AEAE+ALP*ALP*AGAG+BET*BET*AHAH+2.0D0*(ALP*AEAG+BET*AEAH + 1 +ALP*BET*AGAH) +* COMPUTE Z + Z=AEBE+ALP*ALP*AGBG+BET*BET*AHBH+ALP*(AEBG+AGBE) + 1 +BET*(AEBH+AHBE)+ALP*BET*(AGBH+AHBG) +* COMPUTE F + F=X*Y-Z*Z + IF(F.LT.FMIN) THEN + IAMIN=IA + IBMIN=IB + FMIN=F + ENDIF + ENDDO + ENDDO + ALP=ALP_TAB(IAMIN) + BET=BET_TAB(IBMIN) + 140 BET=BET/ALP + IF((ALP.LT.1.0D0).AND.(ALP.GT.0.0D0)) THEN + ALP=1.0D0 + BET=0.0D0 + ELSE IF(ALP.LE.0.0D0) THEN + ISTART=M+1 + ALP=1.0D0 + BET=0.0D0 + ENDIF + DO 155 IGR=1,NGRP + DO 150 I=1,LL4 + GRAD1(I,IGR)=REAL(ALP)*(GRAD1(I,IGR)+REAL(BET)*GRAD2(I,IGR)) + VEA2(I,IGR)=REAL(ALP)*(VEA2(I,IGR)+REAL(BET)*VEA3(I,IGR)) + VEB2(I,IGR)=REAL(ALP)*(VEB2(I,IGR)+REAL(BET)*VEB3(I,IGR)) + 150 CONTINUE + 155 CONTINUE + ENDIF + CALL KDRCPU(TK2) + TKB=TKB+(TK2-TK1) +* + LOGTES=(M.LT.ICL1).OR.(MOD(M-ISTART,ICL1+ICL2).EQ.ICL1-1) + IF(LOGTES.AND.(DELS.LE.EPS1)) THEN + DELT=0.0 + DO 170 IGR=1,NGRP + DELN=0.0 + DELD=0.0 + DO 160 I=1,LL4 + EVECT(I,IGR,IMOD)=EVECT(I,IGR,IMOD)+GRAD1(I,IGR) + VEA1(I,IGR)=VEA1(I,IGR)+VEA2(I,IGR) + VEB1(I,IGR)=VEB1(I,IGR)+VEB2(I,IGR) + GRAD2(I,IGR)=GRAD1(I,IGR) + VEA3(I,IGR)=VEA2(I,IGR) + VEB3(I,IGR)=VEB2(I,IGR) + DELN=MAX(DELN,ABS(VEB2(I,IGR))) + DELD=MAX(DELD,ABS(VEB1(I,IGR))) + 160 CONTINUE + IF(DELD.NE.0.0) DELT=MAX(DELT,DELN/DELD) + 170 CONTINUE + IF(IMPX.GE.2) WRITE (6,615) M,AEAE,AEAG,AEAH,AGAG,AGAH,AHAH, + 1 BEBE,ALP,BET,EVAL,F,DELS,DELT,N,BEBG,BEBH,BGBG,BGBH,BHBH, + 2 AEBE,AEBG,AEBH,AGBE,AGBG,AGBH,AHBE,AHBG,AHBH +* COMPUTE THE CONVERGENCE HISTOGRAM. + IF((IMPH.GE.1).AND.(M.LE.MMAXX)) THEN + JPFLUX=LCMGID(IPFLUX,'MODE') + KPFLUX=LCMGIL(JPFLUX,IMOD) + CALL FLDXCO(KPFLUX,LL4,NUN,EVECT(1,NGRP,IMOD),.TRUE.,ERR(M)) + ALPH(M)=REAL(ALP) + BETA(M)=REAL(BET) + ENDIF + IF(DELT.LE.EPS2) GO TO 190 + ELSE + DO 185 IGR=1,NGRP + DO 180 I=1,LL4 + EVECT(I,IGR,IMOD)=EVECT(I,IGR,IMOD)+GRAD1(I,IGR) + VEA1(I,IGR)=VEA1(I,IGR)+VEA2(I,IGR) + VEB1(I,IGR)=VEB1(I,IGR)+VEB2(I,IGR) + GRAD2(I,IGR)=GRAD1(I,IGR) + VEA3(I,IGR)=VEA2(I,IGR) + VEB3(I,IGR)=VEB2(I,IGR) + 180 CONTINUE + 185 CONTINUE + IF(IMPX.GE.2) WRITE (6,620) M,AEAE,AEAG,AEAH,AGAG,AGAH,AHAH, + 1 BEBE,ALP,BET,EVAL,F,DELS,N,BEBG,BEBH,BGBG,BGBH,BHBH,AEBE, + 2 AEBG,AEBH,AGBE,AGBG,AGBH,AHBE,AHBG,AHBH +* COMPUTE THE CONVERGENCE HISTOGRAM. + IF((IMPH.GE.1).AND.(M.LE.MMAXX)) THEN + JPFLUX=LCMGID(IPFLUX,'MODE') + KPFLUX=LCMGIL(JPFLUX,IMOD) + CALL FLDXCO(KPFLUX,LL4,NUN,EVECT(1,NGRP,IMOD),.TRUE.,ERR(M)) + ALPH(M)=REAL(ALP) + BETA(M)=REAL(BET) + ENDIF + ENDIF +* + IF(M.EQ.1) TEST=DELS + IF((M.GT.5).AND.(DELS.GT.TEST)) CALL XABORT('FLDMON: CONVERGENCE' + 1 //' FAILURE.') + IF(M.GE.MAXOUT) THEN + WRITE (6,'(/46H FLDMON: ***WARNING*** MAXIMUM NUMBER OF ITERA, + 1 17HTIONS IS REACHED.)') + GO TO 190 + ENDIF + IF(MOD(M,36).EQ.0) THEN + ISTART=M+1 + NNADI=NNADI+1 + IF(IMPX.GE.1) WRITE (6,700) NNADI + ENDIF + GO TO 50 +*---- +* DIRECT SOLUTION EDITION +*---- + 190 Z1=1.0D0/EVAL + IF(IMPX.GE.1) WRITE (6,630) 1.0D0/EVAL + IF(IMPX.EQ.1) WRITE (6,640) M + IF(IMPX.EQ.3) THEN + DO 210 IGR=1,NGRP + WRITE (6,660) 'DIRECT',IGR,(EVECT(I,IGR,IMOD),I=1,LL4) + 210 CONTINUE + ENDIF + IF(IMPH.EQ.1) THEN + JPFLUX=LCMGID(IPFLUX,'MODE') + KPFLUX=LCMGIL(JPFLUX,IMOD) + CALL LCMLEN(KPFLUX,'REF',ILONG,ITYLCM) + IF(ILONG.EQ.0) THEN + WRITE(6,'(44H FLDMON: STORE A REFERENCE THERMAL HARMONIC.)') + CALL LCMPUT(KPFLUX,'REF',NUN,2,EVECT(1,NGRP,IMOD)) + ENDIF + ELSE IF(IMPH.GE.2) THEN + JPFLUX=LCMGID(IPFLUX,'MODE') + KPFLUX=LCMGIL(JPFLUX,IMOD) + IGRAPH=0 + 215 IGRAPH=IGRAPH+1 + WRITE (TEXT12,'(5HHISTO,I3)') IGRAPH + CALL LCMLEN (KPFLUX,TEXT12,ILENG,ITYLCM) + IF(ILENG.EQ.0) THEN + MM=MIN(M,MMAXX) + CALL LCMSIX (KPFLUX,TEXT12,1) + CALL LCMPTC (KPFLUX,'HTITLE',72,TITR) + CALL LCMPUT (KPFLUX,'ALPHA',MM,2,ALPH) + CALL LCMPUT (KPFLUX,'BETA',MM,2,BETA) + CALL LCMPUT (KPFLUX,'ERROR',MM,2,ERR) + CALL LCMPUT (KPFLUX,'IMPH',1,1,IMPH) + CALL LCMSIX (KPFLUX,' ',2) + ELSE + GO TO 215 + ENDIF + ENDIF +*---- +* PRECONDITIONED POWER METHOD FOR THE ADJOINT PROBLEM +*---- + CALL KDRCPU(TK1) + EVAL=1.0D0 + VVV=0.0 + ISTART=1 + NNADI=NADI + TEST=0.0 + IF(IMPX.GE.1) WRITE (6,600) NADI,'ADJOINT' + IF(IMPX.GE.2) WRITE (6,610) + CALL FLDDEF(NUN,IPTRK,IPSYS,LL4,ITY,NGRP,IMOD,LMOD,EVECT,ADECT, + 1 ADECT(1,1,IMOD),2,VEA1,VEB1) + CALL KDRCPU(TK2) + TKB=TKB+(TK2-TK1) + M=0 + 220 M=M+1 +*---- +* EIGENVALUE CALCULATION +*---- + CALL KDRCPU(TK1) + AEBE=0.0D0 + BEBE=0.0D0 + DO 235 IGR=1,NGRP + DO 230 I=1,LL4 + AEBE=AEBE+VEA1(I,IGR)*VEB1(I,IGR) + BEBE=BEBE+VEB1(I,IGR)**2 + 230 CONTINUE + 235 CONTINUE + EVAL=AEBE/BEBE + CALL KDRCPU(TK2) + TKB=TKB+(TK2-TK1) +*---- +* DIRECTION EVALUATION +*---- + DO 280 IGR=NGRP,1,-1 + CALL KDRCPU(TK1) + DO 240 I=1,LL4 + GRAD1(I,IGR)=REAL(EVAL)*VEB1(I,IGR)-VEA1(I,IGR) + 240 CONTINUE + DO 270 JGR=NGRP,IGR+1,-1 + WRITE(TEXT12,'(1HA,2I3.3)') JGR,IGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 270 + IF(ITY.EQ.13) THEN + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD1(1,JGR),AGAR) + DO 250 I=1,LL4 + GRAD1(I,IGR)=GRAD1(I,IGR)+AGAR(I) + 250 CONTINUE + ELSE + CALL LCMGPD(IPSYS,TEXT12,AGARM_PTR) + CALL C_F_POINTER(AGARM_PTR,AGARM,(/ ILONG /)) + DO 260 I=1,ILONG + GRAD1(I,IGR)=GRAD1(I,IGR)+AGARM(I)*GRAD1(I,JGR) + 260 CONTINUE + ENDIF + 270 CONTINUE + CALL KDRCPU(TK2) + TKB=TKB+(TK2-TK1) +* + CALL KDRCPU(TK1) + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL FLDADI(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD1(1,IGR),NNADI) + CALL KDRCPU(TK2) + TKT=TKT+(TK2-TK1) + 280 CONTINUE +*---- +* PERFORM THERMAL (UP-SCATTERING) ITERATIONS +*---- + IF(MAXINR.GT.1) THEN + CALL FLDTHR(IPTRK,IPSYS,IPFLUX,.TRUE.,LL4,ITY,NUN,NGRP,ICL1, + 1 ICL2,IMPX,NNADI,0,MAXINR,EPSINR,ITER,TKT,TKB,GRAD1) + ENDIF +*---- +* DISPLACEMENT EVALUATION +*---- + CALL KDRCPU(TK1) + F=0.0D0 + DELS=ABS(REAL((EVAL-VVV)/EVAL)) + VVV=REAL(EVAL) +*---- +* EVALUATION OF THE TWO ACCELERATION PARAMETERS ALP AND BET +*---- + ALP=1.0D0 + BET=0.0D0 + N=0 + AEAE=0.0D0 + AEAG=0.0D0 + AEAH=0.0D0 + AGAG=0.0D0 + AGAH=0.0D0 + AHAH=0.0D0 + BEBG=0.0D0 + BEBH=0.0D0 + BGBG=0.0D0 + BGBH=0.0D0 + BHBH=0.0D0 + AEBG=0.0D0 + AEBH=0.0D0 + AGBE=0.0D0 + AGBG=0.0D0 + AGBH=0.0D0 + AHBE=0.0D0 + AHBG=0.0D0 + AHBH=0.0D0 + CALL FLDDEF(NUN,IPTRK,IPSYS,LL4,ITY,NGRP,IMOD,LMOD,EVECT,ADECT, + 1 GRAD1(1,1),2,VEA2,VEB2) + IF(1+MOD(M-ISTART,ICL1+ICL2).GT.ICL1) THEN + DO 295 IGR=1,NGRP + DO 290 I=1,LL4 +* COMPUTE (A ,A ) + AEAE=AEAE+VEA1(I,IGR)**2 + AEAG=AEAG+VEA1(I,IGR)*VEA2(I,IGR) + AEAH=AEAH+VEA1(I,IGR)*VEA3(I,IGR) + AGAG=AGAG+VEA2(I,IGR)**2 + AGAH=AGAH+VEA2(I,IGR)*VEA3(I,IGR) + AHAH=AHAH+VEA3(I,IGR)**2 +* COMPUTE (B ,B ) + BEBG=BEBG+VEB1(I,IGR)*VEB2(I,IGR) + BEBH=BEBH+VEB1(I,IGR)*VEB3(I,IGR) + BGBG=BGBG+VEB2(I,IGR)**2 + BGBH=BGBH+VEB2(I,IGR)*VEB3(I,IGR) + BHBH=BHBH+VEB3(I,IGR)**2 +* COMPUTE (A ,B ) + AEBG=AEBG+VEA1(I,IGR)*VEB2(I,IGR) + AEBH=AEBH+VEA1(I,IGR)*VEB3(I,IGR) + AGBE=AGBE+VEA2(I,IGR)*VEB1(I,IGR) + AGBG=AGBG+VEA2(I,IGR)*VEB2(I,IGR) + AGBH=AGBH+VEA2(I,IGR)*VEB3(I,IGR) + AHBE=AHBE+VEA3(I,IGR)*VEB1(I,IGR) + AHBG=AHBG+VEA3(I,IGR)*VEB2(I,IGR) + AHBH=AHBH+VEA3(I,IGR)*VEB3(I,IGR) + 290 CONTINUE + 295 CONTINUE +* + 300 N=N+1 + IF(N.GT.10) GO TO 305 +* COMPUTE X(M+1) + X=BEBE+ALP*ALP*BGBG+BET*BET*BHBH+2.0D0*(ALP*BEBG+BET*BEBH + 1 +ALP*BET*BGBH) + DXDA=2.0D0*(BEBG+ALP*BGBG+BET*BGBH) + DXDB=2.0D0*(BEBH+ALP*BGBH+BET*BHBH) +* COMPUTE Y(M+1) + Y=AEAE+ALP*ALP*AGAG+BET*BET*AHAH+2.0D0*(ALP*AEAG+BET*AEAH + 1 +ALP*BET*AGAH) + DYDA=2.0D0*(AEAG+ALP*AGAG+BET*AGAH) + DYDB=2.0D0*(AEAH+ALP*AGAH+BET*AHAH) +* COMPUTE Z(M+1) + Z=AEBE+ALP*ALP*AGBG+BET*BET*AHBH+ALP*(AEBG+AGBE) + 1 +BET*(AEBH+AHBE)+ALP*BET*(AGBH+AHBG) + DZDA=AEBG+AGBE+2.0D0*ALP*AGBG+BET*(AGBH+AHBG) + DZDB=AEBH+AHBE+ALP*(AGBH+AHBG)+2.0D0*BET*AHBH +* COMPUTE F(M+1) + F=X*Y-Z*Z + D2F(1,1)=2.0D0*(BGBG*Y+DXDA*DYDA+X*AGAG-DZDA**2-2.0D0*Z*AGBG) + D2F(1,2)=2.0D0*BGBH*Y+DXDA*DYDB+DXDB*DYDA+2.0D0*X*AGAH + 1 -2.0D0*DZDA*DZDB-2.0D0*Z*(AGBH+AHBG) + D2F(2,2)=2.0D0*(BHBH*Y+DXDB*DYDB+X*AHAH-DZDB**2-2.0D0*Z*AHBH) + D2F(2,1)=D2F(1,2) + D2F(1,3)=DXDA*Y+X*DYDA-2.0D0*Z*DZDA + D2F(2,3)=DXDB*Y+X*DYDB-2.0D0*Z*DZDB +* SOLUTION OF A LINEAR SYSTEM. + CALL ALSBD(2,1,D2F,IER,2) + IF(IER.NE.0) GO TO 305 + ALP=ALP-D2F(1,3) + BET=BET-D2F(2,3) + IF(ALP.GT.100.0) GO TO 305 + IF((ABS(D2F(1,3)).LE.1.0D-4).AND.(ABS(D2F(2,3)).LE.1.0D-4)) + 1 GO TO 310 + GO TO 300 +* +* alternative algorithm in case of Newton-Raphton failure + 305 IF(IMPX.GT.0) WRITE(6,'(/30H FLDMON: FAILURE OF THE NEWTON, + 1 55H-RAPHTON ALGORIHTHM FOR COMPUTING THE OVERRELAXATION PA, + 2 12HRAMETERS(2).)') + IAMIN=999 + IBMIN=999 + FMIN=HUGE(FMIN) + DO IA=1,SIZE(ALP_TAB) + ALP=ALP_TAB(IA) + DO IB=1,SIZE(BET_TAB) + BET=BET_TAB(IB) +* COMPUTE X + X=BEBE+ALP*ALP*BGBG+BET*BET*BHBH+2.0D0*(ALP*BEBG+BET*BEBH + 1 +ALP*BET*BGBH) +* COMPUTE Y + Y=AEAE+ALP*ALP*AGAG+BET*BET*AHAH+2.0D0*(ALP*AEAG+BET*AEAH + 1 +ALP*BET*AGAH) +* COMPUTE Z + Z=AEBE+ALP*ALP*AGBG+BET*BET*AHBH+ALP*(AEBG+AGBE) + 1 +BET*(AEBH+AHBE)+ALP*BET*(AGBH+AHBG) +* COMPUTE F + F=X*Y-Z*Z + IF(F.LT.FMIN) THEN + IAMIN=IA + IBMIN=IB + FMIN=F + ENDIF + ENDDO + ENDDO + ALP=ALP_TAB(IAMIN) + BET=BET_TAB(IBMIN) + 310 BET=BET/ALP +* + IF((ALP.LT.1.0D0).AND.(ALP.GT.0.0D0)) THEN + ALP=1.0D0 + BET=0.0D0 + ELSE IF(ALP.LE.0.0D0) THEN + ISTART=M+1 + ALP=1.0D0 + BET=0.0D0 + ENDIF + DO 325 IGR=1,NGRP + DO 320 I=1,LL4 + GRAD1(I,IGR)=REAL(ALP)*(GRAD1(I,IGR)+REAL(BET)*GRAD2(I,IGR)) + VEA2(I,IGR)=REAL(ALP)*(VEA2(I,IGR)+REAL(BET)*VEA3(I,IGR)) + VEB2(I,IGR)=REAL(ALP)*(VEB2(I,IGR)+REAL(BET)*VEB3(I,IGR)) + 320 CONTINUE + 325 CONTINUE + ENDIF + CALL KDRCPU(TK2) + TKB=TKB+(TK2-TK1) +* + LOGTES=(M.LT.ICL1).OR.(MOD(M-ISTART,ICL1+ICL2).EQ.ICL1-1) + IF(LOGTES.AND.(DELS.LE.EPS1))THEN + DELT=0.0 + DO 340 IGR=1,NGRP + DELN=0.0 + DELD=0.0 + DO 330 I=1,LL4 + ADECT(I,IGR,IMOD)=ADECT(I,IGR,IMOD)+GRAD1(I,IGR) + VEA1(I,IGR)=VEA1(I,IGR)+VEA2(I,IGR) + VEB1(I,IGR)=VEB1(I,IGR)+VEB2(I,IGR) + GRAD2(I,IGR)=GRAD1(I,IGR) + VEA3(I,IGR)=VEA2(I,IGR) + VEB3(I,IGR)=VEB2(I,IGR) + DELN=MAX(DELN,ABS(VEB2(I,IGR))) + DELD=MAX(DELD,ABS(VEB1(I,IGR))) + 330 CONTINUE + IF(DELD.NE.0.0) DELT=MAX(DELT,DELN/DELD) + 340 CONTINUE + IF(IMPX.GE.2) WRITE (6,615) M,AEAE,AEAG,AEAH,AGAG,AGAH,AHAH, + 1 BEBE,ALP,BET,EVAL,F,DELS,DELT,N,BEBG,BEBH,BGBG,BGBH,BHBH,AEBE, + 2 AEBG,AEBH,AGBE,AGBG,AGBH,AHBE,AHBG,AHBH + IF(DELT.LE.EPS2) GO TO 360 + ELSE + DO 355 IGR=1,NGRP + DO 350 I=1,LL4 + ADECT(I,IGR,IMOD)=ADECT(I,IGR,IMOD)+GRAD1(I,IGR) + VEA1(I,IGR)=VEA1(I,IGR)+VEA2(I,IGR) + VEB1(I,IGR)=VEB1(I,IGR)+VEB2(I,IGR) + GRAD2(I,IGR)=GRAD1(I,IGR) + VEA3(I,IGR)=VEA2(I,IGR) + VEB3(I,IGR)=VEB2(I,IGR) + 350 CONTINUE + 355 CONTINUE + IF(IMPX.GE.2) WRITE (6,620) M,AEAE,AEAG,AEAH,AGAG,AGAH,AHAH, + 1 BEBE,ALP,BET,EVAL,F,DELS,N,BEBG,BEBH,BGBG,BGBH,BHBH,AEBE, + 2 AEBG,AEBH,AGBE,AGBG,AGBH,AHBE,AHBG,AHBH + ENDIF + IF(M.EQ.1) TEST=DELS + IF((M.GT.5).AND.(DELS.GT.TEST)) CALL XABORT('FLDMON: CONVERGENCE' + 1 //' FAILURE.') + IF(M.GE.MAXOUT) THEN + WRITE (6,'(/46H FLDMON: ***WARNING*** MAXIMUM NUMBER OF ITERA, + 1 17HTIONS IS REACHED.)') + GO TO 360 + ENDIF + IF(MOD(M,36).EQ.0) THEN + ISTART=M+1 + NNADI=NNADI+1 + IF(IMPX.GE.1) WRITE (6,700) NNADI + ENDIF + GO TO 220 +*---- +* ADJOINT SOLUTION EDITION +*---- + 360 IF(IMPX.GE.1) WRITE (6,630) 1.0D0/EVAL + IF(IMPX.EQ.1) WRITE (6,640) M + IF(IMPX.EQ.3) THEN + DO 380 IGR=1,NGRP + WRITE (6,660) 'ADJOINT',IGR,(ADECT(I,IGR,IMOD),I=1,LL4) + 380 CONTINUE + ENDIF +* + IF(ABS(Z1-1.0D0/EVAL).GT.1.0E-4) CALL XABORT('FLDMON: FAILURE O' + 1 //'F HARMONIC COMPUTATION.') + FKEFF(IMOD)=REAL(0.5D0*(Z1+1.0D0/EVAL)) + 390 CONTINUE + IF(IMPX.GE.1) THEN + WRITE (6,650) TKT,TKB,TKT+TKB + WRITE (6,670) (FKEFF(IMOD),IMOD=1,LMOD) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(AGAR,GRAD1,GRAD2,VEA1,VEA2,VEA3,VEB1,VEB2,VEB3) + RETURN +* + 600 FORMAT(1H1/50H FLDMON: ITERATIVE PROCEDURE BASED ON PRECONDITION, + 1 17HED POWER METHOD (,I2,37H ADI ITERATIONS PER OUTER ITERATION)./ + 2 9X,A7,10H EQUATION.) + 610 FORMAT(//5X,17HBILINEAR PRODUCTS,48X,5HALPHA,3X,4HBETA,3X, + 1 12HEIGENVALUE..,12X,8HACCURACY,11(1H.),2X,1HN) + 615 FORMAT(1X,I3,1P,7E9.1,0P,2F8.3,E14.6,3E10.2,I4/(4X,1P,7E9.1)) + 620 FORMAT(1X,I3,1P,7E9.1,0P,2F8.3,E14.6,2E10.2,10X,I4/(4X,1P,7E9.1)) + 630 FORMAT(/42H FLDMON: EFFECTIVE MULTIPLICATION FACTOR =,1P,D17.10/) + 640 FORMAT(/23H FLDMON: CONVERGENCE IN,I5,12H ITERATIONS.) + 650 FORMAT(/53H FLDMON: CPU TIME USED TO SOLVE THE TRIANGULAR LINEAR, + 1 10H SYSTEMS =,F10.3/23X,34HTO COMPUTE THE BILINEAR PRODUCTS =, + 2 F10.3,20X,16HTOTAL CPU TIME =,F10.3) + 660 FORMAT(//9H FLDMON: ,A7,37H EIGENVECTOR CORRESPONDING TO THE GRO, + 1 2HUP,I4//(5X,1P,8E14.5)) + 670 FORMAT(//21H FLDMON: EIGENVALUES:/(5X,1P,E17.10)) + 700 FORMAT(/53H FLDMON: INCREASING THE NUMBER OF INNER ITERATIONS TO, + 1 I3,36H ADI ITERATIONS PER OUTER ITERATION./) + END diff --git a/Trivac/src/FLDMRA.f90 b/Trivac/src/FLDMRA.f90 new file mode 100755 index 0000000..ba42c07 --- /dev/null +++ b/Trivac/src/FLDMRA.f90 @@ -0,0 +1,181 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! GMRES(m) linear equation solver. +! +!Copyright: +! Copyright (c) 2019 Ecole Polytechnique de Montreal +! this library is free software; you can redistribute it and/or +! modify it under the terms of the gnu lesser general public +! license as published by the free software foundation; either +! version 2.1 of the license, or (at your option) any later version +! +!Author(s): A. Hebert +! +!Reference: +! based on a Matlab script by C. T. Kelley, July 10, 1994. +! +!Parameters: input +! B fixed source +! atv function pointer for the matrix-vector product returning +! X+M*(B-A*X) where X is the unknown and B is the source. +! The format for atv is "Y=atv(X,B,n,...)" +! n order of matrix A +! ertol iteration convergence criterion +! nstart restarts the GMRES method every nstart iterations +! maxit maximum number of GMRES iterations. +! impx print parameter: =0: no print; =1: minimum printing. +! iptrk L_TRACK pointer to the tracking information +! ipsys L_SYSTEM pointer to system matrices +! ipflux L_FLUX pointer to the solution +! +!Parameters: input/output +! X initial estimate / solution of the linear system. +! +!Parameters: output +! iter actual number of iterations +! +!---------------------------------------------------------------------------- +! +subroutine FLDMRA(B,atv,n,ertol,nstart,maxit,impx,iptrk,ipsys,ipflux,X,iter) + use GANLIB + implicit real(kind=8) (a-h,o-z) + !---- + ! subroutine arguments + !---- + real(kind=8), dimension(n), intent(in) :: B + integer, intent(in) :: nstart,maxit,impx + real(kind=8), intent(in) :: ertol + interface + function atv(X,B,n,iptrk,ipsys,ipflux) result(Y) + use GANLIB + integer, intent(in) :: n + real(kind=8), dimension(n), intent(in) :: X, B + real(kind=8), dimension(n) :: Y + type(c_ptr) iptrk,ipsys,ipflux + end function atv + end interface + real(kind=8), dimension(n), intent(inout) :: X + integer, intent(out) :: iter + type(c_ptr) iptrk,ipsys,ipflux + !---- + ! local variables + !---- + integer, parameter :: iunout=6 + !---- + ! allocatable arays + !---- + real(kind=8), allocatable, dimension(:) :: r,qq,g,c,s + real(kind=8), allocatable, dimension(:,:) :: v,h + !---- + ! scratch storage allocation + !---- + allocate(v(n,nstart+1),g(nstart+1),h(nstart+1,nstart+1), & + c(nstart+1),s(nstart+1)) + !---- + ! global GMRES(m) iteration. + !---- + allocate(r(n),qq(n)) + eps1=ertol*sqrt(dot_product(B(:n),B(:n))) + rho=1.0d10 + iter=0 + do while((rho > eps1).and.(iter < maxit)) + r(:)=atv(X,B,n,iptrk,ipsys,ipflux)-X(:) + rho=sqrt(dot_product(r(:n),r(:n))) + !---- + ! test for termination on entry + !---- + if(rho < eps1) then + deallocate(qq,r) + go to 100 + endif + ! + g(:nstart+1)=0.0d0 + h(:nstart,:nstart)=0.0d0 + v(:n,:nstart+1)=0.0d0 + c(:nstart+1)=0.0d0 + s(:nstart+1)=0.0d0 + g(1)=rho + v(:n,1)=r(:n)/rho + !---- + ! gmres(1) iteration + !---- + k=0 + do while((rho > eps1).and.(k < nstart).and.(iter < maxit)) + k=k+1 + iter=iter+1 + if(impx > 2) write(iunout,200) iter,rho,eps1 + qq(:n)=0.0d0 + r(:)=atv(v(:,k),qq,n,iptrk,ipsys,ipflux) + v(:n,k+1)=v(:n,k)-r(:n) + !---- + ! modified Gram-Schmidt + !---- + do j=1,k + hr=dot_product(v(:n,j),v(:n,k+1)) + h(j,k)=hr + v(:n,k+1)=v(:n,k+1)-hr*v(:n,j) + enddo + h(k+1,k)=sqrt(dot_product(v(:n,k+1),v(:n,k+1))) + !---- + ! reorthogonalize + !---- + do j=1,k + hr=dot_product(v(:n,j),v(:n,k+1)) + h(j,k)=h(j,k)+hr + v(:n,k+1)=v(:n,k+1)-hr*v(:n,j) + enddo + h(k+1,k)=sqrt(dot_product(v(:n,k+1),v(:n,k+1))) + !---- + ! watch out for happy breakdown + !---- + if(h(k+1,k) /= 0.0) then + v(:n,k+1)=v(:n,k+1)/h(k+1,k) + endif + !---- + ! form and store the information for the new Givens rotation + !---- + do i=1,k-1 + w1=c(i)*h(i,k)-s(i)*h(i+1,k) + w2=s(i)*h(i,k)+c(i)*h(i+1,k) + h(i,k)=w1 + h(i+1,k)=w2 + enddo + znu=sqrt(h(k,k)**2+h(k+1,k)**2) + if(znu /= 0.0) then + c(k)=h(k,k)/znu + s(k)=-h(k+1,k)/znu + h(k,k)=c(k)*h(k,k)-s(k)*h(k+1,k) + h(k+1,k)=0.0d0 + w1=c(k)*g(k)-s(k)*g(k+1) + w2=s(k)*g(k)+c(k)*g(k+1) + g(k)=w1 + g(k+1)=w2 + endif + !---- + ! update the residual norm + !---- + rho=abs(g(k+1)) + enddo + !---- + ! at this point either k > nstart or rho < eps1. + ! it's time to compute x and cycle. + !---- + h(:k,k+1)=g(:k) + call ALSBD(k,1,h,ier,nstart+1) + if(ier /= 0) call XABORT('FLDMRA: singular matrix.') + do i=1,n + X(i)=X(i)+dot_product(v(i,:k),h(:k,k+1)) + enddo + enddo + deallocate(qq,r) + !---- + ! scratch storage deallocation + !---- + 100 deallocate(s,c,h,g,v) + return + ! + 200 format(24h FLDMRA: outer iteration,i4,10h L2 norm=,1p,e11.4, & + 6h eps1=,e11.4) +end subroutine FLDMRA diff --git a/Trivac/src/FLDNOR.f b/Trivac/src/FLDNOR.f new file mode 100755 index 0000000..cb782f1 --- /dev/null +++ b/Trivac/src/FLDNOR.f @@ -0,0 +1,92 @@ +*DECK FLDNOR + SUBROUTINE FLDNOR(IPSYS,NUN,NGRP,NEL,NBMIX,MAT,VOL,IDL,HTYPE, + 1 EVECT,FNORM) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Normalization of the neutron flux +* +*Copyright: +* Copyright (C) 2010 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPSYS L_SYSTEM pointer to the system matrices. +* NUN number of flux unknowns per energy group. +* NGRP number of energy groups. +* NEL number of finite elements. +* NBMIX number of material mixtures. +* MAT material mixture indices per finite element. +* VOL volumes of the finite elements. +* IDL position of averaged flux in neutron flux unknowns. +* HTYPE type of flux: 'DIRE' or 'ADJO' +* EVECT neutron flux unknowns. +* +*Parameters: output +* EVECT normalized flux. +* FNORM normalization factor. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPSYS + INTEGER NUN,NGRP,NEL,NBMIX,MAT(NEL),IDL(NEL) + CHARACTER*4 HTYPE + REAL VOL(NEL),EVECT(NUN,NGRP),FNORM +*---- +* LOCAL VARIABLES +*---- + CHARACTER*12 TEXT12 + REAL, DIMENSION(:), ALLOCATABLE :: SGD +*---- +* COMPUTE THE POWER INTEGRAL +*---- + POWER=0.0 + IF(HTYPE.EQ.'DIRE') THEN + ALLOCATE(SGD(NBMIX)) + DO 25 IGR=1,NGRP + DO 20 JGR=1,NGRP + WRITE(TEXT12,'(4HFISS,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 20 + IF(ILONG.GT.NBMIX) CALL XABORT('FLDNOR: NBMIX OVERFLOW.') + CALL LCMGET(IPSYS,TEXT12,SGD) + DO 10 IEL=1,NEL + IND=IDL(IEL) + IBM=MAT(IEL) + IF(IND.EQ.0) GO TO 10 + POWER=POWER+VOL(IEL)*SGD(IBM)*EVECT(IND,JGR) + 10 CONTINUE + 20 CONTINUE + 25 CONTINUE + DEALLOCATE(SGD) + ELSE IF(HTYPE.EQ.'ADJO') THEN + DO 35 JGR=1,NGRP + DO 30 IEL=1,NEL + IND=IDL(IEL) + IF(IND.EQ.0) GO TO 30 + POWER=POWER+VOL(IEL)*EVECT(IND,JGR) + 30 CONTINUE + 35 CONTINUE + ENDIF + IF(POWER.EQ.0.0) CALL XABORT('FLDNOR: UNABLE TO NORMALIZE.') + FNORM=1.0/POWER +*---- +* NORMALIZE THE FLUX +*---- + DO 45 IND=1,NUN + DO 40 IGR=1,NGRP + EVECT(IND,IGR)=EVECT(IND,IGR)*FNORM + 40 CONTINUE + 45 CONTINUE + RETURN + END diff --git a/Trivac/src/FLDONE.f b/Trivac/src/FLDONE.f new file mode 100755 index 0000000..3d9f6b2 --- /dev/null +++ b/Trivac/src/FLDONE.f @@ -0,0 +1,87 @@ +*DECK FLDONE + FUNCTION FLDONE(X,B,N,IPTRK,IPSYS,IPFLUX) RESULT(Y) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Computation of a single X+M*(B-A*X) iteration in TRIVAC. +* +*Copyright: +* Copyright (C) 2020 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* X initial flux. +* B fixed source. +* N number of unknowns in the flux. +* IPTRK L_TRACK pointer to the tracking information. +* IPSYS L_SYSTEM pointer to system matrices. +* IPFLUX L_FLUX pointer to the solution. +* +*Parameters: output +* Y flux at the next iteration. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER, INTENT(IN) :: N + REAL(KIND=8), DIMENSION(N), INTENT(IN) :: X, B + REAL(KIND=8), DIMENSION(N) :: Y + TYPE(C_PTR) IPTRK,IPSYS,IPFLUX +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + INTEGER ISTATE(NSTATE) + CHARACTER*12 TEXT12 + REAL, DIMENSION(:), ALLOCATABLE :: WORK1,WORK2,GAR +* + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + NLF=ISTATE(30) + CALL LCMGET(IPSYS,'STATE-VECTOR',ISTATE) + NGRP=ISTATE(1) + LL4=ISTATE(2) + ITY=ISTATE(4) + NBMIX=ISTATE(7) + NAN=ISTATE(8) + IF(ITY.EQ.13) LL4=LL4*NLF/2 ! SPN cases + CALL LCMGET(IPFLUX,'STATE-VECTOR',ISTATE) + IGR=ISTATE(39) + IF(LL4.NE.N) CALL XABORT('FLDONE: INCONSISTENT UNKNOWNS.') +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(WORK1(LL4),WORK2(LL4)) + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + WORK1(:LL4)=REAL(B(:LL4)) + WORK2(:LL4)=REAL(X(:LL4)) + IF(ITY.EQ.2) THEN +* CLASSICAL TREATMENT + ALLOCATE(GAR(LL4)) + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,WORK2,GAR) + GAR(:LL4)=WORK1(:LL4)-GAR(:LL4) + CALL MTLDLS(TEXT12,IPTRK,IPSYS,LL4,ITY,GAR) + WORK2(:LL4)=WORK2(:LL4)+GAR(:LL4) + DEALLOCATE(GAR) + ELSE IF(ITY.EQ.3) THEN +* THOMAS-RAVIART/DIFFUSION TRIVAC TRACKING. + CALL FLDTRS(TEXT12,IPTRK,IPSYS,LL4,WORK1,WORK2,1) + ELSE IF(ITY.EQ.13) THEN +* THOMAS-RAVIART/SIMPLIFIED PN TRIVAC TRACKING. + IF(NAN.EQ.0) CALL XABORT('FLDONE: SPN-ONLY ALGORITHM(2).') + CALL FLDSPN(TEXT12,IPTRK,IPSYS,LL4,NBMIX,NAN,WORK1,WORK2,1) + ELSE + CALL XABORT('FLDONE: INVALID TYPE.') + ENDIF + Y(:LL4)=WORK2(:LL4) + DEALLOCATE(WORK2,WORK1) + RETURN + END FUNCTION FLDONE diff --git a/Trivac/src/FLDORT.f b/Trivac/src/FLDORT.f new file mode 100755 index 0000000..41d7ff0 --- /dev/null +++ b/Trivac/src/FLDORT.f @@ -0,0 +1,145 @@ +*DECK FLDORT + SUBROUTINE FLDORT(IPSYS,IPFLUX,NUN,NGRP,LMOD) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Test the biorthogonality of the direct-CADjoint eigenvectors. +* +*Copyright: +* Copyright (C) 2020 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPSYS L_SYSTEM pointer to system matrices. +* IPFLUX L_FLUX pointer to the solution. +* NUN number of unknowns in each energy group. +* NGRP number of energy groups. +* LMOD number of orthogonal harmonics to compute. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPSYS,IPFLUX + INTEGER NUN,NGRP,LMOD +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + INTEGER ISTATE(NSTATE) + CHARACTER TEXT12*12,HSMG*131 + TYPE(C_PTR) JPFLUX,KPFLUX,MPFLUX + REAL, DIMENSION(:), POINTER :: AGARM + TYPE(C_PTR) AGARM_PTR +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, DIMENSION(:), ALLOCATABLE :: GAR + COMPLEX, DIMENSION(:,:,:), ALLOCATABLE :: CEV,CAD + COMPLEX(KIND=8), DIMENSION(:,:), ALLOCATABLE :: DWORK,ORTHO +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(DWORK(NUN,NGRP),CEV(NUN,NGRP,LMOD),CAD(NUN,NGRP,LMOD), + 1 ORTHO(LMOD,LMOD),GAR(NUN)) +*---- +* FLUX RECOVERY +*---- + CALL LCMLEN(IPFLUX,'MODE',ILONG,ITYLCM) + IF((ILONG.EQ.0).AND.(LMOD.EQ.1)) THEN + MPFLUX=LCMGID(IPFLUX,'AFLUX') + DO IGR=1,NGRP + CALL LCMGDL(MPFLUX,IGR,GAR) + CAD(:NUN,IGR,1)=GAR(:NUN) + ENDDO + MPFLUX=LCMGID(IPFLUX,'FLUX') + DO IGR=1,NGRP + CALL LCMGDL(MPFLUX,IGR,GAR) + CEV(:NUN,IGR,1)=GAR(:NUN) + ENDDO + ELSE IF(ILONG.GT.0) THEN + DO IMOD=1,LMOD + JPFLUX=LCMGID(IPFLUX,'MODE') + CALL LCMLEL(JPFLUX,IMOD,ILONG,ITYLCM) + IF(ILONG.EQ.0) THEN + WRITE(6,'(20HFLDORT: MISSING MODE,I4,1H.)') IMOD + CALL XABORT(HSMG) + ENDIF + KPFLUX=LCMGIL(JPFLUX,IMOD) + MPFLUX=LCMGID(KPFLUX,'AFLUX') + DO IGR=1,NGRP + CALL LCMLEL(MPFLUX,IGR,ILONG,ITYLCM) + IF(ITYLCM.EQ.2) THEN + CALL LCMGDL(MPFLUX,IGR,GAR) + CAD(:NUN,IGR,IMOD)=GAR(:NUN) + ELSE IF(ITYLCM.EQ.6) THEN + CALL LCMGDL(MPFLUX,IGR,CAD(1,IGR,IMOD)) + ENDIF + ENDDO + MPFLUX=LCMGID(KPFLUX,'FLUX') + DO IGR=1,NGRP + CALL LCMLEL(MPFLUX,IGR,ILONG,ITYLCM) + IF(ITYLCM.EQ.2) THEN + CALL LCMGDL(MPFLUX,IGR,GAR) + CEV(:NUN,IGR,IMOD)=GAR(:NUN) + ELSE IF(ITYLCM.EQ.6) THEN + CALL LCMGDL(MPFLUX,IGR,CEV(1,IGR,IMOD)) + ENDIF + ENDDO + ENDDO + ELSE + CALL XABORT('FLDORT: MODE INFORMATION MISSING.') + ENDIF +*---- +* MULTIPLY FLUX WITH B MATRIX +*---- + CALL LCMGET(IPSYS,'STATE-VECTOR',ISTATE) + LL4=ISTATE(2) + DO JMOD=1,LMOD + DWORK(:NUN,:NGRP)=0.0D0 + DO IGR=1,NGRP + DO JGR=1,NGRP + WRITE(TEXT12,'(1HB,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) CYCLE + CALL LCMGPD(IPSYS,TEXT12,AGARM_PTR) + CALL C_F_POINTER(AGARM_PTR,AGARM,(/ ILONG /)) + DO I=1,ILONG + DWORK(I,IGR)=DWORK(I,IGR)+CMPLX(AGARM(I)*CEV(I,JGR,JMOD)) + ENDDO + ENDDO + ENDDO +*---- +* COMPUTE ORTHONORMAL MATRIX +*---- + DO IMOD=1,LMOD + ORTHO(IMOD,JMOD)=0.0D0 + DO I=1,LL4 + DO IGR=1,NGRP + ORTHO(IMOD,JMOD)=ORTHO(IMOD,JMOD)+CAD(I,IGR,IMOD)* + 1 DWORK(I,IGR) + ENDDO + ENDDO + ENDDO + ENDDO +*---- +* PRINT ORTHONORMAL MATRIX +*---- + WRITE(6,'(/28H FLDORT: ORTHONORMAL MATRIX:)') + DO IMOD=1,LMOD + WRITE(6,'(3X,1P,15E12.4)') REAL(ORTHO(IMOD,:LMOD)) + ENDDO +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(GAR,ORTHO,CAD,CEV,DWORK) + RETURN + END diff --git a/Trivac/src/FLDPWY.f b/Trivac/src/FLDPWY.f new file mode 100755 index 0000000..ea4f5ec --- /dev/null +++ b/Trivac/src/FLDPWY.f @@ -0,0 +1,262 @@ +*DECK FLDPWY + SUBROUTINE FLDPWY(LL4W,LL4X,LL4Y,NBLOS,IELEM,CTRAN,IPERT,KN, + > DIFF,F2Y,F3W) +* +*----------------------------------------------------------------------- +* +*Purpose: +* compute the Piolat contribution to the current-current tranverse +* couplings for the Thomas-Raviart-Schneider method. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* LL4W number of currents in direction W. +* LL4X number of currents in direction X. +* LL4Y number of currents in direction Y. +* NBLOS number of lozenges in one ADI direction. +* IELEM degree of the Lagrangian finite elements: =1 (linear); +* =2 (parabolic); =3 (cubic). +* CTRAN tranverse coupling Piolat unit matrix. +* IPERT mixture permutation index. +* KN ADI permutation indices for the volumes and currents. +* DIFF inverse diffusion coefficients. +* F2W right-hand-side vector in direction W. +* F2X right-hand-side vector in direction X. +* F2Y right-hand-side vector in direction Y. +* +*Parameters: output +* F3W result of matrix multiplication in direction W. +* F3X result of matrix multiplication in direction X. +* F3Y result of matrix multiplication in direction Y. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER LL4W,LL4X,LL4Y,NBLOS,IELEM,IPERT(NBLOS), + 1 KN(NBLOS,3+6*(IELEM+2)*IELEM**2) + REAL DIFF(NBLOS),F2Y(LL4Y),F3W(LL4W) + DOUBLE PRECISION CTRAN((IELEM+1)*IELEM,(IELEM+1)*IELEM) +* + NELEM=(IELEM+1)*IELEM + NELEH=NELEM*IELEM + NUM=0 + DO 30 KEL=1,NBLOS + IF(IPERT(KEL).EQ.0) GO TO 30 + NUM=NUM+1 + ITRS=KN(NUM,3) + DINV=DIFF(KEL) + DO 25 I1=0,IELEM-1 + DO 20 I0=1,NELEM + I=I1*NELEM+I0 + KNW1=KN(ITRS,3+I) + IF(KNW1.EQ.0) GO TO 20 + INW1=ABS(KNW1) + DO 10 J0=1,NELEM + J=I1*NELEM+J0 + KNY2=KN(NUM,3+5*NELEH+J) + IF(KNY2.EQ.0) GO TO 10 + INY2=ABS(KNY2)-LL4W-LL4X + SG=REAL(SIGN(1,KNW1)*SIGN(1,KNY2)) + F3W(INW1)=F3W(INW1)-SG*DINV*REAL(CTRAN(I0,J0))*F2Y(INY2) + 10 CONTINUE + 20 CONTINUE + 25 CONTINUE + 30 CONTINUE + RETURN + END +* + SUBROUTINE FLDPWX(LL4W,LL4X,NBLOS,IELEM,CTRAN,IPERT,KN,DIFF, + > F2X,F3W) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER LL4W,LL4X,NBLOS,IELEM,IPERT(NBLOS), + 1 KN(NBLOS,3+6*(IELEM+2)*IELEM**2) + REAL DIFF(NBLOS),F2X(LL4X),F3W(LL4W) + DOUBLE PRECISION CTRAN((IELEM+1)*IELEM,(IELEM+1)*IELEM) +* + NELEM=(IELEM+1)*IELEM + NELEH=NELEM*IELEM + NUM=0 + DO 60 KEL=1,NBLOS + IF(IPERT(KEL).EQ.0) GO TO 60 + NUM=NUM+1 + DINV=DIFF(KEL) + DO 55 I1=0,IELEM-1 + DO 50 I0=1,NELEM + I=I1*NELEM+I0 + KNX1=KN(NUM,3+2*NELEH+I) + IF(KNX1.EQ.0) GO TO 50 + INX1=ABS(KNX1)-LL4W + DO 40 J0=1,NELEM + J=I1*NELEM+J0 + KNW2=KN(NUM,3+NELEH+J) + IF(KNW2.EQ.0) GO TO 40 + INW2=ABS(KNW2) + SG=REAL(SIGN(1,KNX1)*SIGN(1,KNW2)) + F3W(INW2)=F3W(INW2)-SG*DINV*REAL(CTRAN(I0,J0))*F2X(INX1) + 40 CONTINUE + 50 CONTINUE + 55 CONTINUE + 60 CONTINUE + RETURN + END +* + SUBROUTINE FLDPXW(LL4W,LL4X,NBLOS,IELEM,CTRAN,IPERT,KN,DIFF, + > F2W,F3X) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER LL4W,LL4X,NBLOS,IELEM,IPERT(NBLOS), + 1 KN(NBLOS,3+6*(IELEM+2)*IELEM**2) + REAL DIFF(NBLOS),F2W(LL4W),F3X(LL4X) + DOUBLE PRECISION CTRAN((IELEM+1)*IELEM,(IELEM+1)*IELEM) +* + NELEM=(IELEM+1)*IELEM + NELEH=NELEM*IELEM + NUM=0 + DO 90 KEL=1,NBLOS + IF(IPERT(KEL).EQ.0) GO TO 90 + NUM=NUM+1 + DINV=DIFF(KEL) + DO 85 I1=0,IELEM-1 + DO 80 I0=1,NELEM + I=I1*NELEM+I0 + KNX1=KN(NUM,3+2*NELEH+I) + IF(KNX1.EQ.0) GO TO 80 + INX1=ABS(KNX1)-LL4W + DO 70 J0=1,NELEM + J=I1*NELEM+J0 + KNW2=KN(NUM,3+NELEH+J) + IF(KNW2.EQ.0) GO TO 70 + INW2=ABS(KNW2) + SG=REAL(SIGN(1,KNX1)*SIGN(1,KNW2)) + F3X(INX1)=F3X(INX1)-SG*DINV*REAL(CTRAN(I0,J0))*F2W(INW2) + 70 CONTINUE + 80 CONTINUE + 85 CONTINUE + 90 CONTINUE + RETURN + END +* + SUBROUTINE FLDPXY(LL4W,LL4X,LL4Y,NBLOS,IELEM,CTRAN,IPERT,KN,DIFF, + > F2Y,F3X) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER LL4W,LL4X,LL4Y,NBLOS,IELEM,IPERT(NBLOS), + 1 KN(NBLOS,3+6*(IELEM+2)*IELEM**2) + REAL DIFF(NBLOS),F2Y(LL4Y),F3X(LL4X) + DOUBLE PRECISION CTRAN((IELEM+1)*IELEM,(IELEM+1)*IELEM) +* + NELEM=(IELEM+1)*IELEM + NELEH=NELEM*IELEM + NUM=0 + DO 120 KEL=1,NBLOS + IF(IPERT(KEL).EQ.0) GO TO 120 + NUM=NUM+1 + DINV=DIFF(KEL) + DO 115 I1=0,IELEM-1 + DO 110 I0=1,NELEM + I=I1*NELEM+I0 + KNY1=KN(NUM,3+4*NELEH+I) + IF(KNY1.EQ.0) GO TO 110 + INY1=ABS(KNY1)-LL4W-LL4X + DO 100 J0=1,NELEM + J=I1*NELEM+J0 + KNX2=KN(NUM,3+3*NELEH+J) + IF(KNX2.EQ.0) GO TO 100 + INX2=ABS(KNX2)-LL4W + SG=REAL(SIGN(1,KNY1)*SIGN(1,KNX2)) + F3X(INX2)=F3X(INX2)-SG*DINV*REAL(CTRAN(I0,J0))*F2Y(INY1) + 100 CONTINUE + 110 CONTINUE + 115 CONTINUE + 120 CONTINUE + RETURN + END +* + SUBROUTINE FLDPYX(LL4W,LL4X,LL4Y,NBLOS,IELEM,CTRAN,IPERT,KN,DIFF, + > F2X,F3Y) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER LL4W,LL4X,LL4Y,NBLOS,IELEM,IPERT(NBLOS), + 1 KN(NBLOS,3+6*(IELEM+2)*IELEM**2) + REAL DIFF(NBLOS),F2X(LL4X),F3Y(LL4Y) + DOUBLE PRECISION CTRAN((IELEM+1)*IELEM,(IELEM+1)*IELEM) +* + NELEM=(IELEM+1)*IELEM + NELEH=NELEM*IELEM + NUM=0 + DO 150 KEL=1,NBLOS + IF(IPERT(KEL).EQ.0) GO TO 150 + NUM=NUM+1 + DINV=DIFF(KEL) + DO 145 I1=0,IELEM-1 + DO 140 I0=1,NELEM + I=I1*NELEM+I0 + KNY1=KN(NUM,3+4*NELEH+I) + IF(KNY1.EQ.0) GO TO 140 + INY1=ABS(KNY1)-LL4W-LL4X + DO 130 J0=1,NELEM + J=I1*NELEM+J0 + KNX2=KN(NUM,3+3*NELEH+J) + IF(KNX2.EQ.0) GO TO 130 + INX2=ABS(KNX2)-LL4W + SG=REAL(SIGN(1,KNY1)*SIGN(1,KNX2)) + F3Y(INY1)=F3Y(INY1)-SG*DINV*REAL(CTRAN(I0,J0))*F2X(INX2) + 130 CONTINUE + 140 CONTINUE + 145 CONTINUE + 150 CONTINUE + RETURN + END +* + SUBROUTINE FLDPYW(LL4W,LL4X,LL4Y,NBLOS,IELEM,CTRAN,IPERT,KN,DIFF, + > F2W,F3Y) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER LL4W,LL4X,LL4Y,NBLOS,IELEM,IPERT(NBLOS), + 1 KN(NBLOS,3+6*(IELEM+2)*IELEM**2) + REAL DIFF(NBLOS),F2W(LL4W),F3Y(LL4Y) + DOUBLE PRECISION CTRAN((IELEM+1)*IELEM,(IELEM+1)*IELEM) +* + NELEM=(IELEM+1)*IELEM + NELEH=NELEM*IELEM + NUM=0 + DO 180 KEL=1,NBLOS + IF(IPERT(KEL).EQ.0) GO TO 180 + NUM=NUM+1 + ITRS=KN(NUM,3) + DINV=DIFF(KEL) + DO 175 I1=0,IELEM-1 + DO 170 I0=1,NELEM + I=I1*NELEM+I0 + KNW1=KN(ITRS,3+I) + IF(KNW1.EQ.0) GO TO 170 + INW1=ABS(KNW1) + DO 160 J0=1,NELEM + J=I1*NELEM+J0 + KNY2=KN(NUM,3+5*NELEH+J) + IF(KNY2.EQ.0) GO TO 160 + INY2=ABS(KNY2)-LL4W-LL4X + SG=REAL(SIGN(1,KNW1)*SIGN(1,KNY2)) + F3Y(INY2)=F3Y(INY2)-SG*DINV*REAL(CTRAN(I0,J0))*F2W(INW1) + 160 CONTINUE + 170 CONTINUE + 175 CONTINUE + 180 CONTINUE + RETURN + END diff --git a/Trivac/src/FLDREL.f b/Trivac/src/FLDREL.f new file mode 100755 index 0000000..b59dafd --- /dev/null +++ b/Trivac/src/FLDREL.f @@ -0,0 +1,51 @@ +*DECK FLDREL + SUBROUTINE FLDREL(RELAX,IPLIST,NGRP,NUN,ARRAY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Relaxation procedure for flux distribution information. +* +*Copyright: +* Copyright (C) 2014 Ecole Polytechnique de Montreal. +* +*Author(s): A. Hebert +* +*Parameters: input +* RELAX relaxation factor +* IPLIST pointer to object information. +* NGRP number of energy groups +* NUN number of unknowns per energy group +* ARRAY real record to relax +* +*Parameters: output +* ARRAY real record after relaxation +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIST + INTEGER NGRP,NUN + REAL RELAX,ARRAY(NUN,NGRP) +*---- +* LOCAL VARIABLES +*---- + INTEGER IGR,IUN,ILONG,ITYLCM + REAL, ALLOCATABLE, DIMENSION(:) :: ARRAY0 +* + IF(RELAX.EQ.1.0) RETURN + ALLOCATE(ARRAY0(NUN)) + DO IGR=1,NGRP + CALL LCMLEL(IPLIST,IGR,ILONG,ITYLCM) + IF(ILONG.NE.NUN) CALL XABORT('FLDREL: UNABLE TO RELAX.') + CALL LCMGDL(IPLIST,IGR,ARRAY0) + DO IUN=1,NUN + ARRAY(IUN,IGR)=RELAX*ARRAY(IUN,IGR)+(1.0-RELAX)*ARRAY0(IUN) + ENDDO + ENDDO + DEALLOCATE(ARRAY0) + RETURN + END diff --git a/Trivac/src/FLDSMB.f b/Trivac/src/FLDSMB.f new file mode 100755 index 0000000..f479a9a --- /dev/null +++ b/Trivac/src/FLDSMB.f @@ -0,0 +1,475 @@ +*DECK FLDSMB + SUBROUTINE FLDSMB (IPTRK,IPSYS,IPFLUX,LL4,ITY,NUN,NGRP,ICL1,ICL2, + 1 IMPX,IMPH,TITR,EPS2,MAXOUT,MAXINR,EPSINR,EVECT,FKEFF) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solution of a multigroup eigenvalue system for the calculation of the +* direct neutron flux in BIVAC. Use the preconditionned power method +* with a two-parameter SVAT acceleration technique. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK L_TRACK pointer to the BIVAC tracking information. +* IPSYS L_SYSTEM pointer to system matrices. +* IPFLUX L_FLUX pointer to the solution. +* LL4 order of the system matrices. +* ITY type of algorithm: 1: Diffusion theory; 11: Simplified PN +* approximation. +* NUN number of unknowns in each energy group. +* NGRP number of energy groups. +* ICL1 number of free iterations in one cycle of the inverse power +* method. +* ICL2 number of accelerated iterations in one cycle. +* IMPX print parameter: =0: no print; =1: minimum printing; +* =2: iteration history is printed. +* IMPH type of histogram processing: +* =0: no action is taken; +* =1: the flux is compared to a reference flux stored on LCM; +* =2: the convergence histogram is printed; +* =3: the convergence histogram is printed with axis and +* titles. The plotting file is completed; +* =4: the convergence histogram is printed with axis, acce- +* leration factors and titles. The plotting file is +* completed. +* TITR title. +* EPS2 convergence criteria for the flux. +* MAXOUT maximum number of outer iterations. +* MAXINR maximum number of thermal iterations. +* EPSINR thermal iteration epsilon. +* EVECT initial estimate of the unknown vector. +* +*Parameters: output +* EVECT converged unknown vector. +* FKEFF effective multiplication factor. +* +*Reference: +* A. H\'ebert, 'Preconditioning the power method for reactor +* calculations', Nucl. Sci. Eng., 94, 1 (1986). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPSYS,IPFLUX + CHARACTER*72 TITR + INTEGER LL4,ITY,NUN,NGRP,ICL1,ICL2,IMPX,IMPH,MAXOUT,MAXINR + REAL FKEFF,EPS2,EPSINR,EVECT(NUN,NGRP) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MMAXX=250,EPS1=1.0E-5) + CHARACTER*12 TEXT12 + LOGICAL LOGTES + DOUBLE PRECISION AEAE,AEAG,AEAH,AGAG,AGAH,AHAH,BEBE,BEBG,BEBH, + 1 BGBG,BGBH,BHBH,AEBE,AEBG,AEBH,AGBE,AGBG,AGBH,AHBE,AHBG,AHBH, + 2 X,DXDA,DXDB,Y,DYDA,DYDB,Z,DZDA,DZDB,F,D2F(2,3),EVAL,ALP,BET, + 3 FMIN + INTEGER ITITR(18) + REAL ERR(MMAXX),ALPH(MMAXX),BETA(MMAXX) + DOUBLE PRECISION, PARAMETER :: ALP_TAB(24) = (/ 0.2, 0.4, 0.6, + 1 0.8, 1.0, 1.2, 1.5, 2.0, 10.0, 15.0, 20.0, 25.0, 30.0, 35.0, + 2 40.0, 45.0, 50.0, 55.0, 60.0, 65.0, 70.0, 75.0, 80.0, 85.0 /) + DOUBLE PRECISION, PARAMETER :: BET_TAB(11) = (/ -1.0, -0.8, -0.6, + 1 -0.4, -0.2, 0.0, 0.2, 0.4, 0.6, 0.8, 1.0 /) + REAL, DIMENSION(:), ALLOCATABLE :: WORK + REAL, DIMENSION(:,:), ALLOCATABLE :: GRAD1,GRAD2,GAR1,GAR2,GAR3, + 1 GAF1,GAF2,GAF3 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(GRAD1(NUN,NGRP),GRAD2(NUN,NGRP),GAR1(NUN,NGRP), + 1 GAR2(NUN,NGRP),GAR3(NUN,NGRP),GAF1(NUN,NGRP),GAF2(NUN,NGRP), + 2 GAF3(NUN,NGRP),WORK(NUN)) +* +* TKT : CPU TIME FOR THE SOLUTION OF LINEAR SYSTEMS. +* TKB : CPU TIME FOR BILINEAR PRODUCT EVALUATIONS. + TKT=0.0 + TKB=0.0 + CALL KDRCPU(TK1) +*---- +* PRECONDITIONED POWER METHOD +*---- + EVAL=1.0 + VVV=0.0 + ISTART=1 + TEST=0.0 + IF(IMPX.GE.1) WRITE (6,600) + IF(IMPX.GE.2) WRITE (6,610) + DO 25 IGR=1,NGRP + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,EVECT(1,IGR),GAR1(1,IGR)) + DO 20 JGR=1,NGRP + IF(JGR.EQ.IGR) GO TO 20 + WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 20 + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,EVECT(1,JGR),WORK(1)) + DO 10 I=1,LL4 + GAR1(I,IGR)=GAR1(I,IGR)-WORK(I) + 10 CONTINUE + 20 CONTINUE + 25 CONTINUE + CALL KDRCPU(TK2) + TKB=TKB+(TK2-TK1) +* + M=0 + 30 M=M+1 +*---- +* EIGENVALUE EVALUATION +*---- + CALL KDRCPU(TK1) + AEBE=0.0D0 + BEBE=0.0D0 + DO 75 IGR=1,NGRP + DO 40 I=1,LL4 + GAF1(I,IGR)=0.0 + 40 CONTINUE + DO 60 JGR=1,NGRP + WRITE(TEXT12,'(1HB,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 60 + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,EVECT(1,JGR),WORK(1)) + DO 50 I=1,LL4 + GAF1(I,IGR)=GAF1(I,IGR)+WORK(I) + 50 CONTINUE + 60 CONTINUE + DO 70 I=1,LL4 + AEBE=AEBE+GAR1(I,IGR)*GAF1(I,IGR) + BEBE=BEBE+GAF1(I,IGR)**2 + 70 CONTINUE + 75 CONTINUE + EVAL=AEBE/BEBE + CALL KDRCPU(TK2) + TKB=TKB+(TK2-TK1) +*---- +* DIRECTION EVALUATION +*---- + DO 110 IGR=1,NGRP + CALL KDRCPU(TK1) + DO 80 I=1,LL4 + GRAD1(I,IGR)=REAL(EVAL)*GAF1(I,IGR)-GAR1(I,IGR) + 80 CONTINUE + DO 100 JGR=1,IGR-1 + WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 100 + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD1(1,JGR),WORK(1)) + DO 90 I=1,LL4 + GRAD1(I,IGR)=GRAD1(I,IGR)+WORK(I) + 90 CONTINUE + 100 CONTINUE + CALL KDRCPU(TK2) + TKB=TKB+(TK2-TK1) +* + CALL KDRCPU(TK1) + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL MTLDLS(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD1(1,IGR)) + CALL KDRCPU(TK2) + TKT=TKT+(TK2-TK1) + 110 CONTINUE +*---- +* PERFORM THERMAL (UP-SCATTERING) ITERATIONS +*---- + KTER=0 + NADI=5 ! used with SPN approximations + IF(MAXINR.GT.1) THEN + CALL FLDBHR(IPTRK,IPSYS,.FALSE.,LL4,ITY,NUN,NGRP,ICL1,ICL2, + 1 IMPX,NADI,MAXINR,EPSINR,KTER,TKT,TKB,GRAD1) + ENDIF +*---- +* DISPLACEMENT EVALUATION +*---- + F=0.0D0 + DELS=ABS(REAL((EVAL-VVV)/EVAL)) + VVV=REAL(EVAL) + CALL KDRCPU(TK1) +*---- +* EVALUATION OF THE TWO ACCELERATION PARAMETERS ALP AND BET +*---- + ALP=1.0D0 + BET=0.0D0 + N=0 + AEAE=0.0D0 + AEAG=0.0D0 + AEAH=0.0D0 + AGAG=0.0D0 + AGAH=0.0D0 + AHAH=0.0D0 + BEBG=0.0D0 + BEBH=0.0D0 + BGBG=0.0D0 + BGBH=0.0D0 + BHBH=0.0D0 + AEBG=0.0D0 + AEBH=0.0D0 + AGBE=0.0D0 + AGBG=0.0D0 + AGBH=0.0D0 + AHBE=0.0D0 + AHBG=0.0D0 + AHBH=0.0D0 + DO 165 IGR=1,NGRP + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD1(1,IGR),GAR2(1,IGR)) + DO 120 I=1,LL4 + GAF2(I,IGR)=0.0 + 120 CONTINUE + DO 160 JGR=1,NGRP + IF(JGR.EQ.IGR) GO TO 140 + WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 140 + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD1(1,JGR),WORK(1)) + DO 130 I=1,LL4 + GAR2(I,IGR)=GAR2(I,IGR)-WORK(I) + 130 CONTINUE + 140 WRITE(TEXT12,'(1HB,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 160 + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD1(1,JGR),WORK(1)) + DO 150 I=1,LL4 + GAF2(I,IGR)=GAF2(I,IGR)+WORK(I) + 150 CONTINUE + 160 CONTINUE + 165 CONTINUE + IF(1+MOD(M-ISTART,ICL1+ICL2).GT.ICL1) THEN + DO 175 IGR=1,NGRP + DO 170 I=1,LL4 +* COMPUTE (A ,A ) + AEAE=AEAE+GAR1(I,IGR)**2 + AEAG=AEAG+GAR1(I,IGR)*GAR2(I,IGR) + AEAH=AEAH+GAR1(I,IGR)*GAR3(I,IGR) + AGAG=AGAG+GAR2(I,IGR)**2 + AGAH=AGAH+GAR2(I,IGR)*GAR3(I,IGR) + AHAH=AHAH+GAR3(I,IGR)**2 +* COMPUTE (B ,B ) + BEBG=BEBG+GAF1(I,IGR)*GAF2(I,IGR) + BEBH=BEBH+GAF1(I,IGR)*GAF3(I,IGR) + BGBG=BGBG+GAF2(I,IGR)**2 + BGBH=BGBH+GAF2(I,IGR)*GAF3(I,IGR) + BHBH=BHBH+GAF3(I,IGR)**2 +* COMPUTE (A ,B ) + AEBG=AEBG+GAR1(I,IGR)*GAF2(I,IGR) + AEBH=AEBH+GAR1(I,IGR)*GAF3(I,IGR) + AGBE=AGBE+GAR2(I,IGR)*GAF1(I,IGR) + AGBG=AGBG+GAR2(I,IGR)*GAF2(I,IGR) + AGBH=AGBH+GAR2(I,IGR)*GAF3(I,IGR) + AHBE=AHBE+GAR3(I,IGR)*GAF1(I,IGR) + AHBG=AHBG+GAR3(I,IGR)*GAF2(I,IGR) + AHBH=AHBH+GAR3(I,IGR)*GAF3(I,IGR) + 170 CONTINUE + 175 CONTINUE +* + 180 N=N+1 + IF(N.GT.10) GO TO 185 +* COMPUTE X(M+1) + X=BEBE+ALP*ALP*BGBG+BET*BET*BHBH+2.0D0*(ALP*BEBG+BET*BEBH + 1 +ALP*BET*BGBH) + DXDA=2.0D0*(BEBG+ALP*BGBG+BET*BGBH) + DXDB=2.0D0*(BEBH+ALP*BGBH+BET*BHBH) +* COMPUTE Y(M+1) + Y=AEAE+ALP*ALP*AGAG+BET*BET*AHAH+2.0D0*(ALP*AEAG+BET*AEAH + 1 +ALP*BET*AGAH) + DYDA=2.0D0*(AEAG+ALP*AGAG+BET*AGAH) + DYDB=2.0D0*(AEAH+ALP*AGAH+BET*AHAH) +* COMPUTE Z(M+1) + Z=AEBE+ALP*ALP*AGBG+BET*BET*AHBH+ALP*(AEBG+AGBE) + 1 +BET*(AEBH+AHBE)+ALP*BET*(AGBH+AHBG) + DZDA=AEBG+AGBE+2.0D0*ALP*AGBG+BET*(AGBH+AHBG) + DZDB=AEBH+AHBE+ALP*(AGBH+AHBG)+2.0D0*BET*AHBH +* COMPUTE F(M+1) + F=X*Y-Z*Z + D2F(1,1)=2.0D0*(BGBG*Y+DXDA*DYDA+X*AGAG-DZDA**2-2.0D0*Z*AGBG) + D2F(1,2)=2.0D0*BGBH*Y+DXDA*DYDB+DXDB*DYDA+2.0D0*X*AGAH + 1 -2.0D0*DZDA*DZDB-2.0D0*Z*(AGBH+AHBG) + D2F(2,2)=2.0D0*(BHBH*Y+DXDB*DYDB+X*AHAH-DZDB**2-2.0D0*Z*AHBH) + D2F(2,1)=D2F(1,2) + D2F(1,3)=DXDA*Y+X*DYDA-2.0D0*Z*DZDA + D2F(2,3)=DXDB*Y+X*DYDB-2.0D0*Z*DZDB +* SOLUTION OF A LINEAR SYSTEM. + CALL ALSBD(2,1,D2F,IER,2) + IF(IER.NE.0) GO TO 185 + ALP=ALP-D2F(1,3) + BET=BET-D2F(2,3) + IF(ALP.GT.100.0) GO TO 185 + IF((ABS(D2F(1,3)).LE.1.0D-4).AND.(ABS(D2F(2,3)).LE.1.0D-4)) + 1 GO TO 190 + GO TO 180 +* +* alternative algorithm in case of Newton-Raphton failure + 185 IF(IMPX.GT.0) WRITE(6,'(/30H FLDSMB: FAILURE OF THE NEWTON, + 1 55H-RAPHTON ALGORIHTHM FOR COMPUTING THE OVERRELAXATION PA, + 2 9HRAMETERS.)') + IAMIN=999 + IBMIN=999 + FMIN=HUGE(FMIN) + DO IA=1,SIZE(ALP_TAB) + ALP=ALP_TAB(IA) + DO IB=1,SIZE(BET_TAB) + BET=BET_TAB(IB) +* COMPUTE X + X=BEBE+ALP*ALP*BGBG+BET*BET*BHBH+2.0D0*(ALP*BEBG+BET*BEBH + 1 +ALP*BET*BGBH) +* COMPUTE Y + Y=AEAE+ALP*ALP*AGAG+BET*BET*AHAH+2.0D0*(ALP*AEAG+BET*AEAH + 1 +ALP*BET*AGAH) +* COMPUTE Z + Z=AEBE+ALP*ALP*AGBG+BET*BET*AHBH+ALP*(AEBG+AGBE) + 1 +BET*(AEBH+AHBE)+ALP*BET*(AGBH+AHBG) +* COMPUTE F + F=X*Y-Z*Z + IF(F.LT.FMIN) THEN + IAMIN=IA + IBMIN=IB + FMIN=F + ENDIF + ENDDO + ENDDO + ALP=ALP_TAB(IAMIN) + BET=BET_TAB(IBMIN) + 190 BET=BET/ALP + IF((ALP.LT.1.0D0).AND.(ALP.GT.0.0D0)) THEN + ALP=1.0D0 + BET=0.0D0 + ELSE IF(ALP.LE.0.0D0) THEN + ISTART=M+1 + ALP=1.0D0 + BET=0.0D0 + ENDIF + DO 205 IGR=1,NGRP + DO 200 I=1,LL4 + GRAD1(I,IGR)=REAL(ALP)*(GRAD1(I,IGR)+REAL(BET)*GRAD2(I,IGR)) + GAR2(I,IGR)=REAL(ALP)*(GAR2(I,IGR)+REAL(BET)*GAR3(I,IGR)) + GAF2(I,IGR)=REAL(ALP)*(GAF2(I,IGR)+REAL(BET)*GAF3(I,IGR)) + 200 CONTINUE + 205 CONTINUE + ENDIF + CALL KDRCPU(TK2) + TKB=TKB+(TK2-TK1) +* + LOGTES=(M.LT.ICL1).OR.(MOD(M-ISTART,ICL1+ICL2).EQ.ICL1-1) + IF(LOGTES.AND.(DELS.LE.EPS1)) THEN + DELT=0.0 + DO 220 IGR=1,NGRP + DELN=0.0 + DELD=0.0 + DO 210 I=1,LL4 + EVECT(I,IGR)=EVECT(I,IGR)+GRAD1(I,IGR) + GAR1(I,IGR)=GAR1(I,IGR)+GAR2(I,IGR) + GAF1(I,IGR)=GAF1(I,IGR)+GAF2(I,IGR) + GRAD2(I,IGR)=GRAD1(I,IGR) + GAR3(I,IGR)=GAR2(I,IGR) + GAF3(I,IGR)=GAF2(I,IGR) + DELN=MAX(DELN,ABS(GAF2(I,IGR))) + DELD=MAX(DELD,ABS(GAF1(I,IGR))) + 210 CONTINUE + IF(DELD.NE.0.0) DELT=MAX(DELT,DELN/DELD) + 220 CONTINUE + IF(IMPX.GE.2) WRITE (6,615) M,AEAE,AEAG,AEAH,AGAG,AGAH,AHAH, + 1 BEBE,ALP,BET,EVAL,F,DELS,DELT,N,BEBG,BEBH,BGBG,BGBH,BHBH, + 2 AEBE,AEBG,AEBH,AGBE,AGBG,AGBH,AHBE,AHBG,AHBH +* COMPUTE THE CONVERGENCE HISTOGRAM. + IF((IMPH.GE.1).AND.(M.LE.MMAXX)) THEN + CALL FLDXCO(IPFLUX,LL4,NUN,EVECT(1,NGRP),.TRUE.,ERR(M)) + ALPH(M)=REAL(ALP) + BETA(M)=REAL(BET) + ENDIF + IF(DELT.LE.EPS2) GO TO 240 + ELSE + DO 235 IGR=1,NGRP + DO 230 I=1,LL4 + EVECT(I,IGR)=EVECT(I,IGR)+GRAD1(I,IGR) + GAR1(I,IGR)=GAR1(I,IGR)+GAR2(I,IGR) + GAF1(I,IGR)=GAF1(I,IGR)+GAF2(I,IGR) + GRAD2(I,IGR)=GRAD1(I,IGR) + GAR3(I,IGR)=GAR2(I,IGR) + GAF3(I,IGR)=GAF2(I,IGR) + 230 CONTINUE + 235 CONTINUE + IF(IMPX.GE.2) WRITE (6,620) M,AEAE,AEAG,AEAH,AGAG,AGAH,AHAH, + 1 BEBE,ALP,BET,EVAL,F,DELS,N,BEBG,BEBH,BGBG,BGBH,BHBH,AEBE, + 2 AEBG,AEBH,AGBE,AGBG,AGBH,AHBE,AHBG,AHBH +* COMPUTE THE CONVERGENCE HISTOGRAM. + IF((IMPH.GE.1).AND.(M.LE.MMAXX)) THEN + CALL FLDXCO(IPFLUX,LL4,NUN,EVECT(1,NGRP),.TRUE.,ERR(M)) + ALPH(M)=REAL(ALP) + BETA(M)=REAL(BET) + ENDIF + ENDIF + IF(M.EQ.1) TEST=DELS + IF((M.GT.5).AND.(DELS.GT.TEST)) CALL XABORT('FLDSMB: CONVERGENCE' + 1 //' FAILURE.') + IF(M.GE.MAXOUT) CALL XABORT('FLDSMB: MAXIMUM NUMBER OF ITERATION' + 1 //'S REACHED.') + GO TO 30 +*---- +* SOLUTION EDITION +*---- + 240 FKEFF=REAL(1.0D0/EVAL) + IF(IMPX.EQ.1) WRITE (6,640) M + IF(IMPX.GE.1) THEN + WRITE (6,650) TKT,TKB,TKT+TKB + WRITE (6,670) FKEFF + ENDIF + IF(IMPX.EQ.3) THEN + DO 250 IGR=1,NGRP + WRITE (6,680) IGR,(EVECT(I,IGR),I=1,LL4) + 250 CONTINUE + ENDIF + IF(IMPH.EQ.1) THEN + CALL LCMLEN(IPFLUX,'REF',ILONG,ITYLCM) + IF(ILONG.EQ.0) THEN + WRITE(6,'(40H FLDSMB: STORE A REFERENCE THERMAL FLUX.)') + CALL LCMPUT(IPFLUX,'REF',NUN,2,EVECT(1,NGRP)) + ENDIF + ELSE IF(IMPH.GE.2) THEN + IGRAPH=0 + 260 IGRAPH=IGRAPH+1 + WRITE (TEXT12,'(5HHISTO,I3)') IGRAPH + CALL LCMLEN (IPFLUX,TEXT12,ILENG,ITYLCM) + IF(ILENG.EQ.0) THEN + MM=MIN(M,MMAXX) + READ (TITR,'(18A4)') ITITR + CALL LCMSIX (IPFLUX,TEXT12,1) + CALL LCMPUT (IPFLUX,'HTITLE',18,3,ITITR) + CALL LCMPUT (IPFLUX,'ALPHA',MM,2,ALPH) + CALL LCMPUT (IPFLUX,'BETA',MM,2,BETA) + CALL LCMPUT (IPFLUX,'ERROR',MM,2,ERR) + CALL LCMPUT (IPFLUX,'IMPH',1,1,IMPH) + CALL LCMSIX (IPFLUX,' ',2) + ELSE + GO TO 260 + ENDIF + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(GRAD1,GRAD2,GAR1,GAR2,GAR3,GAF1,GAF2,GAF3,WORK) + RETURN +* + 600 FORMAT(1H1/50H FLDSMB: ITERATIVE PROCEDURE BASED ON PRECONDITION, + 1 16HED POWER METHOD./9X,16HDIRECT EQUATION.) + 610 FORMAT(//5X,17HBILINEAR PRODUCTS,48X,5HALPHA,3X,4HBETA,3X, + 1 12HEIGENVALUE..,12X,8HACCURACY,11(1H.),2X,1HN) + 615 FORMAT(1X,I3,1P,7E9.1,0P,2F8.3,E14.6,3E10.2,I4/(4X,1P,7E9.1)) + 620 FORMAT(1X,I3,1P,7E9.1,0P,2F8.3,E14.6,2E10.2,10X,I4/(4X,1P,7E9.1)) + 640 FORMAT(/23H FLDSMB: CONVERGENCE IN,I4,12H ITERATIONS.) + 650 FORMAT(/53H FLDSMB: CPU TIME USED TO SOLVE THE TRIANGULAR LINEAR, + 1 10H SYSTEMS =,F10.3/23X,34HTO COMPUTE THE BILINEAR PRODUCTS =, + 2 F10.3,20X,16HTOTAL CPU TIME =,F10.3) + 670 FORMAT(//42H FLDSMB: EFFECTIVE MULTIPLICATION FACTOR =,1P,E17.10/) + 680 FORMAT(//47H FLDSMB: EIGENVECTOR CORRESPONDING TO THE GROUP,I4 + 1 //(5X,1P,8E14.5)) + END diff --git a/Trivac/src/FLDSPN.f b/Trivac/src/FLDSPN.f new file mode 100755 index 0000000..a7b8618 --- /dev/null +++ b/Trivac/src/FLDSPN.f @@ -0,0 +1,710 @@ +*DECK FLDSPN + SUBROUTINE FLDSPN(NAMP,IPTRK,IPSYS,LL4,NBMIX,NAN,S1,F1,NADI) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform NADI inner iterations with the ADI preconditionning. +* Special version for Thomas-Raviart basis (simplified PN). +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NAMP name of the ADI-splitted matrix. +* IPTRK L_TRACK pointer to the tracking information. +* IPSYS L_SYSTEM pointer to system matrices. +* LL4 order of the matrix. +* NBMIX total number of material mixtures in the macrolib. +* NAN number of Legendre orders in the cross sections. +* S1 source term of the linear system. +* F1 initial solution of the linear system. +* NADI number of inner ADI iterations. +* +*Parameters: output +* F1 solution of the linear system after NADI iterations. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER NAMP*(*) + TYPE(C_PTR) IPTRK,IPSYS + INTEGER LL4,NBMIX,NAN,NADI + REAL F1(LL4),S1(LL4) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + CHARACTER NAMT*12,TEXT12*12 + INTEGER ITP(NSTATE) + LOGICAL LMUX,DIAG,CHEX + INTEGER, DIMENSION(:), ALLOCATABLE :: MAT,KN,IQFR + REAL, DIMENSION(:), ALLOCATABLE :: VOL,QFR,XX,YY,ZZ,DIFF,T,GAR, + 1 FL,FW,FX,FY,FZ,GAMMA + REAL, DIMENSION(:,:), ALLOCATABLE :: SIGT,SIGTI,R,V + INTEGER C11W_LEN,C11X_LEN,C11Y_LEN,C11Z_LEN + INTEGER, DIMENSION(:), POINTER :: IPERT,IPBW,MUW,IPVW,NBLW,LBLW, + 1 IPBX,MUX,IPVX,NBLX,LBLX,IPBY,MUY,IPVY,NBLY,LBLY,IPBZ,MUZ,IPVZ, + 2 NBLZ,LBLZ + REAL, DIMENSION(:), POINTER :: TF,FRZ,BW,C11W,BX,C11X,BY,C11Y,BZ, + 1 C11Z + DOUBLE PRECISION, DIMENSION(:), POINTER :: CTRAN + TYPE(C_PTR) TF_PTR,FRZ_PTR,IPERT_PTR,CTRAN_PTR, + 1 BW_PTR,C11W_PTR,IPBW_PTR,MUW_PTR,IPVW_PTR,NBLW_PTR,LBLW_PTR, + 2 BX_PTR,C11X_PTR,IPBX_PTR,MUX_PTR,IPVX_PTR,NBLX_PTR,LBLX_PTR, + 3 BY_PTR,C11Y_PTR,IPBY_PTR,MUY_PTR,IPVY_PTR,NBLY_PTR,LBLY_PTR, + 4 BZ_PTR,C11Z_PTR,IPBZ_PTR,MUZ_PTR,IPVZ_PTR,NBLZ_PTR,LBLZ_PTR +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(SIGT(NBMIX,NAN),SIGTI(NBMIX,NAN)) +*---- +* RECOVER PN SPECIFIC PARAMETERS. +*---- + NAMT=NAMP + IF(NAMT(1:1).NE.'A') CALL XABORT('FLDSPN: ''A'' MATRIX EXPECTED.') + READ(NAMT,'(1X,2I3)') IGR,JGR + IF(IGR.NE.JGR) CALL XABORT('FLDSPN: INVALIB GROUP INDICES.') + CALL LCMGET(IPTRK,'STATE-VECTOR',ITP) + NREG=ITP(1) + NUN=ITP(2) + ITYPE=ITP(6) + IELEM=ITP(9) + ICOL=ITP(10) + L4=ITP(11) + LX=ITP(14) + LZ=ITP(16) + ISEG=ITP(17) + LTSW=ITP(19) + LL4F=ITP(25) + LL4W=ITP(26) + LL4X=ITP(27) + LL4Y=ITP(28) + LL4Z=ITP(29) + NLF=ITP(30) + NVD=ITP(34) + CHEX=(ITYPE.EQ.8).OR.(ITYPE.EQ.9) + IF(CHEX) THEN + IOFW=LL4F + IOFX=LL4F+LL4W + IOFY=LL4F+LL4W+LL4X + IOFZ=LL4F+LL4W+LL4X+LL4Y + IF(NUN.GT.(LX*LZ+L4)*NLF/2) CALL XABORT('FLDSPN: INVALID NUN ' + 1 //'OR L4.') + ELSE + IOFW=0 + IOFX=LL4F + IOFY=LL4F+LL4X + IOFZ=LL4F+LL4X+LL4Y + IF(NUN.NE.L4*NLF/2) CALL XABORT('FLDSPN: INVALID NUN OR L4.') + ENDIF + IF(L4*NLF/2.NE.LL4) CALL XABORT('FLDSPN: INVALID L4 OR LL4.') +*---- +* RECOVER TRACKING-RELATED INFORMATIONS +*---- + ALLOCATE(MAT(NREG),VOL(NREG)) + CALL LCMGET(IPTRK,'MATCOD',MAT) + CALL LCMGET(IPTRK,'VOLUME',VOL) + CALL LCMLEN(IPTRK,'KN',MAXKN,ITYLCM) + CALL LCMLEN(IPTRK,'QFR',MAXQF,ITYLCM) + ALLOCATE(KN(MAXKN),QFR(MAXQF),IQFR(MAXQF)) + CALL LCMGET(IPTRK,'KN',KN) + CALL LCMGET(IPTRK,'QFR',QFR) + CALL LCMGET(IPTRK,'IQFR',IQFR) + IF(CHEX) THEN + CALL LCMGET(IPTRK,'SIDE',SIDE) + ELSE + ALLOCATE(XX(NREG),YY(NREG)) + CALL LCMGET(IPTRK,'XX',XX) + CALL LCMGET(IPTRK,'YY',YY) + ENDIF + ALLOCATE(ZZ(NREG)) + CALL LCMGET(IPTRK,'ZZ',ZZ) +*---- +* PROCESS PHYSICAL ALBEDOS +*---- + TEXT12='ALBEDO-FU'//NAMT(2:4) + CALL LCMLEN(IPSYS,TEXT12,NALBP,ITYLCM) + IF(NALBP.GT.0) THEN + ALLOCATE(GAMMA(NALBP)) + CALL LCMGET(IPSYS,TEXT12,GAMMA) + DO IQW=1,MAXQF + IALB=IQFR(IQW) + IF(IALB.NE.0) QFR(IQW)=QFR(IQW)*GAMMA(IALB) + ENDDO + DEALLOCATE(GAMMA) + ENDIF +*---- +* RECOVER THE CROSS SECTIONS. +*---- + DO 10 IL=1,NAN + WRITE(TEXT12,'(4HSCAR,I2.2,A6)') IL-1,NAMT(2:7) + CALL LCMGET(IPSYS,TEXT12,SIGT(1,IL)) + WRITE(TEXT12,'(4HSCAI,I2.2,A6)') IL-1,NAMT(2:7) + CALL LCMGET(IPSYS,TEXT12,SIGTI(1,IL)) + 10 CONTINUE +*---- +* RECOVER THE FINITE ELEMENT UNIT STIFFNESS MATRIX. +*---- + CALL LCMSIX(IPTRK,'BIVCOL',1) + CALL LCMLEN(IPTRK,'T',LC,ITYLCM) + ALLOCATE(R(LC,LC),V(LC,LC-1)) + CALL LCMGET(IPTRK,'R',R) + CALL LCMGET(IPTRK,'V',V) + CALL LCMSIX(IPTRK,' ',2) +*---- +* RECOVER INFORMATIONS RELATED TO SYSTEM MATRICES +*---- + CALL LCMLEN(IPTRK,'MUX',IDUM,ITYLCM) + LMUX=(IDUM.NE.0).AND.(ITYLCM.EQ.1) + DIAG=(LL4Y.GT.0).AND.(.NOT.LMUX) + CALL LCMGPD(IPSYS,'TF'//NAMT,TF_PTR) + CALL C_F_POINTER(TF_PTR,TF,(/ LL4F*NLF/2 /)) +* + NULLIFY(IPBW) + NULLIFY(IPVW) + NULLIFY(BW) + NULLIFY(C11W) + IF(LL4W.GT.0) THEN + NBLOS=LX*LZ/3 + CALL LCMGPD(IPTRK,'CTRAN',CTRAN_PTR) + CALL LCMGPD(IPTRK,'IPERT',IPERT_PTR) + CALL LCMGPD(IPTRK,'FRZ',FRZ_PTR) + CALL C_F_POINTER(CTRAN_PTR,CTRAN,(/ ((IELEM+1)*IELEM)**2 /)) + CALL C_F_POINTER(IPERT_PTR,IPERT,(/ NBLOS /)) + CALL C_F_POINTER(FRZ_PTR,FRZ,(/ NBLOS /)) +* + CALL LCMGPD(IPTRK,'IPBBW',IPBW_PTR) + CALL LCMLEN(IPSYS,'WB',LENWB,ITYL) + IF(LENWB.EQ.0) THEN + CALL LCMGPD(IPTRK,'WB',BW_PTR) + ELSE + CALL LCMGPD(IPSYS,'WB',BW_PTR) + ENDIF + CALL C_F_POINTER(IPBW_PTR,IPBW,(/ 2*IELEM*LL4W /)) + CALL C_F_POINTER(BW_PTR,BW,(/ 2*IELEM*LL4W /)) + CALL LCMLEN(IPSYS,'WI'//NAMT,C11W_LEN,ITYLCM) + CALL LCMGPD(IPSYS,'WI'//NAMT,C11W_PTR) + IF(ISEG.EQ.0) THEN +* SCALAR SOLUTION FOR A W-ORIENTED LINEAR SYSTEM. + CALL LCMGPD(IPTRK,'MUW',MUW_PTR) + CALL C_F_POINTER(MUW_PTR,MUW,(/ LL4W /)) + ELSE IF(ISEG.GT.0) THEN +* SUPERVECTORIAL SOLUTION FOR A W-ORIENTED LINEAR SYSTEM. + CALL LCMGET(IPTRK,'LL4VW',LL4VW) + CALL LCMGPD(IPTRK,'MUVW',MUW_PTR) + CALL LCMGPD(IPTRK,'IPVW',IPVW_PTR) + CALL LCMLEN(IPTRK,'NBLW',LONW,ITYLCM) + CALL LCMGPD(IPTRK,'NBLW',NBLW_PTR) + CALL LCMGPD(IPTRK,'LBLW',LBLW_PTR) + CALL C_F_POINTER(MUW_PTR,MUW,(/ LL4VW/ISEG /)) + CALL C_F_POINTER(IPVW_PTR,IPVW,(/ LL4W /)) + CALL C_F_POINTER(NBLW_PTR,NBLW,(/ LONW /)) + CALL C_F_POINTER(LBLW_PTR,LBLW,(/ LONW /)) + ENDIF + CALL C_F_POINTER(C11W_PTR,C11W,(/ C11W_LEN /)) + ENDIF + CALL LCMGPD(IPTRK,'IPBBX',IPBX_PTR) + CALL LCMLEN(IPSYS,'XB',LENXB,ITYL) + IF(LENXB.EQ.0) THEN + CALL LCMGPD(IPTRK,'XB',BX_PTR) + ELSE + CALL LCMGPD(IPSYS,'XB',BX_PTR) + ENDIF + CALL C_F_POINTER(IPBX_PTR,IPBX,(/ 2*IELEM*LL4X /)) + CALL C_F_POINTER(BX_PTR,BX,(/ 2*IELEM*LL4X /)) + NULLIFY(IPVX) + IF(DIAG) THEN + CALL LCMLEN(IPSYS,'YI'//NAMT,C11X_LEN,ITYLCM) + CALL LCMGPD(IPSYS,'YI'//NAMT,C11X_PTR) + IF(ISEG.EQ.0) THEN +* SCALAR SOLUTION FOR A X-ORIENTED LINEAR SYSTEM. + CALL LCMGPD(IPTRK,'MUY',MUX_PTR) + CALL C_F_POINTER(MUX_PTR,MUX,(/ LL4X /)) + ELSE IF(ISEG.GT.0) THEN +* SUPERVECTORIAL SOLUTION FOR A X-ORIENTED LINEAR SYSTEM. + CALL LCMGET(IPTRK,'LL4VY',LL4VX) + CALL LCMGPD(IPTRK,'MUVY',MUX_PTR) + CALL LCMGPD(IPTRK,'IPVY',IPVX_PTR) + CALL LCMLEN(IPTRK,'NBLY',LONX,ITYLCM) + CALL LCMGPD(IPTRK,'NBLY',NBLX_PTR) + CALL LCMGPD(IPTRK,'LBLY',LBLX_PTR) + CALL C_F_POINTER(MUX_PTR,MUX,(/ LL4VX/ISEG /)) + CALL C_F_POINTER(IPVX_PTR,IPVX,(/ LL4X /)) + CALL C_F_POINTER(NBLX_PTR,NBLX,(/ LONX /)) + CALL C_F_POINTER(LBLX_PTR,LBLX,(/ LONX /)) + ENDIF + ELSE + CALL LCMLEN(IPSYS,'XI'//NAMT,C11X_LEN,ITYLCM) + CALL LCMGPD(IPSYS,'XI'//NAMT,C11X_PTR) + IF(ISEG.EQ.0) THEN +* SCALAR SOLUTION FOR A X-ORIENTED LINEAR SYSTEM. + CALL LCMGPD(IPTRK,'MUX',MUX_PTR) + CALL C_F_POINTER(MUX_PTR,MUX,(/ LL4X /)) + ELSE IF(ISEG.GT.0) THEN +* SUPERVECTORIAL SOLUTION FOR A X-ORIENTED LINEAR SYSTEM. + CALL LCMGET(IPTRK,'LL4VX',LL4VX) + CALL LCMGPD(IPTRK,'MUVX',MUX_PTR) + CALL LCMGPD(IPTRK,'IPVX',IPVX_PTR) + CALL LCMLEN(IPTRK,'NBLX',LONX,ITYLCM) + CALL LCMGPD(IPTRK,'NBLX',NBLX_PTR) + CALL LCMGPD(IPTRK,'LBLX',LBLX_PTR) + CALL C_F_POINTER(MUX_PTR,MUX,(/ LL4VX/ISEG /)) + CALL C_F_POINTER(IPVX_PTR,IPVX,(/ LL4X /)) + CALL C_F_POINTER(NBLX_PTR,NBLX,(/ LONX /)) + CALL C_F_POINTER(LBLX_PTR,LBLX,(/ LONX /)) + ENDIF + ENDIF + CALL C_F_POINTER(C11X_PTR,C11X,(/ C11X_LEN /)) + NULLIFY(IPBY) + NULLIFY(IPVY) + NULLIFY(BY) + NULLIFY(C11Y) + IF(LL4Y.GT.0) THEN + CALL LCMGPD(IPTRK,'IPBBY',IPBY_PTR) + CALL LCMLEN(IPSYS,'YB',LENYB,ITYL) + IF(LENYB.EQ.0) THEN + CALL LCMGPD(IPTRK,'YB',BY_PTR) + ELSE + CALL LCMGPD(IPSYS,'YB',BY_PTR) + ENDIF + CALL C_F_POINTER(IPBY_PTR,IPBY,(/ 2*IELEM*LL4Y /)) + CALL C_F_POINTER(BY_PTR,BY,(/ 2*IELEM*LL4Y /)) + CALL LCMLEN(IPSYS,'YI'//NAMT,C11Y_LEN,ITYLCM) + CALL LCMGPD(IPSYS,'YI'//NAMT,C11Y_PTR) + IF(ISEG.EQ.0) THEN +* SCALAR SOLUTION FOR A Y-ORIENTED LINEAR SYSTEM. + CALL LCMGPD(IPTRK,'MUY',MUY_PTR) + CALL C_F_POINTER(MUY_PTR,MUY,(/ LL4Y /)) + ELSE IF(ISEG.GT.0) THEN +* SUPERVECTORIAL SOLUTION FOR A Y-ORIENTED LINEAR SYSTEM. + CALL LCMGET(IPTRK,'LL4VY',LL4VY) + CALL LCMGPD(IPTRK,'MUVY',MUY_PTR) + CALL LCMGPD(IPTRK,'IPVY',IPVY_PTR) + CALL LCMLEN(IPTRK,'NBLY',LONY,ITYLCM) + CALL LCMGPD(IPTRK,'NBLY',NBLY_PTR) + CALL LCMGPD(IPTRK,'LBLY',LBLY_PTR) + CALL C_F_POINTER(MUY_PTR,MUY,(/ LL4VY/ISEG /)) + CALL C_F_POINTER(IPVY_PTR,IPVY,(/ LL4Y /)) + CALL C_F_POINTER(NBLY_PTR,NBLY,(/ LONY /)) + CALL C_F_POINTER(LBLY_PTR,LBLY,(/ LONY /)) + ENDIF + CALL C_F_POINTER(C11Y_PTR,C11Y,(/ C11Y_LEN /)) + ENDIF + NULLIFY(IPBZ) + NULLIFY(IPVZ) + NULLIFY(BZ) + NULLIFY(C11Z) + IF(LL4Z.GT.0) THEN + CALL LCMGPD(IPTRK,'IPBBZ',IPBZ_PTR) + CALL LCMLEN(IPSYS,'ZB',LENZB,ITYL) + IF(LENZB.EQ.0) THEN + CALL LCMGPD(IPTRK,'ZB',BZ_PTR) + ELSE + CALL LCMGPD(IPSYS,'ZB',BZ_PTR) + ENDIF + CALL C_F_POINTER(IPBZ_PTR,IPBZ,(/ 2*IELEM*LL4Z /)) + CALL C_F_POINTER(BZ_PTR,BZ,(/ 2*IELEM*LL4Z /)) + CALL LCMLEN(IPSYS,'ZI'//NAMT,C11Z_LEN,ITYLCM) + CALL LCMGPD(IPSYS,'ZI'//NAMT,C11Z_PTR) + IF(ISEG.EQ.0) THEN +* SCALAR SOLUTION FOR A Z-ORIENTED LINEAR SYSTEM. + CALL LCMGPD(IPTRK,'MUZ',MUZ_PTR) + CALL C_F_POINTER(MUZ_PTR,MUZ,(/ LL4Z /)) + ELSE IF(ISEG.GT.0) THEN +* SUPERVECTORIAL SOLUTION FOR A Z-ORIENTED LINEAR SYSTEM. + CALL LCMGET(IPTRK,'LL4VZ',LL4VZ) + CALL LCMGPD(IPTRK,'MUVZ',MUZ_PTR) + CALL LCMGPD(IPTRK,'IPVZ',IPVZ_PTR) + CALL LCMLEN(IPTRK,'NBLZ',LONZ,ITYLCM) + CALL LCMGPD(IPTRK,'NBLZ',NBLZ_PTR) + CALL LCMGPD(IPTRK,'LBLZ',LBLZ_PTR) + CALL C_F_POINTER(MUZ_PTR,MUZ,(/ LL4VZ/ISEG /)) + CALL C_F_POINTER(IPVZ_PTR,IPVZ,(/ LL4Z /)) + CALL C_F_POINTER(NBLZ_PTR,NBLZ,(/ LONZ /)) + CALL C_F_POINTER(LBLZ_PTR,LBLZ,(/ LONZ /)) + ENDIF + CALL C_F_POINTER(C11Z_PTR,C11Z,(/ C11Z_LEN /)) + ENDIF + IF(CHEX) THEN + NBLOS=LX*LZ/3 + ALLOCATE(DIFF(NBLOS)) + ENDIF +*---- +* PERFORM ADI ITERATIONS AND LEGENDRE ORDER SWAPPING +*---- + ALLOCATE(FL(LL4F),FX(LL4X)) + IF(LL4W.GT.0) ALLOCATE(FW(LL4W)) + IF(LL4Y.GT.0) ALLOCATE(FY(LL4Y)) + IF(LL4Z.GT.0) ALLOCATE(FZ(LL4Z)) + IF(ISEG.GT.0) ALLOCATE(T(ISEG)) + DO 615 IADI=1,NADI + DO 610 IL=0,NLF-1 + JOFF=(IL/2)*L4 + IF(MOD(IL,2).EQ.0) THEN + DO 21 I0=1,LL4X + FX(I0)=F1(JOFF+IOFX+I0) + 21 CONTINUE + DO 22 I0=1,LL4Y + FY(I0)=F1(JOFF+IOFY+I0) + 22 CONTINUE + DO 23 I0=1,LL4Z + FZ(I0)=F1(JOFF+IOFZ+I0) + 23 CONTINUE + ENDIF + IF(CHEX) THEN + NBLOS=LX*LZ/3 + CALL PNFH3E(IL,NBMIX,NBLOS,IELEM,ICOL,NLF,NVD,NAN,L4,LL4F, + 1 MAT,SIGTI,SIDE,ZZ,FRZ,QFR,IPERT,KN,LC,R,V,S1,F1) + ELSE + CALL PNFL3E(IL,NREG,IELEM,ICOL,XX,YY,ZZ,MAT,VOL,NBMIX,NLF, + 1 NVD,NAN,SIGTI,L4,KN,QFR,LC,R,V,S1,F1) + ENDIF + IF(MOD(IL,2).EQ.1) THEN +*---- +* RECOVER CROSS SECTIONS FOR THE PIOLAT TERMS. +*---- + IF(CHEX) THEN + NBLOS=LX*LZ/3 + FACT=REAL(2*IL+1) + DO 25 KEL=1,NBLOS + DIFF(KEL)=0.0 + IF(IPERT(KEL).GT.0) THEN + IBM=MAT((IPERT(KEL)-1)*3+1) + IF(IBM.GT.0) THEN + GARS=SIGT(IBM,MIN(IL+1,NAN)) + IOF=(IPERT(KEL)-1)*3+1 + DIFF(KEL)=FACT*ZZ(IOF)*FRZ(KEL)*GARS + ENDIF + ENDIF + 25 CONTINUE + ENDIF +*---- +* W DIRECTION +*---- + IF(LL4W.GT.0) THEN + NBLOS=LX*LZ/3 + DO 30 I0=1,LL4F + FL(I0)=F1(JOFF+I0) + 30 CONTINUE + DO 50 I0=1,LL4X + DO 40 J0=1,2*IELEM + JJ=IPBX((I0-1)*2*IELEM+J0) + IF(JJ.EQ.0) GO TO 50 + FL(JJ)=FL(JJ)-BX((I0-1)*2*IELEM+J0)*REAL(IL)*FX(I0) + 40 CONTINUE + 50 CONTINUE + DO 70 I0=1,LL4Y + DO 60 J0=1,2*IELEM + JJ=IPBY((I0-1)*2*IELEM+J0) + IF(JJ.EQ.0) GO TO 70 + FL(JJ)=FL(JJ)-BY((I0-1)*2*IELEM+J0)*REAL(IL)*FY(I0) + 60 CONTINUE + 70 CONTINUE + DO 90 I0=1,LL4Z + DO 80 J0=1,2*IELEM + JJ=IPBZ((I0-1)*2*IELEM+J0) + IF(JJ.EQ.0) GO TO 90 + FL(JJ)=FL(JJ)-BZ((I0-1)*2*IELEM+J0)*REAL(IL)*FZ(I0) + 80 CONTINUE + 90 CONTINUE + DO 115 I0=1,LL4W + GGW=-F1(JOFF+IOFW+I0) + DO 100 J0=1,2*IELEM + JJ=IPBW((I0-1)*2*IELEM+J0) + IF(JJ.EQ.0) GO TO 110 + GGW=GGW+BW((I0-1)*2*IELEM+J0)*REAL(IL)* + 1 FL(JJ)/TF((IL/2)*LL4F+JJ) + 100 CONTINUE + 110 FW(I0)=GGW + 115 CONTINUE +* +* PIOLAT TRANSFORM TERM. + CALL FLDPWY(LL4W,LL4X,LL4Y,NBLOS,IELEM,CTRAN,IPERT,KN,DIFF, + 1 FY,FW) + CALL FLDPWX(LL4W,LL4X,NBLOS,IELEM,CTRAN,IPERT,KN,DIFF,FX,FW) + MUMAX=MUW(LL4W) + IF(ISEG.EQ.0) THEN +* SCALAR SOLUTION FOR A W-ORIENTED LINEAR SYSTEM. + CALL ALLDLS(LL4W,MUW,C11W(1+(IL/2)*MUMAX),FW) + ELSE IF(ISEG.GT.0) THEN +* SUPERVECTORIAL SOLUTION FOR A W-ORIENTED LINEAR SYSTEM. + ALLOCATE(GAR(LL4VW)) + GAR(:LL4VW)=0.0 + DO 120 I=1,LL4W + GAR(IPVW(I))=FW(I) + 120 CONTINUE + CALL ALVDLS(LTSW,MUW,C11W(1+(IL/2)*MUMAX),GAR,ISEG,LONW, + 1 NBLW,LBLW,T) + DO 130 I=1,LL4W + FW(I)=GAR(IPVW(I)) + 130 CONTINUE + DEALLOCATE(GAR) + ENDIF + ENDIF +*---- +* X DIRECTION +*---- + DO 140 I0=1,LL4F + FL(I0)=F1(JOFF+I0) + 140 CONTINUE + DO 160 I0=1,LL4W + DO 150 J0=1,2*IELEM + JJ=IPBW((I0-1)*2*IELEM+J0) + IF(JJ.EQ.0) GO TO 160 + FL(JJ)=FL(JJ)-BW((I0-1)*2*IELEM+J0)*REAL(IL)*FW(I0) + 150 CONTINUE + 160 CONTINUE + DO 180 I0=1,LL4Y + DO 170 J0=1,2*IELEM + JJ=IPBY((I0-1)*2*IELEM+J0) + IF(JJ.EQ.0) GO TO 180 + FL(JJ)=FL(JJ)-BY((I0-1)*2*IELEM+J0)*REAL(IL)*FY(I0) + 170 CONTINUE + 180 CONTINUE + DO 200 I0=1,LL4Z + DO 190 J0=1,2*IELEM + JJ=IPBZ((I0-1)*2*IELEM+J0) + IF(JJ.EQ.0) GO TO 200 + FL(JJ)=FL(JJ)-BZ((I0-1)*2*IELEM+J0)*REAL(IL)*FZ(I0) + 190 CONTINUE + 200 CONTINUE + DO 225 I0=1,LL4X + GGX=-F1(JOFF+IOFX+I0) + DO 210 J0=1,2*IELEM + JJ=IPBX((I0-1)*2*IELEM+J0) + IF(JJ.EQ.0) GO TO 220 + GGX=GGX+BX((I0-1)*2*IELEM+J0)*REAL(IL)*FL(JJ)/ + 1 TF((IL/2)*LL4F+JJ) + 210 CONTINUE + 220 FX(I0)=GGX + 225 CONTINUE + IF(LL4W.GT.0) THEN +* PIOLAT TRANSFORM TERM. + NBLOS=LX*LZ/3 + CALL FLDPXW(LL4W,LL4X,NBLOS,IELEM,CTRAN,IPERT,KN,DIFF,FW, + 1 FX) + CALL FLDPXY(LL4W,LL4X,LL4Y,NBLOS,IELEM,CTRAN,IPERT,KN, + 1 DIFF,FY,FX) + ENDIF + MUMAX=MUX(LL4X) + IF(ISEG.EQ.0) THEN +* SCALAR SOLUTION FOR A X-ORIENTED LINEAR SYSTEM. + CALL ALLDLS(LL4X,MUX,C11X(1+(IL/2)*MUMAX),FX) + ELSE IF(ISEG.GT.0) THEN +* SUPERVECTORIAL SOLUTION FOR A X-ORIENTED LINEAR SYSTEM. + ALLOCATE(GAR(LL4VX)) + GAR(:LL4VX)=0.0 + DO 230 I=1,LL4X + GAR(IPVX(I))=FX(I) + 230 CONTINUE + CALL ALVDLS(LTSW,MUX,C11X(1+(IL/2)*MUMAX),GAR,ISEG,LONX, + 1 NBLX,LBLX,T) + DO 240 I=1,LL4X + FX(I)=GAR(IPVX(I)) + 240 CONTINUE + DEALLOCATE(GAR) + ENDIF +*---- +* Y DIRECTION +*---- + IF(LL4Y.GT.0) THEN + DO 250 I0=1,LL4F + FL(I0)=F1(JOFF+I0) + 250 CONTINUE + DO 270 I0=1,LL4W + DO 260 J0=1,2*IELEM + JJ=IPBW((I0-1)*2*IELEM+J0) + IF(JJ.EQ.0) GO TO 270 + FL(JJ)=FL(JJ)-BW((I0-1)*2*IELEM+J0)*REAL(IL)*FW(I0) + 260 CONTINUE + 270 CONTINUE + DO 290 I0=1,LL4X + DO 280 J0=1,2*IELEM + JJ=IPBX((I0-1)*2*IELEM+J0) + IF(JJ.EQ.0) GO TO 290 + FL(JJ)=FL(JJ)-BX((I0-1)*2*IELEM+J0)*REAL(IL)*FX(I0) + 280 CONTINUE + 290 CONTINUE + DO 310 I0=1,LL4Z + DO 300 J0=1,2*IELEM + JJ=IPBZ((I0-1)*2*IELEM+J0) + IF(JJ.EQ.0) GO TO 310 + FL(JJ)=FL(JJ)-BZ((I0-1)*2*IELEM+J0)*REAL(IL)*FZ(I0) + 300 CONTINUE + 310 CONTINUE + DO 335 I0=1,LL4Y + GGY=-F1(JOFF+IOFY+I0) + DO 320 J0=1,2*IELEM + JJ=IPBY((I0-1)*2*IELEM+J0) + IF(JJ.EQ.0) GO TO 330 + GGY=GGY+BY((I0-1)*2*IELEM+J0)*REAL(IL)* + 1 FL(JJ)/TF((IL/2)*LL4F+JJ) + 320 CONTINUE + 330 FY(I0)=GGY + 335 CONTINUE + IF(LL4W.GT.0) THEN +* PIOLAT TRANSFORM TERM. + NBLOS=LX*LZ/3 + CALL FLDPYX(LL4W,LL4X,LL4Y,NBLOS,IELEM,CTRAN,IPERT,KN, + 1 DIFF,FX,FY) + CALL FLDPYW(LL4W,LL4X,LL4Y,NBLOS,IELEM,CTRAN,IPERT,KN, + 1 DIFF,FW,FY) + ENDIF + MUMAX=MUY(LL4Y) + IF(ISEG.EQ.0) THEN +* SCALAR SOLUTION FOR A Y-ORIENTED LINEAR SYSTEM. + CALL ALLDLS(LL4Y,MUY,C11Y(1+(IL/2)*MUMAX),FY) + ELSE IF(ISEG.GT.0) THEN +* SUPERVECTORIAL SOLUTION FOR A Y-ORIENTED LINEAR SYSTEM. + ALLOCATE(GAR(LL4VY)) + GAR(:LL4VY)=0.0 + DO 340 I=1,LL4Y + GAR(IPVY(I))=FY(I) + 340 CONTINUE + CALL ALVDLS(LTSW,MUY,C11Y(1+(IL/2)*MUMAX),GAR,ISEG,LONY, + 1 NBLY,LBLY,T) + DO 350 I=1,LL4Y + FY(I)=GAR(IPVY(I)) + 350 CONTINUE + DEALLOCATE(GAR) + ENDIF + ENDIF +*---- +* Z DIRECTION +*---- + IF(LL4Z.GT.0) THEN + DO 360 I0=1,LL4F + FL(I0)=F1(JOFF+I0) + 360 CONTINUE + DO 380 I0=1,LL4W + DO 370 J0=1,2*IELEM + JJ=IPBW((I0-1)*2*IELEM+J0) + IF(JJ.EQ.0) GO TO 380 + FL(JJ)=FL(JJ)-BW((I0-1)*2*IELEM+J0)*REAL(IL)*FW(I0) + 370 CONTINUE + 380 CONTINUE + DO 400 I0=1,LL4X + DO 390 J0=1,2*IELEM + JJ=IPBX((I0-1)*2*IELEM+J0) + IF(JJ.EQ.0) GO TO 400 + FL(JJ)=FL(JJ)-BX((I0-1)*2*IELEM+J0)*REAL(IL)*FX(I0) + 390 CONTINUE + 400 CONTINUE + DO 420 I0=1,LL4Y + DO 410 J0=1,2*IELEM + JJ=IPBY((I0-1)*2*IELEM+J0) + IF(JJ.EQ.0) GO TO 420 + FL(JJ)=FL(JJ)-BY((I0-1)*2*IELEM+J0)*REAL(IL)*FY(I0) + 410 CONTINUE + 420 CONTINUE + DO 445 I0=1,LL4Z + GGZ=-F1(JOFF+IOFZ+I0) + DO 430 J0=1,2*IELEM + JJ=IPBZ((I0-1)*2*IELEM+J0) + IF(JJ.EQ.0) GO TO 440 + GGZ=GGZ+BZ((I0-1)*2*IELEM+J0)*REAL(IL)* + 1 FL(JJ)/TF((IL/2)*LL4F+JJ) + 430 CONTINUE + 440 FZ(I0)=GGZ + 445 CONTINUE + MUMAX=MUZ(LL4Z) + IF(ISEG.EQ.0) THEN +* SCALAR SOLUTION FOR A Z-ORIENTED LINEAR SYSTEM. + CALL ALLDLS(LL4Z,MUZ,C11Z(1+(IL/2)*MUMAX),FZ) + ELSE IF(ISEG.GT.0) THEN +* SUPERVECTORIAL SOLUTION FOR A Z-ORIENTED LINEAR SYSTEM. + ALLOCATE(GAR(LL4VZ)) + GAR(:LL4VZ)=0.0 + DO 450 I=1,LL4Z + GAR(IPVZ(I))=FZ(I) + 450 CONTINUE + CALL ALVDLS(LTSW,MUZ,C11Z(1+(IL/2)*MUMAX),GAR,ISEG,LONZ, + 1 NBLZ,LBLZ,T) + DO 460 I=1,LL4Z + FZ(I)=GAR(IPVZ(I)) + 460 CONTINUE + DEALLOCATE(GAR) + ENDIF + ENDIF +*---- +* COMPUTE FLUX AND RECOVER CURRENTS +*---- + DO 470 I0=1,LL4F + FL(I0)=F1(JOFF+I0) + 470 CONTINUE + DO 490 J0=1,LL4W + DO 480 I0=1,2*IELEM + II=IPBW((J0-1)*2*IELEM+I0) + IF(II.EQ.0) GO TO 490 + FL(II)=FL(II)-BW((J0-1)*2*IELEM+I0)*REAL(IL)*FW(J0) + 480 CONTINUE + 490 CONTINUE + DO 510 J0=1,LL4X + DO 500 I0=1,2*IELEM + II=IPBX((J0-1)*2*IELEM+I0) + IF(II.EQ.0) GO TO 510 + FL(II)=FL(II)-BX((J0-1)*2*IELEM+I0)*REAL(IL)*FX(J0) + 500 CONTINUE + 510 CONTINUE + DO 530 J0=1,LL4Y + DO 520 I0=1,2*IELEM + II=IPBY((J0-1)*2*IELEM+I0) + IF(II.EQ.0) GO TO 530 + FL(II)=FL(II)-BY((J0-1)*2*IELEM+I0)*REAL(IL)*FY(J0) + 520 CONTINUE + 530 CONTINUE + DO 550 J0=1,LL4Z + DO 540 I0=1,2*IELEM + II=IPBZ((J0-1)*2*IELEM+I0) + IF(II.EQ.0) GO TO 550 + FL(II)=FL(II)-BZ((J0-1)*2*IELEM+I0)*REAL(IL)*FZ(J0) + 540 CONTINUE + 550 CONTINUE + DO 560 I0=1,LL4F + F1(JOFF+I0)=FL(I0)/TF((IL/2)*LL4F+I0) + 560 CONTINUE + IF(LL4W.GT.0) THEN + DO 570 I0=1,LL4W + F1(JOFF+IOFW+I0)=FW(I0) + 570 CONTINUE + ENDIF + DO 580 I0=1,LL4X + F1(JOFF+IOFX+I0)=FX(I0) + 580 CONTINUE + IF(LL4Y.GT.0) THEN + DO 590 I0=1,LL4Y + F1(JOFF+IOFY+I0)=FY(I0) + 590 CONTINUE + ENDIF + IF(LL4Z.GT.0) THEN + DO 600 I0=1,LL4Z + F1(JOFF+IOFZ+I0)=FZ(I0) + 600 CONTINUE + ENDIF + ENDIF + 610 CONTINUE + 615 CONTINUE + IF(ISEG.GT.0) DEALLOCATE(T) + DEALLOCATE(FL,FX) + IF(LL4W.GT.0) DEALLOCATE(FW) + IF(LL4Y.GT.0) DEALLOCATE(FY) + IF(LL4Z.GT.0) DEALLOCATE(FZ) + IF(.NOT.CHEX) DEALLOCATE(YY,XX) + DEALLOCATE(V,R,ZZ,IQFR,QFR,KN,VOL,MAT) + IF(CHEX) DEALLOCATE(DIFF) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SIGT,SIGTI) + RETURN + END diff --git a/Trivac/src/FLDTH1.f b/Trivac/src/FLDTH1.f new file mode 100755 index 0000000..0e56b1d --- /dev/null +++ b/Trivac/src/FLDTH1.f @@ -0,0 +1,60 @@ +*DECK FLDTH1 + SUBROUTINE FLDTH1 (ISPLH,NEL,LL4,EVECT,MAT,VOL,IDL,KN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the averaged flux for a linear primal formulation of +* the diffusion equation in hexagonal geometry with triangular +* mesh-splitting. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* ISPLH type of triangular mesh-splitting (ISPLH.GT.1). +* NEL total number of finite elements. +* LL4 order of the system matrices. +* EVECT variational coefficients of the flux. The information is +* contained in position EVECT(1) to EVECT(LL4). +* MAT mixture index assigned to each element. +* VOL volume of each element +* IDL position of the average flux component associated with each +* volume. +* KN element-ordered unknown list. +* +*Parameters: output +* EVECT averaged fluxes. The information is contained in positions +* EVECT(LL4+1) to EVECT(LL4+NEL). +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER ISPLH,NEL,LL4,MAT(NEL),IDL(NEL), + 1 KN(NEL*(18*(ISPLH-1)**2+8)) + REAL EVECT(LL4+NEL),VOL(NEL) +* + IVAL=18*(ISPLH-1)**2+8 + NUM1=0 + SS=1.0/REAL(6*(ISPLH-1)**2) + DO 70 K=1,NEL + IF(MAT(K).EQ.0) GO TO 70 + EVECT(IDL(K))=0.0 + IF(VOL(K).EQ.0.0) GO TO 60 + DO 50 I=1,6*(ISPLH-1)**2 + IND1=KN(NUM1+I) + IF(IND1.EQ.0) GO TO 50 + EVECT(IDL(K))=EVECT(IDL(K))+SS*EVECT(IND1) + 50 CONTINUE + 60 NUM1=NUM1+IVAL + 70 CONTINUE + RETURN + END diff --git a/Trivac/src/FLDTH2.f b/Trivac/src/FLDTH2.f new file mode 100755 index 0000000..f90b0be --- /dev/null +++ b/Trivac/src/FLDTH2.f @@ -0,0 +1,80 @@ +*DECK FLDTH2 + SUBROUTINE FLDTH2 (ISPLH,NEL,NUN,EVECT,MAT,VOL,IDL,KN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of the averaged flux with a linear Lagrangian finite +* element or mesh corner finite difference method in hexagonal geometry. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* ISPLH type of hexagonal mesh-splitting: =1 for complete hexagons; +* =2 for triangular mesh-splitting. +* NEL total number of finite elements. +* NUN total number of unknowns per energy group. +* EVECT variational coefficients of the flux. The information is +* contained in position EVECT(1) to EVECT(LL4) where LL4 is +* the order of the system matrices. +* MAT mixture index assigned to each element. +* VOL volume of each element. +* IDL position of the average flux component associated with each +* volume. +* KN element-ordered unknown list. +* +*Parameters: output +* EVECT averaged fluxes. The information is contained in positions +* EVECT(IDL(I)). +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER ISPLH,NEL,NUN,MAT(NEL),IDL(NEL),KN(14*NEL) + REAL EVECT(NUN),VOL(NEL) +*---- +* LOCAL VARIABLES +*---- + REAL TH(14) + SAVE TH + DATA TH/3*0.055555555556,0.166666666667,6*0.055555555556, + 1 0.166666666667,3*0.055555555556/ +* + NUM1=0 + IF(ISPLH.EQ.1) THEN + SS=1.0/12.0 + DO 40 K=1,NEL + IF(MAT(K).EQ.0) GO TO 40 + EVECT(IDL(K))=0.0 + IF(VOL(K).EQ.0.0) GO TO 30 + DO 20 I=1,12 + IND1=KN(NUM1+I) + IF(IND1.EQ.0) GO TO 20 + EVECT(IDL(K))=EVECT(IDL(K))+SS*EVECT(IND1) + 20 CONTINUE + 30 NUM1=NUM1+12 + 40 CONTINUE + ELSE IF(ISPLH.EQ.2) THEN + DO 70 K=1,NEL + IF(MAT(K).EQ.0) GO TO 70 + EVECT(IDL(K))=0.0 + IF(VOL(K).EQ.0.0) GO TO 60 + DO 50 I=1,14 + IND1=KN(NUM1+I) + IF(IND1.EQ.0) GO TO 50 + EVECT(IDL(K))=EVECT(IDL(K))+TH(I)*EVECT(IND1) + 50 CONTINUE + 60 NUM1=NUM1+14 + 70 CONTINUE + ENDIF + RETURN + END diff --git a/Trivac/src/FLDTHR.f b/Trivac/src/FLDTHR.f new file mode 100755 index 0000000..d27e6de --- /dev/null +++ b/Trivac/src/FLDTHR.f @@ -0,0 +1,300 @@ +*DECK FLDTHR + SUBROUTINE FLDTHR(IPTRK,IPSYS,IPFLUX,LADJ,LL4,ITY,NUN,NGRP,ICL1, + 1 ICL2,IMPX,NADI,NSTARD,MAXINR,EPSINR,ITER,TKT,TKB,GRAD1) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform thermal (up-scattering) iterations in Trivac. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK L_TRACK pointer to the tracking information. +* IPSYS L_SYSTEM pointer to system matrices. +* IPFLUX L_FLUX pointer to the solution. +* LADJ flag set to .TRUE. for adjoint solution acceleration. +* LL4 order of the system matrices. +* ITY type of solution (2: classical Trivac; 3: Thomas-Raviart). +* NUN number of unknowns in each energy group. +* NGRP number of energy groups. +* ICL1 number of free iterations in one cycle of the inverse power +* method. +* ICL2 number of accelerated iterations in one cycle. +* IMPX print parameter (set to 0 for no printing). +* NADI number of inner ADI iterations per outer iteration. +* NSTARD number of restarting iterations with GMRES. +* MAXINR maximum number of thermal iterations. +* EPSINR thermal iteration epsilon. +* +*Parameters: input/output +* ITER actual number of thermal iterations. +* TKT CPU time spent to compute the solution of linear systems. +* TKB CPU time spent to compute the bilinear products. +* GRAD1 delta flux for this outer iteration. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPSYS,IPFLUX + INTEGER LL4,ITY,NUN,NGRP,ICL1,ICL2,IMPX,NADI,NSTARD,MAXINR,ITER + REAL EPSINR,TKT,TKB,GRAD1(NUN,NGRP) + LOGICAL LADJ +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + INTEGER ISTATE(NSTATE) + REAL(KIND=8) DERTOL + CHARACTER TEXT12*12,TEXT3*3 + INTERFACE + FUNCTION FLDONE_TEMPLATE(X,B,N,IPTRK,IPSYS,IPFLUX) RESULT(Y) + USE GANLIB + INTEGER, INTENT(IN) :: N + REAL(KIND=8), DIMENSION(N), INTENT(IN) :: X, B + REAL(KIND=8), DIMENSION(N) :: Y + TYPE(C_PTR) IPTRK,IPSYS,IPFLUX + END FUNCTION FLDONE_TEMPLATE + END INTERFACE + PROCEDURE(FLDONE_TEMPLATE) :: FLDONE +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, DIMENSION(:), ALLOCATABLE :: W + REAL, DIMENSION(:,:), ALLOCATABLE :: GAR2 + REAL, DIMENSION(:,:,:), ALLOCATABLE :: WORK + REAL, DIMENSION(:), POINTER :: AGAR + REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: DWORK1,DWORK2 + TYPE(C_PTR) AGAR_PTR +*---- +* SCRATCH STORAGE ALLOCATION +*---- + IF(MAXINR.EQ.0) RETURN + ALLOCATE(GAR2(NUN,NGRP),WORK(LL4,NGRP,3)) +* + IF(NSTARD.GT.0) CALL LCMGET(IPFLUX,'STATE-VECTOR',ISTATE) + NCTOT=ICL1+ICL2 + IF(ICL2.EQ.0) THEN + NCPTM=NCTOT+1 + ELSE + NCPTM=ICL1 + ENDIF + DO 11 IGR=1,NGRP + DO 10 I=1,LL4 + WORK(I,IGR,1)=0.0 + WORK(I,IGR,2)=0.0 + WORK(I,IGR,3)=GRAD1(I,IGR) + 10 CONTINUE + 11 CONTINUE + IGDEB=1 +*---- +* PERFORM THERMAL (UP-SCATTERING) ITERATIONS +*---- + TEXT3='NO ' + ITER=2 + DO + CALL KDRCPU(TK1) + IF(LADJ) THEN +* ADJOINT SOLUTION + DO 31 IGR=IGDEB,NGRP + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,WORK(1,IGR,3), + 1 GAR2(1,IGR)) + DO 30 JGR=1,NGRP + IF(JGR.EQ.IGR) GO TO 30 + WRITE(TEXT12,'(1HA,2I3.3)') JGR,IGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 30 + IF(ITY.EQ.13) THEN + ALLOCATE(W(LL4)) + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,WORK(1,JGR,3), + 1 W(1)) + DO 15 I=1,LL4 + GAR2(I,IGR)=GAR2(I,IGR)-W(I) + 15 CONTINUE + DEALLOCATE(W) + ELSE + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ ILONG /)) + DO 20 I=1,ILONG + GAR2(I,IGR)=GAR2(I,IGR)-AGAR(I)*WORK(I,JGR,3) + 20 CONTINUE + ENDIF + 30 CONTINUE + 31 CONTINUE + DO 61 IGR=NGRP,IGDEB,-1 + DO 50 JGR=NGRP,IGR+1,-1 + WRITE(TEXT12,'(1HA,2I3.3)') JGR,IGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 50 + IF(ITY.EQ.13) THEN + ALLOCATE(W(LL4)) + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,GAR2(1,JGR),W(1)) + DO 35 I=1,LL4 + GAR2(I,IGR)=GAR2(I,IGR)+W(I) + 35 CONTINUE + DEALLOCATE(W) + ELSE + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ ILONG /)) + DO 40 I=1,ILONG + GAR2(I,IGR)=GAR2(I,IGR)+AGAR(I)*GAR2(I,JGR) + 40 CONTINUE + ENDIF + 50 CONTINUE + CALL KDRCPU(TK2) + TKB=TKB+(TK2-TK1) +* + CALL KDRCPU(TK1) + IF(NSTARD.EQ.0) THEN + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL FLDADI(TEXT12,IPTRK,IPSYS,LL4,ITY,GAR2(1,IGR),NADI) + JTER=NADI + ELSE +* use a GMRES solution of the linear system + DERTOL=EPSINR + ISTATE(39)=IGR + CALL LCMPUT(IPFLUX,'STATE-VECTOR',NSTATE,1,ISTATE) + ALLOCATE(DWORK1(LL4),DWORK2(LL4)) + DWORK1(:LL4)=GAR2(:LL4,IGR) ! source + DWORK2(:LL4)=WORK(:LL4,IGR,3) ! estimate of the flux + CALL FLDMRA(DWORK1,FLDONE,LL4,DERTOL,NSTARD,NADI,IMPX, + 1 IPTRK,IPSYS,IPFLUX,DWORK2,JTER) + GAR2(:LL4,IGR)=REAL(DWORK2(:LL4)) + DEALLOCATE(DWORK2,DWORK1) + ENDIF + DO 60 I=1,LL4 + WORK(I,IGR,1)=WORK(I,IGR,2) + WORK(I,IGR,2)=WORK(I,IGR,3) + WORK(I,IGR,3)=GRAD1(I,IGR)+(WORK(I,IGR,2)-GAR2(I,IGR)) + 60 CONTINUE + 61 CONTINUE + ELSE +* DIRECT SOLUTION + DO 81 IGR=IGDEB,NGRP + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,WORK(1,IGR,3), + 1 GAR2(1,IGR)) + DO 80 JGR=1,NGRP + IF(JGR.EQ.IGR) GO TO 80 + WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 80 + IF(ITY.EQ.13) THEN + ALLOCATE(W(LL4)) + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,WORK(1,JGR,3), + 1 W(1)) + DO 65 I=1,LL4 + GAR2(I,IGR)=GAR2(I,IGR)-W(I) + 65 CONTINUE + DEALLOCATE(W) + ELSE + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ ILONG /)) + DO 70 I=1,ILONG + GAR2(I,IGR)=GAR2(I,IGR)-AGAR(I)*WORK(I,JGR,3) + 70 CONTINUE + ENDIF + 80 CONTINUE + 81 CONTINUE + DO 115 IGR=IGDEB,NGRP + DO 100 JGR=1,IGR-1 + WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 100 + IF(ITY.EQ.13) THEN + ALLOCATE(W(LL4)) + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,GAR2(1,JGR),W(1)) + DO 85 I=1,LL4 + GAR2(I,IGR)=GAR2(I,IGR)+W(I) + 85 CONTINUE + DEALLOCATE(W) + ELSE + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ ILONG /)) + DO 90 I=1,ILONG + GAR2(I,IGR)=GAR2(I,IGR)+AGAR(I)*GAR2(I,JGR) + 90 CONTINUE + ENDIF + 100 CONTINUE + CALL KDRCPU(TK2) + TKB=TKB+(TK2-TK1) +* + CALL KDRCPU(TK1) + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + IF(NSTARD.EQ.0) THEN + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL FLDADI(TEXT12,IPTRK,IPSYS,LL4,ITY,GAR2(1,IGR),NADI) + JTER=NADI + ELSE +* use a GMRES solution of the linear system + DERTOL=EPSINR + ISTATE(39)=IGR + CALL LCMPUT(IPFLUX,'STATE-VECTOR',NSTATE,1,ISTATE) + ALLOCATE(DWORK1(LL4),DWORK2(LL4)) + DWORK1(:LL4)=GAR2(:LL4,IGR) ! source + DWORK2(:LL4)=WORK(:LL4,IGR,3) ! estimate of the flux + CALL FLDMRA(DWORK1,FLDONE,LL4,DERTOL,NSTARD,NADI,IMPX, + 1 IPTRK,IPSYS,IPFLUX,DWORK2,JTER) + GAR2(:LL4,IGR)=REAL(DWORK2(:LL4)) + DEALLOCATE(DWORK2,DWORK1) + ENDIF + DO 110 I=1,LL4 + WORK(I,IGR,1)=WORK(I,IGR,2) + WORK(I,IGR,2)=WORK(I,IGR,3) + WORK(I,IGR,3)=GRAD1(I,IGR)+(WORK(I,IGR,2)-GAR2(I,IGR)) + 110 CONTINUE + 115 CONTINUE + ENDIF + IF(MOD(ITER-2,NCTOT).GE.NCPTM) THEN + CALL FLD2AC(NGRP,LL4,IGDEB,WORK,ZMU) + ELSE + ZMU=1.0 + ENDIF + IGDEBO=IGDEB + DO 130 IGR=IGDEBO,NGRP + GINN=0.0 + FINN=0.0 + DO 120 I=1,LL4 + GINN=MAX(GINN,ABS(WORK(I,IGR,2)-WORK(I,IGR,3))) + FINN=MAX(FINN,ABS(WORK(I,IGR,3))) + 120 CONTINUE + GINN=GINN/FINN + IF((GINN.LT.EPSINR).AND.(IGDEB.EQ.IGR)) IGDEB=IGDEB+1 + 130 CONTINUE + CALL KDRCPU(TK2) + TKT=TKT+(TK2-TK1) + IF(GINN.LT.EPSINR) TEXT3='YES' + IF(IMPX.GT.2) WRITE(6,1000) ITER,GINN,EPSINR,IGDEB,ZMU,TEXT3, + 1 JTER + IF((GINN.LT.EPSINR).OR.(ITER.EQ.MAXINR)) EXIT + ITER=ITER+1 + ENDDO +*---- +* END OF THERMAL ITERATIONS +*---- + DO 175 I=1,LL4 + DO 170 IGR=1,NGRP + GRAD1(I,IGR)=WORK(I,IGR,3) + 170 CONTINUE + 175 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(GAR2,WORK) + RETURN +* + 1000 FORMAT (10X,3HIN(,I3,6H) FLX:,5H PRC=,1P,E9.2,5H TAR=,E9.2, + 1 7H IGDEB=, I13,6H ACCE=,0P,F12.5,12H CONVERGED=,A3,6H JTER=, + 2 I4) + END diff --git a/Trivac/src/FLDTMX.f b/Trivac/src/FLDTMX.f new file mode 100755 index 0000000..aaaf33d --- /dev/null +++ b/Trivac/src/FLDTMX.f @@ -0,0 +1,305 @@ +*DECK FLDTMX + FUNCTION FLDTMX(F,N,IBLSZ,ITER,IPTRK,IPSYS,IPFLUX) RESULT(X) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Multiplication of A^(-1)B times the harmonic flux in TRIVAC. +* +*Copyright: +* Copyright (C) 2020 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* F harmonic flux vector. +* N number of unknowns in one harmonic. +* IBLSZ block size of the Arnoldi Hessenberg matrix. +* ITER Arnoldi iteration index. +* IPTRK L_TRACK pointer to the tracking information. +* IPSYS L_SYSTEM pointer to system matrices. +* IPFLUX L_FLUX pointer to the solution. +* +*Parameters: output +* X result of the multiplication. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER, INTENT(IN) :: N,IBLSZ,ITER + COMPLEX(KIND=8), DIMENSION(N,IBLSZ), INTENT(IN) :: F + COMPLEX(KIND=8), DIMENSION(N,IBLSZ) :: X + TYPE(C_PTR) IPTRK,IPSYS,IPFLUX +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + INTEGER ISTATE(NSTATE) + REAL EPSCON(5),TIME(2) + CHARACTER TEXT12*12,HSMG*131 + LOGICAL LADJ,LUPS + REAL(KIND=8) DERTOL + INTERFACE + FUNCTION FLDONE_TEMPLATE(X,B,N,IPTRK,IPSYS,IPFLUX) RESULT(Y) + USE GANLIB + INTEGER, INTENT(IN) :: N + REAL(KIND=8), DIMENSION(N), INTENT(IN) :: X, B + REAL(KIND=8), DIMENSION(N) :: Y + TYPE(C_PTR) IPTRK,IPSYS,IPFLUX + END FUNCTION FLDONE_TEMPLATE + END INTERFACE + PROCEDURE(FLDONE_TEMPLATE) :: FLDONE +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, DIMENSION(:), ALLOCATABLE :: WORK + REAL, DIMENSION(:,:), ALLOCATABLE :: GAF1,GRAD + REAL, DIMENSION(:), POINTER :: AGAR + REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: DWORK1,DWORK2 + TYPE(C_PTR) AGAR_PTR +* +* TIME(1) : CPU TIME FOR THE SOLUTION OF LINEAR SYSTEMS. +* TIME(2) : CPU TIME FOR BILINEAR PRODUCT EVALUATIONS. + CALL LCMGET(IPFLUX,'CPU-TIME',TIME) + CALL KDRCPU(TK1) +*---- +* RECOVER INFORMATION FROM IPTRK, IPSYS AND IPFLUX +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + NEL=ISTATE(1) + NUN=ISTATE(2) + NLF=ISTATE(30) + CALL LCMGET(IPSYS,'STATE-VECTOR',ISTATE) + NGRP=ISTATE(1) + LL4=ISTATE(2) + ITY=ISTATE(4) + NBMIX=ISTATE(7) + NAN=ISTATE(8) + IF(ITY.EQ.13) LL4=LL4*NLF/2 ! SPN cases + CALL LCMGET(IPFLUX,'STATE-VECTOR',ISTATE) + LADJ=ISTATE(3).EQ.10 + ICL1=ISTATE(8) + ICL2=ISTATE(9) + IREBAL=ISTATE(10) + MAXINR=ISTATE(11) + NADI=ISTATE(13) + NSTARD=ISTATE(15) + IMPX=ISTATE(40) + CALL LCMGET(IPFLUX,'EPS-CONVERGE',EPSCON) + EPSINR=EPSCON(1) + EPSMSR=EPSCON(4) + IF(LL4*NGRP.NE.N) CALL XABORT('FLDTMX: INCONSISTENT UNKNOWNS.') +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(WORK(NUN),GAF1(NUN,NGRP),GRAD(NUN,NGRP)) +*---- +* CHECK FOR UP-SCATTERING. +*---- + LUPS=.FALSE. + DO 20 IGR=1,NGRP-1 + DO 10 JGR=IGR+1,NGRP + WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + LUPS=.TRUE. + MAXINR=MAX(MAXINR,10) + GO TO 30 + ENDIF + 10 CONTINUE + 20 CONTINUE +*---- +* MAIN LOOP OVER MODES. +*---- + 30 DO 240 IMOD=1,IBLSZ + IF(LADJ) THEN +* ADJOINT SOLUTION +*---- +* COMPUTE B TIMES THE FLUX. +*---- + DO 70 IGR=1,NGRP + DO 40 I=1,LL4 + GAF1(I,IGR)=0.0 + 40 CONTINUE + DO 60 JGR=1,NGRP + WRITE(TEXT12,'(1HB,2I3.3)') JGR,IGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 60 + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ ILONG /)) + DO 50 I=1,ILONG + IOF=(JGR-1)*LL4+I + GAF1(I,IGR)=GAF1(I,IGR)+AGAR(I)*REAL(F(IOF,IMOD),KIND=4) + IF(ABS(AIMAG(F(IOF,IMOD))).GT.1.0E-8) THEN + WRITE(HSMG,'(13HFLDTMX: FLUX(,2I8,2H)=,1P,2E12.4, + 1 12H IS COMPLEX.)') IOF,IMOD,F(IOF,IMOD) + CALL XABORT(HSMG) + ENDIF + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + CALL KDRCPU(TK2) + TIME(2)=TIME(2)+(TK2-TK1) +*---- +* COMPUTE A^(-1)B WITHOUT DOWN-SCATTERING. +*---- + DO 120 IGR=NGRP,1,-1 + CALL KDRCPU(TK1) + DO 80 I=1,LL4 + GRAD(I,IGR)=GAF1(I,IGR) + 80 CONTINUE + DO 110 JGR=NGRP,IGR+1,-1 + WRITE(TEXT12,'(1HA,2I3.3)') JGR,IGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 110 + IF(ITY.EQ.13) THEN + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD(1,JGR),WORK) + DO 90 I=1,LL4 + GRAD(I,IGR)=GRAD(I,IGR)+WORK(I) + 90 CONTINUE + ELSE + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ ILONG /)) + DO 100 I=1,ILONG + GRAD(I,IGR)=GRAD(I,IGR)+AGAR(I)*GRAD(I,JGR) + 100 CONTINUE + ENDIF + 110 CONTINUE + CALL KDRCPU(TK2) + TIME(2)=TIME(2)+(TK2-TK1) +* + CALL KDRCPU(TK1) + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + IF(NSTARD.EQ.0) THEN + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL FLDADI(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD(1,IGR),NADI) + JTER=NADI + ELSE +* use a GMRES solution of the linear system + DERTOL=EPSMSR + ISTATE(39)=IGR + CALL LCMPUT(IPFLUX,'STATE-VECTOR',NSTATE,1,ISTATE) + ALLOCATE(DWORK1(LL4),DWORK2(LL4)) + DWORK1(:LL4)=GRAD(:LL4,IGR) ! source + DWORK2(:LL4)=0.0 ! estimate of the flux + CALL FLDMRA(DWORK1,FLDONE,LL4,DERTOL,NSTARD,NADI,IMPX,IPTRK, + 1 IPSYS,IPFLUX,DWORK2,JTER) + GRAD(:LL4,IGR)=REAL(DWORK2(:LL4)) + DEALLOCATE(DWORK2,DWORK1) + ENDIF + CALL KDRCPU(TK2) + TIME(1)=TIME(1)+(TK2-TK1) + 120 CONTINUE + ELSE +* DIRECT SOLUTION +*---- +* COMPUTE B TIMES THE FLUX. +*---- + DO 160 IGR=1,NGRP + DO 130 I=1,LL4 + GAF1(I,IGR)=0.0 + 130 CONTINUE + DO 150 JGR=1,NGRP + WRITE(TEXT12,'(1HB,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 150 + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ ILONG /)) + DO 140 I=1,ILONG + IOF=(JGR-1)*LL4+I + GAF1(I,IGR)=GAF1(I,IGR)+AGAR(I)*REAL(F(IOF,IMOD),KIND=4) + IF(ABS(AIMAG(F(IOF,IMOD))).GT.1.0E-8) THEN + WRITE(HSMG,'(13HFLDTMX: FLUX(,2I8,2H)=,1P,2E12.4, + 1 12H IS COMPLEX.)') IOF,IMOD,F(IOF,IMOD) + CALL XABORT(HSMG) + ENDIF + 140 CONTINUE + 150 CONTINUE + 160 CONTINUE + CALL KDRCPU(TK2) + TIME(2)=TIME(2)+(TK2-TK1) +*---- +* COMPUTE A^(-1)B WITHOUT UP-SCATTERING. +*---- + DO 210 IGR=1,NGRP + CALL KDRCPU(TK1) + DO 170 I=1,LL4 + GRAD(I,IGR)=GAF1(I,IGR) + 170 CONTINUE + DO 200 JGR=1,IGR-1 + WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 200 + IF(ITY.EQ.13) THEN + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD(1,JGR),WORK) + DO 180 I=1,LL4 + GRAD(I,IGR)=GRAD(I,IGR)+WORK(I) + 180 CONTINUE + ELSE + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ ILONG /)) + DO 190 I=1,ILONG + GRAD(I,IGR)=GRAD(I,IGR)+AGAR(I)*GRAD(I,JGR) + 190 CONTINUE + ENDIF + 200 CONTINUE + CALL KDRCPU(TK2) + TIME(2)=TIME(2)+(TK2-TK1) +* + CALL KDRCPU(TK1) + IF(NSTARD.EQ.0) THEN + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL FLDADI(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD(1,IGR),NADI) + JTER=-NADI + ELSE +* use a GMRES solution of the linear system + DERTOL=EPSMSR + ISTATE(39)=IGR + CALL LCMPUT(IPFLUX,'STATE-VECTOR',NSTATE,1,ISTATE) + ALLOCATE(DWORK1(LL4),DWORK2(LL4)) + DWORK1(:LL4)=GRAD(:LL4,IGR) ! source + DWORK2(:LL4)=0.0 ! estimate of the flux + CALL FLDMRA(DWORK1,FLDONE,LL4,DERTOL,NSTARD,NADI,IMPX,IPTRK, + 1 IPSYS,IPFLUX,DWORK2,JTER) + GRAD(:LL4,IGR)=REAL(DWORK2(:LL4)) + DEALLOCATE(DWORK2,DWORK1) + ENDIF + CALL KDRCPU(TK2) + TIME(1)=TIME(1)+(TK2-TK1) + 210 CONTINUE + ENDIF +*---- +* PERFORM THERMAL (UP/DOWN-SCATTERING) ITERATIONS. +*---- + KTER=0 + IF((IREBAL.EQ.1).OR.LUPS) THEN + CALL FLDTHR(IPTRK,IPSYS,IPFLUX,LADJ,LL4,ITY,NUN,NGRP,ICL1,ICL2, + 1 IMPX,NADI,NSTARD,MAXINR,EPSINR,KTER,TIME(1),TIME(2),GRAD) + ENDIF + DO 230 IGR=1,NGRP + DO 220 I=1,LL4 + IOF=(IGR-1)*LL4+I + X(IOF,IMOD)=GRAD(I,IGR) + 220 CONTINUE + 230 CONTINUE +*---- +* END OF LOOP OVER MODES. +*---- + 240 CONTINUE + CALL LCMPUT(IPFLUX,'CPU-TIME',2,2,TIME) + IF(IMPX.GT.10) WRITE(6,250) ITER,JTER,KTER +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(GRAD,GAF1,WORK) + RETURN + 250 FORMAT(49H FLDTMX: MATRIX MULTIPLICATION AT IRAM ITERATION=,I5, + 1 18H INNER ITERATIONS=,I5,20H THERMAL ITERATIONS=,I5) + END FUNCTION FLDTMX diff --git a/Trivac/src/FLDTN2.f b/Trivac/src/FLDTN2.f new file mode 100755 index 0000000..50a80f4 --- /dev/null +++ b/Trivac/src/FLDTN2.f @@ -0,0 +1,85 @@ +*DECK FLDTN2 + SUBROUTINE FLDTN2 (NEL,LL4,IELEM,CYLIND,EVECT,XX,DD,MAT,VOL,IDL, + 1 KN,LC,T,TS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the integrated flux in each finite element for a Lagrangian +* finite element discretization in Cartesian or cylindrical geometry. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NEL number of finite elements. +* LL4 order of system matrices. +* IELEM degree of the finite elements. +* CYLIND cylindrical geometry flag (set with CYLIND=.true.). +* EVECT unknown vector containing the variational coefficients in +* locations 1 to LL4. +* XX X-directed mesh spacings. +* DD used with cylindrical geometry. +* MAT mixture index assigned to each element. +* VOL volume of each element. +* IDL indices pointing to integrated fluxes in EVECT array. +* KN element-ordered unknown list. +* LC order of the finite element basis. +* T linear product vector. +* TS linear product vector. +* +*Parameters: output +* EVECT unknown vector containing the integrated fluxes in location +* IDL(I). +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NEL,LL4,IELEM,MAT(NEL),IDL(NEL),KN(NEL*(IELEM+1)**3),LC + REAL EVECT(LL4+NEL),XX(NEL),DD(NEL),VOL(NEL),T(LC),TS(LC) + LOGICAL CYLIND +*---- +* LOCAL VARIABLES +*---- + INTEGER IJ1(125),IJ2(125),IJ3(125) +* + LL=LC*LC*LC + DO 100 L=1,LL + L1=1+MOD(L-1,LC) + L2=1+(L-L1)/LC + L3=1+MOD(L2-1,LC) + IJ1(L)=L1 + IJ2(L)=L3 + IJ3(L)=1+(L2-L3)/LC + 100 CONTINUE +* + NUM1=0 + DO 130 K=1,NEL + IF(MAT(K).EQ.0) GO TO 130 + EVECT(IDL(K))=0.0 + IF(VOL(K).EQ.0.0) GO TO 120 + DO 110 I=1,LL + IND1=KN(NUM1+I) + IF(IND1.EQ.0) GO TO 110 + I1=IJ1(I) + I2=IJ2(I) + I3=IJ3(I) + IF(CYLIND) THEN + SS=(T(I1)+TS(I1)*XX(K)/DD(K))*T(I2)*T(I3) + ELSE + SS=T(I1)*T(I2)*T(I3) + ENDIF + EVECT(IDL(K))=EVECT(IDL(K))+SS*EVECT(IND1) + 110 CONTINUE + 120 NUM1=NUM1+LL + 130 CONTINUE + RETURN + END diff --git a/Trivac/src/FLDTRI.f b/Trivac/src/FLDTRI.f new file mode 100755 index 0000000..f4fbb4f --- /dev/null +++ b/Trivac/src/FLDTRI.f @@ -0,0 +1,93 @@ +*DECK FLDTRI + SUBROUTINE FLDTRI(IPTRK,NEL,NUN,EVECT,MAT,VOL,IDL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculation of the averaged flux in TRIVAC. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK L_TRACK pointer to the trivac tracking information. +* NEL total number of finite elements. +* NUN total number of unknown per energy group. +* EVECT variational coefficients of the flux (contained in position +* EVECT(1) to EVECT(LL4)). +* MAT mixture index assigned to each element. +* VOL volume of each element. +* IDL position of the average flux component associated with each +* volume. +* +*Parameters: output +* EVECT averaged fluxes (contained in positions EVECT(IDL(I))). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK + INTEGER NEL,NUN,MAT(NEL),IDL(NEL) + REAL EVECT(NUN),VOL(NEL) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + LOGICAL CYLIND,CHEX + INTEGER ITP(NSTATE) + INTEGER, DIMENSION(:), ALLOCATABLE :: KN + REAL, DIMENSION(:), ALLOCATABLE :: XX,DD,T,TS +*---- +* RECOVER TRIVAC SPECIFIC TRACKING INFORMATION +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',ITP) + ITYPE=ITP(6) + CYLIND=(ITYPE.EQ.3).OR.(ITYPE.EQ.6) + CHEX=(ITYPE.EQ.8).OR.(ITYPE.EQ.9) + IELEM=ABS(ITP(9)) + LL4=ITP(11) + ICHX=ITP(12) + ISPLH=ITP(13) + LX=ITP(14) + LY=ITP(15) + LZ=ITP(16) + CALL LCMLEN(IPTRK,'KN',MAXKN,ITYLCM) + ALLOCATE(KN(MAXKN)) + CALL LCMGET(IPTRK,'KN',KN) +* + IF((ICHX.EQ.1).AND.(.NOT.CHEX)) THEN +* LAGRANGIAN FINITE ELEMENTS. + ALLOCATE(XX(LX*LY*LZ),DD(LX*LY*LZ)) + CALL LCMGET(IPTRK,'XX',XX) + CALL LCMGET(IPTRK,'DD',DD) + CALL LCMSIX(IPTRK,'BIVCOL',1) + CALL LCMLEN(IPTRK,'T',LC,ITYLCM) + ALLOCATE(T(LC),TS(LC)) + CALL LCMGET(IPTRK,'T',T) + CALL LCMGET(IPTRK,'TS',TS) + CALL LCMSIX(IPTRK,' ',2) + CALL FLDTN2(NEL,LL4,IELEM,CYLIND,EVECT,XX,DD,MAT,VOL,IDL,KN, + 1 LC,T,TS) + DEALLOCATE(TS,T,DD,XX) + ELSE IF((ICHX.EQ.1).AND.CHEX) THEN +* MESH CORNER FINITE DIFFERENCES IN HEXAGONAL GEOMETRY. + CALL FLDTH2(ISPLH,NEL,NUN,EVECT,MAT,VOL,IDL,KN) + ELSE IF((ICHX.EQ.3).AND.(ISPLH.GT.1).AND.CHEX) THEN +* MESH CENTERED FINITE DIFFERENCES IN HEXAGONAL GEOMETRY. + CALL FLDTH1(ISPLH,NEL,LL4,EVECT,MAT,VOL,IDL,KN) + ENDIF +*---- +* RELEASE TRIVAC SPECIFIC TRACKING INFORMATION +*---- + DEALLOCATE(KN) + RETURN + END diff --git a/Trivac/src/FLDTRM.f b/Trivac/src/FLDTRM.f new file mode 100755 index 0000000..c39f87a --- /dev/null +++ b/Trivac/src/FLDTRM.f @@ -0,0 +1,379 @@ +*DECK FLDTRM + SUBROUTINE FLDTRM(NAMP,IPTRK,IPSYS,LL4,F2,F3) +* +*----------------------------------------------------------------------- +* +*Purpose: +* LCM driver for the multiplication of a matrix by a vector. Special +* version for Thomas-Raviart or Thomas-Raviart-Schneider basis. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NAMP name of the coefficient matrix. +* IPTRK L_TRACK pointer to the tracking information. +* IPSYS L_SYSTEM pointer to system matrices. +* LL4 order of the matrix. +* F2 vector to multiply. +* +*Parameters: output +* F3 result of the multiplication. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPSYS + CHARACTER NAMP*12 + INTEGER LL4 + REAL F2(LL4),F3(LL4) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + CHARACTER NAMT*12 + INTEGER ITP(NSTATE),ITS(NSTATE) + LOGICAL LMUX,DIAG + INTEGER ASS_LEN + REAL, DIMENSION(:), ALLOCATABLE :: GAR,GAF + INTEGER, DIMENSION(:), POINTER :: KN,IPERT,IPBW,MUW,IPVW,NBLW, + 1 LBLW,IPBX,MUX,IPVX,NBLX,LBLX,IPBY,MUY,IPVY,NBLY,LBLY,IPBZ,MUZ, + 2 IPVZ,NBLZ,LBLZ + REAL, DIMENSION(:), POINTER :: TF,DIFF,AW,BW,AX,BX,AY,BY,AZ,BZ + DOUBLE PRECISION, DIMENSION(:), POINTER :: CTRAN + TYPE(C_PTR) KN_PTR,IPERT_PTR,DIFF_PTR,TF_PTR,CTRAN_PTR, + 1 AW_PTR,BW_PTR,IPBW_PTR,MUW_PTR,IPVW_PTR,NBLW_PTR,LBLW_PTR, + 2 AX_PTR,BX_PTR,IPBX_PTR,MUX_PTR,IPVX_PTR,NBLX_PTR,LBLX_PTR, + 3 AY_PTR,BY_PTR,IPBY_PTR,MUY_PTR,IPVY_PTR,NBLY_PTR,LBLY_PTR, + 4 AZ_PTR,BZ_PTR,IPBZ_PTR,MUZ_PTR,IPVZ_PTR,NBLZ_PTR,LBLZ_PTR +*---- +* INITIALIZATION +*---- + NAMT=NAMP + CALL LCMGET(IPTRK,'STATE-VECTOR',ITP) + IELEM=ITP(9) + ISEG=ITP(17) + LTSW=ITP(19) + LL4F=ITP(25) + LL4W=ITP(26) + LL4X=ITP(27) + LL4Y=ITP(28) + LL4Z=ITP(29) + NLF=ITP(30) + IOFW=LL4F + IOFX=LL4F+LL4W + IOFY=LL4F+LL4W+LL4X + IOFZ=LL4F+LL4W+LL4X+LL4Y + CALL LCMLEN(IPTRK,'MUX',IDUM,ITYLCM) + LMUX=(IDUM.NE.0).AND.(ITYLCM.EQ.1) + DIAG=(LL4Y.GT.0).AND.(.NOT.LMUX) + CALL LCMGPD(IPSYS,'TF'//NAMT,TF_PTR) + CALL C_F_POINTER(TF_PTR,TF,(/ LL4F*NLF/2 /)) +*---- +* RECOVER THE PERTURBATION FLAG. +*---- + CALL LCMGET(IPSYS,'STATE-VECTOR',ITS) + IPR=ITS(9) +* + NULLIFY(IPBW) + NULLIFY(BW) + IF(LL4W.GT.0) THEN + ISPLH=ITP(13) + LX=ITP(14) + LZ=ITP(16) + NBLOS=LX*LZ/3 + CALL LCMLEN(IPTRK,'KN',MAXKN,ITYLCM) + CALL LCMGPD(IPTRK,'CTRAN',CTRAN_PTR) + CALL LCMGPD(IPTRK,'KN',KN_PTR) + CALL LCMGPD(IPTRK,'IPERT',IPERT_PTR) + CALL LCMGPD(IPSYS,'DIFF'//NAMT,DIFF_PTR) + CALL C_F_POINTER(CTRAN_PTR,CTRAN,(/ ((IELEM+1)*IELEM)**2 /)) + CALL C_F_POINTER(KN_PTR,KN,(/ MAXKN /)) + CALL C_F_POINTER(IPERT_PTR,IPERT,(/ NBLOS /)) + CALL C_F_POINTER(DIFF_PTR,DIFF,(/ NBLOS /)) +* + CALL LCMGPD(IPSYS,'WA'//NAMT,AW_PTR) + CALL LCMGPD(IPTRK,'IPBBW',IPBW_PTR) + CALL LCMGPD(IPTRK,'WB',BW_PTR) + CALL C_F_POINTER(IPBW_PTR,IPBW,(/ 2*IELEM*LL4W /)) + CALL C_F_POINTER(BW_PTR,BW,(/ 2*IELEM*LL4W /)) + IF(ISEG.EQ.0) THEN +* SCALAR MULTIPLICATION FOR A W-ORIENTED MATRIX. + CALL LCMGPD(IPTRK,'MUW',MUW_PTR) + CALL C_F_POINTER(MUW_PTR,MUW,(/ LL4W /)) + CALL C_F_POINTER(AW_PTR,AW,(/ MUW(LL4W) /)) + CALL ALLDLM(LL4W,AW,F2(IOFW+1),F3(IOFW+1),MUW,1) + ELSE IF(ISEG.GT.0) THEN +* SUPERVECTORIAL MULTIPLICATION FOR A W-ORIENTED MATRIX. + CALL LCMGET(IPTRK,'LL4VW',LL4VW) + CALL LCMGPD(IPTRK,'MUVW',MUW_PTR) + CALL LCMGPD(IPTRK,'IPVW',IPVW_PTR) + CALL LCMLEN(IPTRK,'NBLW',LONW,ITYLCM) + CALL LCMGPD(IPTRK,'NBLW',NBLW_PTR) + CALL LCMGPD(IPTRK,'LBLW',LBLW_PTR) + CALL C_F_POINTER(MUW_PTR,MUW,(/ LL4VW/ISEG /)) + CALL C_F_POINTER(IPVW_PTR,IPVW,(/ LL4W /)) + CALL C_F_POINTER(NBLW_PTR,NBLW,(/ LONW /)) + CALL C_F_POINTER(LBLW_PTR,LBLW,(/ LONW /)) + CALL LCMLEN(IPSYS,'WA'//NAMT,ASS_LEN,ITYLCM) + CALL C_F_POINTER(AW_PTR,AW,(/ ASS_LEN /)) + ALLOCATE(GAR(LL4VW),GAF(LL4VW)) + GAR(:LL4VW)=0.0 + DO 20 I=1,LL4W + GAR(IPVW(I))=F2(IOFW+I) + 20 CONTINUE + CALL C_F_POINTER(AW_PTR,AW,(/ ISEG*MUW(LL4VW) /)) + CALL ALVDLM(LTSW,AW,GAR,GAF,MUW,1,ISEG,LONW,NBLW,LBLW) + DO 30 I=1,LL4W + F3(IOFW+I)=GAF(IPVW(I)) + 30 CONTINUE + DEALLOCATE(GAF,GAR) + ENDIF + IF((IPR.NE.1).AND.(IPR.NE.2)) THEN + DO 55 I=1,LL4W + GG=F3(IOFW+I) + DO 40 J=1,2*IELEM + II=IPBW((I-1)*2*IELEM+J) + IF(II.EQ.0) GO TO 50 + GG=GG+BW((I-1)*2*IELEM+J)*F2(II) + 40 CONTINUE + 50 F3(IOFW+I)=GG + 55 CONTINUE + ENDIF +* +* PIOLAT TRANSFORM TERM. + CALL FLDPWY(LL4W,LL4X,LL4Y,NBLOS,IELEM,CTRAN,IPERT,KN, + 1 DIFF,F2(IOFY+1),F3(IOFW+1)) + CALL FLDPWX(LL4W,LL4X,NBLOS,IELEM,CTRAN,IPERT,KN,DIFF, + 1 F2(IOFX+1),F3(IOFW+1)) + ENDIF +* + IF(DIAG) THEN + CALL LCMGPD(IPSYS,'YA'//NAMT,AX_PTR) + ELSE + CALL LCMGPD(IPSYS,'XA'//NAMT,AX_PTR) + ENDIF + CALL LCMGPD(IPTRK,'IPBBX',IPBX_PTR) + CALL LCMGPD(IPTRK,'XB',BX_PTR) + CALL C_F_POINTER(IPBX_PTR,IPBX,(/ 2*IELEM*LL4X /)) + CALL C_F_POINTER(BX_PTR,BX,(/ 2*IELEM*LL4X /)) + IF(ISEG.EQ.0) THEN +* SCALAR MULTIPLICATION FOR A X-ORIENTED MATRIX. + IF(DIAG) THEN + CALL LCMGPD(IPTRK,'MUY',MUX_PTR) + ELSE + CALL LCMGPD(IPTRK,'MUX',MUX_PTR) + ENDIF + CALL C_F_POINTER(MUX_PTR,MUX,(/ LL4X /)) + CALL C_F_POINTER(AX_PTR,AX,(/ MUX(LL4X) /)) + CALL ALLDLM(LL4X,AX,F2(IOFX+1),F3(IOFX+1),MUX,1) + ELSE IF(ISEG.GT.0) THEN +* SUPERVECTORIAL MULTIPLICATION FOR A X-ORIENTED MATRIX. + IF(DIAG) THEN + CALL LCMGET(IPTRK,'LL4VY',LL4VX) + CALL LCMGPD(IPTRK,'MUVY',MUX_PTR) + CALL LCMGPD(IPTRK,'IPVY',IPVX_PTR) + CALL LCMLEN(IPTRK,'NBLY',LONX,ITYLCM) + CALL LCMGPD(IPTRK,'NBLY',NBLX_PTR) + CALL LCMGPD(IPTRK,'LBLY',LBLX_PTR) + ELSE + CALL LCMGET(IPTRK,'LL4VX',LL4VX) + CALL LCMGPD(IPTRK,'MUVX',MUX_PTR) + CALL LCMGPD(IPTRK,'IPVX',IPVX_PTR) + CALL LCMLEN(IPTRK,'NBLX',LONX,ITYLCM) + CALL LCMGPD(IPTRK,'NBLX',NBLX_PTR) + CALL LCMGPD(IPTRK,'LBLX',LBLX_PTR) + ENDIF + CALL C_F_POINTER(MUX_PTR,MUX,(/ LL4VX/ISEG /)) + CALL C_F_POINTER(IPVX_PTR,IPVX,(/ LL4X /)) + CALL C_F_POINTER(NBLX_PTR,NBLX,(/ LONX /)) + CALL C_F_POINTER(LBLX_PTR,LBLX,(/ LONX /)) + CALL LCMLEN(IPSYS,'XA'//NAMT,ASS_LEN,ITYLCM) + CALL C_F_POINTER(AX_PTR,AX,(/ ASS_LEN /)) + ALLOCATE(GAR(LL4VX),GAF(LL4VX)) + GAR(:LL4VX)=0.0 + DO 70 I=1,LL4X + GAR(IPVX(I))=F2(IOFX+I) + 70 CONTINUE + CALL ALVDLM(LTSW,AX,GAR,GAF,MUX,1,ISEG,LONX,NBLX,LBLX) + DO 80 I=1,LL4X + F3(IOFX+I)=GAF(IPVX(I)) + 80 CONTINUE + DEALLOCATE(GAF,GAR) + ENDIF + IF((IPR.NE.1).AND.(IPR.NE.2)) THEN + DO 105 I=1,LL4X + GG=F3(IOFX+I) + DO 90 J=1,2*IELEM + II=IPBX((I-1)*2*IELEM+J) + IF(II.EQ.0) GO TO 100 + GG=GG+BX((I-1)*2*IELEM+J)*F2(II) + 90 CONTINUE + 100 F3(IOFX+I)=GG + 105 CONTINUE + ENDIF +* + IF(LL4W.GT.0) THEN +* PIOLAT TRANSFORM TERM. + CALL FLDPXW(LL4W,LL4X,NBLOS,IELEM,CTRAN,IPERT,KN,DIFF, + 1 F2(IOFW+1),F3(IOFX+1)) + CALL FLDPXY(LL4W,LL4X,LL4Y,NBLOS,IELEM,CTRAN,IPERT,KN, + 1 DIFF,F2(IOFY+1),F3(IOFX+1)) + ENDIF +* + NULLIFY(IPBY) + NULLIFY(BY) + IF(LL4Y.GT.0) THEN + CALL LCMGPD(IPSYS,'YA'//NAMT,AY_PTR) + CALL LCMGPD(IPTRK,'IPBBY',IPBY_PTR) + CALL LCMGPD(IPTRK,'YB',BY_PTR) + CALL C_F_POINTER(IPBY_PTR,IPBY,(/ 2*IELEM*LL4Y /)) + CALL C_F_POINTER(BY_PTR,BY,(/ 2*IELEM*LL4Y /)) + IF(ISEG.EQ.0) THEN +* SCALAR MULTIPLICATION FOR A Y-ORIENTED MATRIX. + CALL LCMGPD(IPTRK,'MUY',MUY_PTR) + CALL C_F_POINTER(MUY_PTR,MUY,(/ LL4Y /)) + CALL C_F_POINTER(AY_PTR,AY,(/ MUY(LL4Y) /)) + CALL ALLDLM(LL4Y,AY,F2(IOFY+1),F3(IOFY+1),MUY,1) + ELSE IF(ISEG.GT.0) THEN +* SUPERVECTORIAL MULTIPLICATION FOR A Y-ORIENTED MATRIX. + CALL LCMGET(IPTRK,'LL4VY',LL4VY) + CALL LCMGPD(IPTRK,'MUVY',MUY_PTR) + CALL LCMGPD(IPTRK,'IPVY',IPVY_PTR) + CALL LCMLEN(IPTRK,'NBLY',LONY,ITYLCM) + CALL LCMGPD(IPTRK,'NBLY',NBLY_PTR) + CALL LCMGPD(IPTRK,'LBLY',LBLY_PTR) + CALL C_F_POINTER(MUY_PTR,MUY,(/ LL4VY/ISEG /)) + CALL C_F_POINTER(IPVY_PTR,IPVY,(/ LL4Y /)) + CALL C_F_POINTER(NBLY_PTR,NBLY,(/ LONY /)) + CALL C_F_POINTER(LBLY_PTR,LBLY,(/ LONY /)) + CALL LCMLEN(IPSYS,'YA'//NAMT,ASS_LEN,ITYLCM) + CALL C_F_POINTER(AY_PTR,AY,(/ ASS_LEN /)) + ALLOCATE(GAR(LL4VY),GAF(LL4VY)) + GAR(:LL4VY)=0.0 + DO 120 I=1,LL4Y + GAR(IPVY(I))=F2(IOFY+I) + 120 CONTINUE + CALL ALVDLM(LTSW,AY,GAR,GAF,MUY,1,ISEG,LONY,NBLY,LBLY) + DO 130 I=1,LL4Y + F3(IOFY+I)=GAF(IPVY(I)) + 130 CONTINUE + DEALLOCATE(GAF,GAR) + ENDIF + IF((IPR.NE.1).AND.(IPR.NE.2)) THEN + DO 155 I=1,LL4Y + GG=F3(IOFY+I) + DO 140 J=1,2*IELEM + II=IPBY((I-1)*2*IELEM+J) + IF(II.EQ.0) GO TO 150 + GG=GG+BY((I-1)*2*IELEM+J)*F2(II) + 140 CONTINUE + 150 F3(IOFY+I)=GG + 155 CONTINUE + ENDIF +* + IF(LL4W.GT.0) THEN +* PIOLAT TRANSFORM TERM. + CALL FLDPYX(LL4W,LL4X,LL4Y,NBLOS,IELEM,CTRAN,IPERT,KN, + 1 DIFF,F2(IOFX+1),F3(IOFY+1)) + CALL FLDPYW(LL4W,LL4X,LL4Y,NBLOS,IELEM,CTRAN,IPERT,KN, + 1 DIFF,F2(IOFW+1),F3(IOFY+1)) + ENDIF + ENDIF +* + NULLIFY(IPBZ) + NULLIFY(BZ) + IF(LL4Z.GT.0) THEN + CALL LCMGPD(IPSYS,'ZA'//NAMT,AZ_PTR) + CALL LCMGPD(IPTRK,'IPBBZ',IPBZ_PTR) + CALL LCMGPD(IPTRK,'ZB',BZ_PTR) + CALL C_F_POINTER(IPBZ_PTR,IPBZ,(/ 2*IELEM*LL4Z /)) + CALL C_F_POINTER(BZ_PTR,BZ,(/ 2*IELEM*LL4Z /)) + IF(ISEG.EQ.0) THEN +* SCALAR MULTIPLICATION FOR A Y-ORIENTED MATRIX. + CALL LCMGPD(IPTRK,'MUZ',MUZ_PTR) + CALL C_F_POINTER(MUZ_PTR,MUZ,(/ LL4Z /)) + CALL C_F_POINTER(AZ_PTR,AZ,(/ MUZ(LL4Z) /)) + CALL ALLDLM(LL4Z,AZ,F2(IOFZ+1),F3(IOFZ+1),MUZ,1) + ELSE IF(ISEG.GT.0) THEN +* SUPERVECTORIAL MULTIPLICATION FOR A Z-ORIENTED MATRIX. + CALL LCMGET(IPTRK,'LL4VZ',LL4VZ) + CALL LCMGPD(IPTRK,'MUVZ',MUZ_PTR) + CALL LCMGPD(IPTRK,'IPVZ',IPVZ_PTR) + CALL LCMLEN(IPTRK,'NBLZ',LONZ,ITYLCM) + CALL LCMGPD(IPTRK,'NBLZ',NBLZ_PTR) + CALL LCMGPD(IPTRK,'LBLZ',LBLZ_PTR) + CALL C_F_POINTER(MUZ_PTR,MUZ,(/ LL4VZ/ISEG /)) + CALL C_F_POINTER(IPVZ_PTR,IPVZ,(/ LL4Z /)) + CALL C_F_POINTER(NBLZ_PTR,NBLZ,(/ LONZ /)) + CALL C_F_POINTER(LBLZ_PTR,LBLZ,(/ LONZ /)) + CALL LCMLEN(IPSYS,'ZA'//NAMT,ASS_LEN,ITYLCM) + CALL C_F_POINTER(AZ_PTR,AZ,(/ ASS_LEN /)) + ALLOCATE(GAR(LL4VZ),GAF(LL4VZ)) + GAR(:LL4VZ)=0.0 + DO 170 I=1,LL4Z + GAR(IPVZ(I))=F2(IOFZ+1) + 170 CONTINUE + CALL ALVDLM(LTSW,AZ,GAR,GAF,MUZ,1,ISEG,LONZ,NBLZ,LBLZ) + DO 180 I=1,LL4Z + F3(IOFZ+I)=GAF(IPVZ(I)) + 180 CONTINUE + DEALLOCATE(GAF,GAR) + ENDIF + IF((IPR.NE.1).AND.(IPR.NE.2)) THEN + DO 205 I=1,LL4Z + GG=F3(IOFZ+I) + DO 190 J=1,2*IELEM + II=IPBZ((I-1)*2*IELEM+J) + IF(II.EQ.0) GO TO 200 + GG=GG+BZ((I-1)*2*IELEM+J)*F2(II) + 190 CONTINUE + 200 F3(IOFZ+I)=GG + 205 CONTINUE + ENDIF + ENDIF +* + DO 210 I=1,LL4F + F3(I)=TF(I)*F2(I) + 210 CONTINUE + IF((IPR.NE.1).AND.(IPR.NE.2)) THEN + DO 230 I=1,LL4W + DO 220 J=1,2*IELEM + II=IPBW((I-1)*2*IELEM+J) + IF(II.EQ.0) GO TO 230 + F3(II)=F3(II)+BW((I-1)*2*IELEM+J)*F2(IOFW+I) + 220 CONTINUE + 230 CONTINUE + DO 250 I=1,LL4X + DO 240 J=1,2*IELEM + II=IPBX((I-1)*2*IELEM+J) + IF(II.EQ.0) GO TO 250 + F3(II)=F3(II)+BX((I-1)*2*IELEM+J)*F2(IOFX+I) + 240 CONTINUE + 250 CONTINUE + DO 270 I=1,LL4Y + DO 260 J=1,2*IELEM + II=IPBY((I-1)*2*IELEM+J) + IF(II.EQ.0) GO TO 270 + F3(II)=F3(II)+BY((I-1)*2*IELEM+J)*F2(IOFY+I) + 260 CONTINUE + 270 CONTINUE + DO 290 I=1,LL4Z + DO 280 J=1,2*IELEM + II=IPBZ((I-1)*2*IELEM+J) + IF(II.EQ.0) GO TO 290 + F3(II)=F3(II)+BZ((I-1)*2*IELEM+J)*F2(IOFZ+I) + 280 CONTINUE + 290 CONTINUE + ENDIF + RETURN + END diff --git a/Trivac/src/FLDTRS.f b/Trivac/src/FLDTRS.f new file mode 100755 index 0000000..3cd6367 --- /dev/null +++ b/Trivac/src/FLDTRS.f @@ -0,0 +1,570 @@ +*DECK FLDTRS + SUBROUTINE FLDTRS(NAMP,IPTRK,IPSYS,LL4,S1,F1,NADI) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform NADI inner iterations with the ADI preconditionning. Special +* version for Thomas-Raviart or Raviart-Thomas-Schneider basis. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Reference: +* A. Hebert, "A Raviart-Thomas-Schneider implementation of the +* simplified Pn method in 3-D hexagonal geometry," PHYSOR 2010 - +* Int. Conf. on Advances in Reactor Physics to Power the Nuclear +* Renaissance, May 9-14, Pittsburgh, Pennsylvania, 2010. +* +*Parameters: input +* NAMP name of the ADI-splitted matrix. +* IPTRK L_TRACK pointer to the tracking information. +* IPSYS L_SYSTEM pointer to system matrices. +* LL4 order of the matrix. +* S1 source term of the linear system. +* F1 initial solution of the linear system. +* NADI number of inner ADI iterations. +* +*Parameters: output +* F1 solution of the linear system after NADI iterations. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPSYS + CHARACTER NAMP*12 + INTEGER LL4,NADI + REAL S1(LL4),F1(LL4) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + CHARACTER NAMT*12 + INTEGER ITP(NSTATE) + LOGICAL LMUX,DIAG + REAL, DIMENSION(:), ALLOCATABLE :: FL,FW,FX,FY,FZ,T,GAR + INTEGER C11W_LEN,C11X_LEN,C11Y_LEN,C11Z_LEN + INTEGER, DIMENSION(:), POINTER :: KN,IPERT,IPBW,MUW,IPVW,NBLW, + 1 LBLW,IPBX,MUX,IPVX,NBLX,LBLX,IPBY,MUY,IPVY,NBLY,LBLY,IPBZ,MUZ, + 2 IPVZ,NBLZ,LBLZ + REAL, DIMENSION(:), POINTER :: TF,DIFF,BW,C11W,BX,C11X,BY,C11Y, + 1 BZ,C11Z + DOUBLE PRECISION, DIMENSION(:), POINTER :: CTRAN + TYPE(C_PTR) KN_PTR,IPERT_PTR,DIFF_PTR,TF_PTR,CTRAN_PTR, + 1 BW_PTR,C11W_PTR,IPBW_PTR,MUW_PTR,IPVW_PTR,NBLW_PTR,LBLW_PTR, + 2 BX_PTR,C11X_PTR,IPBX_PTR,MUX_PTR,IPVX_PTR,NBLX_PTR,LBLX_PTR, + 3 BY_PTR,C11Y_PTR,IPBY_PTR,MUY_PTR,IPVY_PTR,NBLY_PTR,LBLY_PTR, + 4 BZ_PTR,C11Z_PTR,IPBZ_PTR,MUZ_PTR,IPVZ_PTR,NBLZ_PTR,LBLZ_PTR +*---- +* INITIALIZATION +*---- + NAMT=NAMP + CALL LCMGET(IPTRK,'STATE-VECTOR',ITP) + IELEM=ITP(9) + ISEG=ITP(17) + LTSW=ITP(19) + LL4F=ITP(25) + LL4W=ITP(26) + LL4X=ITP(27) + LL4Y=ITP(28) + LL4Z=ITP(29) + NLF=ITP(30) + IOFW=LL4F + IOFX=LL4F+LL4W + IOFY=LL4F+LL4W+LL4X + IOFZ=LL4F+LL4W+LL4X+LL4Y + CALL LCMLEN(IPTRK,'MUX',IDUM,ITYLCM) + LMUX=(IDUM.NE.0).AND.(ITYLCM.EQ.1) + DIAG=(LL4Y.GT.0).AND.(.NOT.LMUX) + CALL LCMGPD(IPSYS,'TF'//NAMT,TF_PTR) + CALL C_F_POINTER(TF_PTR,TF,(/ LL4F*NLF/2 /)) +* + NULLIFY(IPBW) + NULLIFY(IPVW) + NULLIFY(BW) + IF(LL4W.GT.0) THEN + ISPLH=ITP(13) + LX=ITP(14) + LZ=ITP(16) + NBLOS=LX*LZ/3 + CALL LCMLEN(IPTRK,'KN',MAXKN,ITYLCM) + CALL LCMGPD(IPTRK,'CTRAN',CTRAN_PTR) + CALL LCMGPD(IPTRK,'KN',KN_PTR) + CALL LCMGPD(IPTRK,'IPERT',IPERT_PTR) + CALL LCMGPD(IPSYS,'DIFF'//NAMT,DIFF_PTR) + CALL C_F_POINTER(CTRAN_PTR,CTRAN,(/ ((IELEM+1)*IELEM)**2 /)) + CALL C_F_POINTER(KN_PTR,KN,(/ MAXKN /)) + CALL C_F_POINTER(IPERT_PTR,IPERT,(/ NBLOS /)) + CALL C_F_POINTER(DIFF_PTR,DIFF,(/ NBLOS /)) +* + ALLOCATE(FW(LL4W)) + CALL LCMGPD(IPTRK,'IPBBW',IPBW_PTR) + CALL LCMLEN(IPSYS,'WB',LENWB,ITYL) + IF(LENWB.EQ.0)THEN + CALL LCMGPD(IPTRK,'WB',BW_PTR) + ELSE + CALL LCMGPD(IPSYS,'WB',BW_PTR) + ENDIF + CALL C_F_POINTER(IPBW_PTR,IPBW,(/ 2*IELEM*LL4W /)) + CALL C_F_POINTER(BW_PTR,BW,(/ 2*IELEM*LL4W /)) + CALL LCMLEN(IPSYS,'WI'//NAMT,C11W_LEN,ITYLCM) + CALL LCMGPD(IPSYS,'WI'//NAMT,C11W_PTR) + IF(ISEG.EQ.0) THEN +* SCALAR SOLUTION FOR A W-ORIENTED LINEAR SYSTEM. + CALL LCMGPD(IPTRK,'MUW',MUW_PTR) + CALL C_F_POINTER(MUW_PTR,MUW,(/ LL4W /)) + ELSE IF(ISEG.GT.0) THEN +* SUPERVECTORIAL SOLUTION FOR A W-ORIENTED LINEAR SYSTEM. + CALL LCMGET(IPTRK,'LL4VW',LL4VW) + CALL LCMGPD(IPTRK,'MUVW',MUW_PTR) + CALL LCMGPD(IPTRK,'IPVW',IPVW_PTR) + CALL LCMLEN(IPTRK,'NBLW',LONW,ITYLCM) + CALL LCMGPD(IPTRK,'NBLW',NBLW_PTR) + CALL LCMGPD(IPTRK,'LBLW',LBLW_PTR) + CALL C_F_POINTER(MUW_PTR,MUW,(/ LL4VW/ISEG /)) + CALL C_F_POINTER(IPVW_PTR,IPVW,(/ LL4W /)) + CALL C_F_POINTER(NBLW_PTR,NBLW,(/ LONW /)) + CALL C_F_POINTER(LBLW_PTR,LBLW,(/ LONW /)) + ENDIF + CALL C_F_POINTER(C11W_PTR,C11W,(/ C11W_LEN /)) + ENDIF + ALLOCATE(FX(LL4X)) + DO 10 I0=1,LL4X + FX(I0)=F1(IOFX+I0) + 10 CONTINUE + CALL LCMGPD(IPTRK,'IPBBX',IPBX_PTR) + CALL LCMLEN(IPSYS,'XB',LENXB,ITYL) + IF(LENXB.EQ.0) THEN + CALL LCMGPD(IPTRK,'XB',BX_PTR) + ELSE + CALL LCMGPD(IPSYS,'XB',BX_PTR) + ENDIF + CALL C_F_POINTER(IPBX_PTR,IPBX,(/ 2*IELEM*LL4X /)) + CALL C_F_POINTER(BX_PTR,BX,(/ 2*IELEM*LL4X /)) + NULLIFY(IPVX) + IF(DIAG) THEN + CALL LCMLEN(IPSYS,'YI'//NAMT,C11X_LEN,ITYLCM) + CALL LCMGPD(IPSYS,'YI'//NAMT,C11X_PTR) + IF(ISEG.EQ.0) THEN +* SCALAR SOLUTION FOR A X-ORIENTED LINEAR SYSTEM. + CALL LCMGPD(IPTRK,'MUY',MUX_PTR) + CALL C_F_POINTER(MUX_PTR,MUX,(/ LL4X /)) + ELSE IF(ISEG.GT.0) THEN +* SUPERVECTORIAL SOLUTION FOR A X-ORIENTED LINEAR SYSTEM. + CALL LCMGET(IPTRK,'LL4VY',LL4VX) + CALL LCMGPD(IPTRK,'MUVY',MUX_PTR) + CALL LCMGPD(IPTRK,'IPVY',IPVX_PTR) + CALL LCMLEN(IPTRK,'NBLY',LONX,ITYLCM) + CALL LCMGPD(IPTRK,'NBLY',NBLX_PTR) + CALL LCMGPD(IPTRK,'LBLY',LBLX_PTR) + CALL C_F_POINTER(MUX_PTR,MUX,(/ LL4VX/ISEG /)) + CALL C_F_POINTER(IPVX_PTR,IPVX,(/ LL4X /)) + CALL C_F_POINTER(NBLX_PTR,NBLX,(/ LONX /)) + CALL C_F_POINTER(LBLX_PTR,LBLX,(/ LONX /)) + ENDIF + ELSE + CALL LCMLEN(IPSYS,'XI'//NAMT,C11X_LEN,ITYLCM) + CALL LCMGPD(IPSYS,'XI'//NAMT,C11X_PTR) + IF(ISEG.EQ.0) THEN +* SCALAR SOLUTION FOR A X-ORIENTED LINEAR SYSTEM. + CALL LCMGPD(IPTRK,'MUX',MUX_PTR) + CALL C_F_POINTER(MUX_PTR,MUX,(/ LL4X /)) + ELSE IF(ISEG.GT.0) THEN +* SUPERVECTORIAL SOLUTION FOR A X-ORIENTED LINEAR SYSTEM. + CALL LCMGET(IPTRK,'LL4VX',LL4VX) + CALL LCMGPD(IPTRK,'MUVX',MUX_PTR) + CALL LCMGPD(IPTRK,'IPVX',IPVX_PTR) + CALL LCMLEN(IPTRK,'NBLX',LONX,ITYLCM) + CALL LCMGPD(IPTRK,'NBLX',NBLX_PTR) + CALL LCMGPD(IPTRK,'LBLX',LBLX_PTR) + CALL C_F_POINTER(MUX_PTR,MUX,(/ LL4VX/ISEG /)) + CALL C_F_POINTER(IPVX_PTR,IPVX,(/ LL4X /)) + CALL C_F_POINTER(NBLX_PTR,NBLX,(/ LONX /)) + CALL C_F_POINTER(LBLX_PTR,LBLX,(/ LONX /)) + ENDIF + ENDIF + CALL C_F_POINTER(C11X_PTR,C11X,(/ C11X_LEN /)) + NULLIFY(IPBY) + NULLIFY(IPVY) + NULLIFY(BY) + IF(LL4Y.GT.0) THEN + ALLOCATE(FY(LL4Y)) + DO 20 I0=1,LL4Y + FY(I0)=F1(IOFY+I0) + 20 CONTINUE + CALL LCMGPD(IPTRK,'IPBBY',IPBY_PTR) + CALL LCMLEN(IPSYS,'YB',LENYB,ITYL) + IF(LENYB.EQ.0) THEN + CALL LCMGPD(IPTRK,'YB',BY_PTR) + ELSE + CALL LCMGPD(IPSYS,'YB',BY_PTR) + ENDIF + CALL C_F_POINTER(IPBY_PTR,IPBY,(/ 2*IELEM*LL4Y /)) + CALL C_F_POINTER(BY_PTR,BY,(/ 2*IELEM*LL4Y /)) + CALL LCMLEN(IPSYS,'YI'//NAMT,C11Y_LEN,ITYLCM) + CALL LCMGPD(IPSYS,'YI'//NAMT,C11Y_PTR) + IF(ISEG.EQ.0) THEN +* SCALAR SOLUTION FOR A Y-ORIENTED LINEAR SYSTEM. + CALL LCMGPD(IPTRK,'MUY',MUY_PTR) + CALL C_F_POINTER(MUY_PTR,MUY,(/ LL4Y /)) + ELSE IF(ISEG.GT.0) THEN +* SUPERVECTORIAL SOLUTION FOR A Y-ORIENTED LINEAR SYSTEM. + CALL LCMGET(IPTRK,'LL4VY',LL4VY) + CALL LCMGPD(IPTRK,'MUVY',MUY_PTR) + CALL LCMGPD(IPTRK,'IPVY',IPVY_PTR) + CALL LCMLEN(IPTRK,'NBLY',LONY,ITYLCM) + CALL LCMGPD(IPTRK,'NBLY',NBLY_PTR) + CALL LCMGPD(IPTRK,'LBLY',LBLY_PTR) + CALL C_F_POINTER(MUY_PTR,MUY,(/ LL4VY/ISEG /)) + CALL C_F_POINTER(IPVY_PTR,IPVY,(/ LL4Y /)) + CALL C_F_POINTER(NBLY_PTR,NBLY,(/ LONY /)) + CALL C_F_POINTER(LBLY_PTR,LBLY,(/ LONY /)) + ENDIF + CALL C_F_POINTER(C11Y_PTR,C11Y,(/ C11Y_LEN /)) + ENDIF + NULLIFY(IPBZ) + NULLIFY(IPVZ) + NULLIFY(BZ) + IF(LL4Z.GT.0) THEN + ALLOCATE(FZ(LL4Z)) + DO 30 I0=1,LL4Z + FZ(I0)=F1(IOFZ+I0) + 30 CONTINUE + CALL LCMGPD(IPTRK,'IPBBZ',IPBZ_PTR) + CALL LCMLEN(IPSYS,'ZB',LENZB,ITYL) + IF(LENZB.EQ.0) THEN + CALL LCMGPD(IPTRK,'ZB',BZ_PTR) + ELSE + CALL LCMGPD(IPSYS,'ZB',BZ_PTR) + ENDIF + CALL C_F_POINTER(IPBZ_PTR,IPBZ,(/ 2*IELEM*LL4Z /)) + CALL C_F_POINTER(BZ_PTR,BZ,(/ 2*IELEM*LL4Z /)) + CALL LCMLEN(IPSYS,'ZI'//NAMT,C11Z_LEN,ITYLCM) + CALL LCMGPD(IPSYS,'ZI'//NAMT,C11Z_PTR) + IF(ISEG.EQ.0) THEN +* SCALAR SOLUTION FOR A Z-ORIENTED LINEAR SYSTEM. + CALL LCMGPD(IPTRK,'MUZ',MUZ_PTR) + CALL C_F_POINTER(MUZ_PTR,MUZ,(/ LL4Z /)) + ELSE IF(ISEG.GT.0) THEN +* SUPERVECTORIAL SOLUTION FOR A Z-ORIENTED LINEAR SYSTEM. + CALL LCMGET(IPTRK,'LL4VZ',LL4VZ) + CALL LCMGPD(IPTRK,'MUVZ',MUZ_PTR) + CALL LCMGPD(IPTRK,'IPVZ',IPVZ_PTR) + CALL LCMLEN(IPTRK,'NBLZ',LONZ,ITYLCM) + CALL LCMGPD(IPTRK,'NBLZ',NBLZ_PTR) + CALL LCMGPD(IPTRK,'LBLZ',LBLZ_PTR) + CALL C_F_POINTER(MUZ_PTR,MUZ,(/ LL4VZ/ISEG /)) + CALL C_F_POINTER(IPVZ_PTR,IPVZ,(/ LL4Z /)) + CALL C_F_POINTER(NBLZ_PTR,NBLZ,(/ LONZ /)) + CALL C_F_POINTER(LBLZ_PTR,LBLZ,(/ LONZ /)) + ENDIF + CALL C_F_POINTER(C11Z_PTR,C11Z,(/ C11Z_LEN /)) + ENDIF + ALLOCATE(FL(LL4F)) +*---- +* W DIRECTION +*---- + IF(ISEG.GT.0) ALLOCATE(T(ISEG)) + DO 520 IADI=1,NADI + IF(LL4W.GT.0) THEN + DO 40 I0=1,LL4F + FL(I0)=S1(I0) + 40 CONTINUE + DO 60 I0=1,LL4X + DO 50 J0=1,2*IELEM + JJ=IPBX((I0-1)*2*IELEM+J0) + IF(JJ.EQ.0) GO TO 60 + FL(JJ)=FL(JJ)-BX((I0-1)*2*IELEM+J0)*FX(I0) + 50 CONTINUE + 60 CONTINUE + DO 80 I0=1,LL4Y + DO 70 J0=1,2*IELEM + JJ=IPBY((I0-1)*2*IELEM+J0) + IF(JJ.EQ.0) GO TO 80 + FL(JJ)=FL(JJ)-BY((I0-1)*2*IELEM+J0)*FY(I0) + 70 CONTINUE + 80 CONTINUE + DO 100 I0=1,LL4Z + DO 90 J0=1,2*IELEM + JJ=IPBZ((I0-1)*2*IELEM+J0) + IF(JJ.EQ.0) GO TO 100 + FL(JJ)=FL(JJ)-BZ((I0-1)*2*IELEM+J0)*FZ(I0) + 90 CONTINUE + 100 CONTINUE + DO 130 I0=1,LL4W + GGW=-S1(IOFW+I0) + DO 110 J0=1,2*IELEM + JJ=IPBW((I0-1)*2*IELEM+J0) + IF(JJ.EQ.0) GO TO 120 + GGW=GGW+BW((I0-1)*2*IELEM+J0)*FL(JJ)/TF(JJ) + 110 CONTINUE + 120 FW(I0)=GGW + 130 CONTINUE +* +* PIOLAT TRANSFORM TERM. + CALL FLDPWY(LL4W,LL4X,LL4Y,NBLOS,IELEM,CTRAN,IPERT,KN,DIFF, + 1 FY,FW) + CALL FLDPWX(LL4W,LL4X,NBLOS,IELEM,CTRAN,IPERT,KN,DIFF,FX,FW) + IF(ISEG.EQ.0) THEN +* SCALAR SOLUTION FOR A W-ORIENTED LINEAR SYSTEM. + CALL ALLDLS(LL4W,MUW,C11W,FW) + ELSE IF(ISEG.GT.0) THEN +* SUPERVECTORIAL SOLUTION FOR A W-ORIENTED LINEAR SYSTEM. + ALLOCATE(GAR(LL4VW)) + GAR(:LL4VW)=0.0 + DO 140 I=1,LL4W + GAR(IPVW(I))=FW(I) + 140 CONTINUE + CALL ALVDLS(LTSW,MUW,C11W,GAR,ISEG,LONW,NBLW,LBLW,T) + DO 150 I=1,LL4W + FW(I)=GAR(IPVW(I)) + 150 CONTINUE + DEALLOCATE(GAR) + ENDIF + ENDIF +*---- +* X DIRECTION +*---- + DO 160 I0=1,LL4F + FL(I0)=S1(I0) + 160 CONTINUE + DO 180 I0=1,LL4W + DO 170 J0=1,2*IELEM + JJ=IPBW((I0-1)*2*IELEM+J0) + IF(JJ.EQ.0) GO TO 180 + FL(JJ)=FL(JJ)-BW((I0-1)*2*IELEM+J0)*FW(I0) + 170 CONTINUE + 180 CONTINUE + DO 200 I0=1,LL4Y + DO 190 J0=1,2*IELEM + JJ=IPBY((I0-1)*2*IELEM+J0) + IF(JJ.EQ.0) GO TO 200 + FL(JJ)=FL(JJ)-BY((I0-1)*2*IELEM+J0)*FY(I0) + 190 CONTINUE + 200 CONTINUE + DO 220 I0=1,LL4Z + DO 210 J0=1,2*IELEM + JJ=IPBZ((I0-1)*2*IELEM+J0) + IF(JJ.EQ.0) GO TO 220 + FL(JJ)=FL(JJ)-BZ((I0-1)*2*IELEM+J0)*FZ(I0) + 210 CONTINUE + 220 CONTINUE + DO 250 I0=1,LL4X + GGX=-S1(IOFX+I0) + DO 230 J0=1,2*IELEM + JJ=IPBX((I0-1)*2*IELEM+J0) + IF(JJ.EQ.0) GO TO 240 + GGX=GGX+BX((I0-1)*2*IELEM+J0)*FL(JJ)/TF(JJ) + 230 CONTINUE + 240 FX(I0)=GGX + 250 CONTINUE + IF(LL4W.GT.0) THEN +* PIOLAT TRANSFORM TERM. + CALL FLDPXW(LL4W,LL4X,NBLOS,IELEM,CTRAN,IPERT,KN,DIFF,FW,FX) + CALL FLDPXY(LL4W,LL4X,LL4Y,NBLOS,IELEM,CTRAN,IPERT,KN,DIFF, + 1 FY,FX) + ENDIF + IF(ISEG.EQ.0) THEN +* SCALAR SOLUTION FOR A X-ORIENTED LINEAR SYSTEM. + CALL ALLDLS(LL4X,MUX,C11X,FX) + ELSE IF(ISEG.GT.0) THEN +* SUPERVECTORIAL SOLUTION FOR A X-ORIENTED LINEAR SYSTEM. + ALLOCATE(GAR(LL4VX)) + GAR(:LL4VX)=0.0 + DO 260 I=1,LL4X + GAR(IPVX(I))=FX(I) + 260 CONTINUE + CALL ALVDLS(LTSW,MUX,C11X,GAR,ISEG,LONX,NBLX,LBLX,T) + DO 270 I=1,LL4X + FX(I)=GAR(IPVX(I)) + 270 CONTINUE + DEALLOCATE(GAR) + ENDIF +*---- +* Y DIRECTION +*---- + IF(LL4Y.GT.0) THEN + DO 280 I0=1,LL4F + FL(I0)=S1(I0) + 280 CONTINUE + DO 300 I0=1,LL4W + DO 290 J0=1,2*IELEM + JJ=IPBW((I0-1)*2*IELEM+J0) + IF(JJ.EQ.0) GO TO 300 + FL(JJ)=FL(JJ)-BW((I0-1)*2*IELEM+J0)*FW(I0) + 290 CONTINUE + 300 CONTINUE + DO 320 I0=1,LL4X + DO 310 J0=1,2*IELEM + JJ=IPBX((I0-1)*2*IELEM+J0) + IF(JJ.EQ.0) GO TO 320 + FL(JJ)=FL(JJ)-BX((I0-1)*2*IELEM+J0)*FX(I0) + 310 CONTINUE + 320 CONTINUE + DO 340 I0=1,LL4Z + DO 330 J0=1,2*IELEM + JJ=IPBZ((I0-1)*2*IELEM+J0) + IF(JJ.EQ.0) GO TO 340 + FL(JJ)=FL(JJ)-BZ((I0-1)*2*IELEM+J0)*FZ(I0) + 330 CONTINUE + 340 CONTINUE + DO 370 I0=1,LL4Y + GGY=-S1(IOFY+I0) + DO 350 J0=1,2*IELEM + JJ=IPBY((I0-1)*2*IELEM+J0) + IF(JJ.EQ.0) GO TO 360 + GGY=GGY+BY((I0-1)*2*IELEM+J0)*FL(JJ)/TF(JJ) + 350 CONTINUE + 360 FY(I0)=GGY + 370 CONTINUE + IF(LL4W.GT.0) THEN +* PIOLAT TRANSFORM TERM. + CALL FLDPYX(LL4W,LL4X,LL4Y,NBLOS,IELEM,CTRAN,IPERT,KN, + 1 DIFF,FX,FY) + CALL FLDPYW(LL4W,LL4X,LL4Y,NBLOS,IELEM,CTRAN,IPERT,KN, + 1 DIFF,FW,FY) + ENDIF + IF(ISEG.EQ.0) THEN +* SCALAR SOLUTION FOR A Y-ORIENTED LINEAR SYSTEM. + CALL ALLDLS(LL4Y,MUY,C11Y,FY) + ELSE IF(ISEG.GT.0) THEN +* SUPERVECTORIAL SOLUTION FOR A Y-ORIENTED LINEAR SYSTEM. + ALLOCATE(GAR(LL4VY)) + GAR(:LL4VY)=0.0 + DO 380 I=1,LL4Y + GAR(IPVY(I))=FY(I) + 380 CONTINUE + CALL ALVDLS(LTSW,MUY,C11Y,GAR,ISEG,LONY,NBLY,LBLY,T) + DO 390 I=1,LL4Y + FY(I)=GAR(IPVY(I)) + 390 CONTINUE + DEALLOCATE(GAR) + ENDIF + ENDIF +*---- +* Z DIRECTION +*---- + IF(LL4Z.GT.0) THEN + DO 400 I0=1,LL4F + FL(I0)=S1(I0) + 400 CONTINUE + DO 420 I0=1,LL4W + DO 410 J0=1,2*IELEM + JJ=IPBW((I0-1)*2*IELEM+J0) + IF(JJ.EQ.0) GO TO 420 + FL(JJ)=FL(JJ)-BW((I0-1)*2*IELEM+J0)*FW(I0) + 410 CONTINUE + 420 CONTINUE + DO 440 I0=1,LL4X + DO 430 J0=1,2*IELEM + JJ=IPBX((I0-1)*2*IELEM+J0) + IF(JJ.EQ.0) GO TO 440 + FL(JJ)=FL(JJ)-BX((I0-1)*2*IELEM+J0)*FX(I0) + 430 CONTINUE + 440 CONTINUE + DO 460 I0=1,LL4Y + DO 450 J0=1,2*IELEM + JJ=IPBY((I0-1)*2*IELEM+J0) + IF(JJ.EQ.0) GO TO 460 + FL(JJ)=FL(JJ)-BY((I0-1)*2*IELEM+J0)*FY(I0) + 450 CONTINUE + 460 CONTINUE + DO 490 I0=1,LL4Z + GGZ=-S1(IOFZ+I0) + DO 470 J0=1,2*IELEM + JJ=IPBZ((I0-1)*2*IELEM+J0) + IF(JJ.EQ.0) GO TO 480 + GGZ=GGZ+BZ((I0-1)*2*IELEM+J0)*FL(JJ)/TF(JJ) + 470 CONTINUE + 480 FZ(I0)=GGZ + 490 CONTINUE + IF(ISEG.EQ.0) THEN +* SCALAR SOLUTION FOR A Z-ORIENTED LINEAR SYSTEM. + CALL ALLDLS(LL4Z,MUZ,C11Z,FZ) + ELSE IF(ISEG.GT.0) THEN +* SUPERVECTORIAL SOLUTION FOR A Z-ORIENTED LINEAR SYSTEM. + ALLOCATE(GAR(LL4VZ)) + GAR(:LL4VZ)=0.0 + DO 500 I=1,LL4Z + GAR(IPVZ(I))=FZ(I) + 500 CONTINUE + CALL ALVDLS(LTSW,MUZ,C11Z,GAR,ISEG,LONZ,NBLZ,LBLZ,T) + DO 510 I=1,LL4Z + FZ(I)=GAR(IPVZ(I)) + 510 CONTINUE + DEALLOCATE(GAR) + ENDIF + ENDIF + 520 CONTINUE + IF(ISEG.GT.0) DEALLOCATE(T) + DEALLOCATE(FL) +*---- +* COMPUTE FLUX AND RECOVER CURRENTS +*---- + DO 530 I0=1,LL4F + F1(I0)=S1(I0) + 530 CONTINUE + DO 550 J0=1,LL4W + DO 540 I0=1,2*IELEM + II=IPBW((J0-1)*2*IELEM+I0) + IF(II.EQ.0) GO TO 550 + F1(II)=F1(II)-BW((J0-1)*2*IELEM+I0)*FW(J0) + 540 CONTINUE + 550 CONTINUE + DO 570 J0=1,LL4X + DO 560 I0=1,2*IELEM + II=IPBX((J0-1)*2*IELEM+I0) + IF(II.EQ.0) GO TO 570 + F1(II)=F1(II)-BX((J0-1)*2*IELEM+I0)*FX(J0) + 560 CONTINUE + 570 CONTINUE + DO 590 J0=1,LL4Y + DO 580 I0=1,2*IELEM + II=IPBY((J0-1)*2*IELEM+I0) + IF(II.EQ.0) GO TO 590 + F1(II)=F1(II)-BY((J0-1)*2*IELEM+I0)*FY(J0) + 580 CONTINUE + 590 CONTINUE + DO 610 J0=1,LL4Z + DO 600 I0=1,2*IELEM + II=IPBZ((J0-1)*2*IELEM+I0) + IF(II.EQ.0) GO TO 610 + F1(II)=F1(II)-BZ((J0-1)*2*IELEM+I0)*FZ(J0) + 600 CONTINUE + 610 CONTINUE + DO 620 I0=1,LL4F + F1(I0)=F1(I0)/TF(I0) + 620 CONTINUE + IF(LL4W.GT.0) THEN + DO 630 I0=1,LL4W + F1(IOFW+I0)=FW(I0) + 630 CONTINUE + DEALLOCATE(FW) + ENDIF + DO 640 I0=1,LL4X + F1(IOFX+I0)=FX(I0) + 640 CONTINUE + DEALLOCATE(FX) + IF(LL4Y.GT.0) THEN + DO 650 I0=1,LL4Y + F1(IOFY+I0)=FY(I0) + 650 CONTINUE + DEALLOCATE(FY) + ENDIF + IF(LL4Z.GT.0) THEN + DO 660 I0=1,LL4Z + F1(IOFZ+I0)=FZ(I0) + 660 CONTINUE + DEALLOCATE(FZ) + ENDIF + RETURN + END diff --git a/Trivac/src/FLDTSM.f b/Trivac/src/FLDTSM.f new file mode 100755 index 0000000..bd78ffc --- /dev/null +++ b/Trivac/src/FLDTSM.f @@ -0,0 +1,185 @@ +*DECK FLDTSM + SUBROUTINE FLDTSM(NAMP,IPTRK,IPSYS,LL4,NBMIX,NAN,F2,F3) +* +*----------------------------------------------------------------------- +* +*Purpose: +* LCM driver for the multiplication of a matrix by a vector. +* Special version for the simplified PN method in TRIVAC. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NAMP name of the coefficient matrix. +* IPTRK L_TRACK pointer to the tracking information. +* IPSYS L_SYSTEM pointer to system matrices. +* LL4 order of the matrix. +* NBMIX total number of material mixtures in the macrolib. +* NAN number of Legendre orders in the cross sections. +* F2 vector to multiply. +* +*Parameters: output +* F3 result of the multiplication. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPSYS + CHARACTER NAMP*(*) + INTEGER LL4,NBMIX,NAN + REAL F2(LL4),F3(LL4) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + CHARACTER NAMT*12,TEXT12*12 + INTEGER IPAR(NSTATE) + LOGICAL CHEX + INTEGER, DIMENSION(:), ALLOCATABLE :: MAT,KN,IQFR + REAL, DIMENSION(:), ALLOCATABLE :: VOL,QFR,XX,YY,ZZ,GAMMA + REAL, DIMENSION(:,:), ALLOCATABLE :: R,V,SGD + INTEGER, DIMENSION(:), POINTER :: IPERT + REAL, DIMENSION(:), POINTER :: FRZ + DOUBLE PRECISION, DIMENSION(:), POINTER :: CTRAN + TYPE(C_PTR) IPERT_PTR,FRZ_PTR,CTRAN_PTR +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(SGD(NBMIX,2*NAN)) +*---- +* RECOVER PN SPECIFIC PARAMETERS. +*---- + NAMT=NAMP + READ(NAMT,'(1X,2I3)') IGR,JGR + CALL LCMGET(IPTRK,'STATE-VECTOR',IPAR) + NREG=IPAR(1) + NUN=IPAR(2) + ITYPE=IPAR(6) + IELEM=IPAR(9) + ICOL=IPAR(10) + L4=IPAR(11) + ISPLH=IPAR(13) + LX=IPAR(14) + LZ=IPAR(16) + LL4F=IPAR(25) + LL4W=IPAR(26) + LL4X=IPAR(27) + LL4Y=IPAR(28) + NLF=IPAR(30) + NVD=IPAR(34) + CHEX=(ITYPE.EQ.8).OR.(ITYPE.EQ.9) + IF(CHEX) THEN + IF(NUN.GT.(LX*LZ+L4)*NLF/2) CALL XABORT('FLDTSM: INVALID NUN ' + 1 //'OR L4.') + ELSE + IF(NUN.NE.L4*NLF/2) CALL XABORT('FLDTSM: INVALID NUN OR L4.') + ENDIF + IF(L4*NLF/2.NE.LL4) CALL XABORT('FLDTSM: INVALID L4 OR LL4.') +*---- +* RECOVER TRACKING INFORMATION. +*---- + ALLOCATE(MAT(NREG),VOL(NREG)) + CALL LCMGET(IPTRK,'MATCOD',MAT) + CALL LCMGET(IPTRK,'VOLUME',VOL) + CALL LCMLEN(IPTRK,'KN',MAXKN,ITYLCM) + CALL LCMLEN(IPTRK,'QFR',MAXQF,ITYLCM) + ALLOCATE(KN(MAXKN),QFR(MAXQF),IQFR(MAXQF)) + CALL LCMGET(IPTRK,'KN',KN) + CALL LCMGET(IPTRK,'QFR',QFR) + CALL LCMGET(IPTRK,'IQFR',IQFR) + IF(CHEX) THEN + CALL LCMGET(IPTRK,'SIDE',SIDE) + ELSE + ALLOCATE(XX(NREG),YY(NREG)) + CALL LCMGET(IPTRK,'XX',XX) + CALL LCMGET(IPTRK,'YY',YY) + ENDIF + ALLOCATE(ZZ(NREG)) + CALL LCMGET(IPTRK,'ZZ',ZZ) +*---- +* RECOVER THE PERTURBATION FLAG. +*---- + CALL LCMGET(IPSYS,'STATE-VECTOR',IPAR) + IPR=IPAR(9) +*---- +* PROCESS PHYSICAL ALBEDO FUNCTIONS +*---- + TEXT12='ALBEDO-FU'//NAMT(2:4) + CALL LCMLEN(IPSYS,TEXT12,NALBP,ITYLCM) + IF(NALBP.GT.0) THEN + ALLOCATE(GAMMA(NALBP)) + CALL LCMGET(IPSYS,TEXT12,GAMMA) + DO IQW=1,MAXQF + IALB=IQFR(IQW) + IF(IALB.NE.0) QFR(IQW)=QFR(IQW)*GAMMA(IALB) + ENDDO + DEALLOCATE(GAMMA) + ENDIF +*---- +* RECOVER THE CROSS SECTIONS. +*---- + DO 20 IL=1,NAN + WRITE(TEXT12,'(4HSCAR,I2.2,A6)') IL-1,NAMT(2:7) + CALL LCMLEN(IPSYS,TEXT12,LENGT,ITYLCM) + IF(LENGT.EQ.0) THEN + SGD(:NBMIX,IL)=0.0 + SGD(:NBMIX,NAN+IL)=0.0 + ELSE + CALL LCMGET(IPSYS,TEXT12,SGD(1,IL)) + WRITE(TEXT12,'(4HSCAI,I2.2,A6)') IL-1,NAMT(2:7) + CALL LCMGET(IPSYS,TEXT12,SGD(1,NAN+IL)) + ENDIF + 20 CONTINUE +*---- +* RECOVER THE FINITE ELEMENT UNIT STIFFNESS MATRIX. +*---- + CALL LCMSIX(IPTRK,'BIVCOL',1) + CALL LCMLEN(IPTRK,'T',LC,ITYLCM) + ALLOCATE(R(LC,LC),V(LC,LC-1)) + CALL LCMGET(IPTRK,'R',R) + CALL LCMGET(IPTRK,'V',V) + CALL LCMSIX(IPTRK,' ',2) +*---- +* COMPUTE THE SOURCE +*---- + ITY=0 + IF(IGR.NE.JGR) ITY=1 + IF(CHEX) THEN + NBLOS=LX*LZ/3 + CALL LCMGPD(IPTRK,'CTRAN',CTRAN_PTR) + CALL LCMGPD(IPTRK,'IPERT',IPERT_PTR) + CALL LCMGPD(IPTRK,'FRZ',FRZ_PTR) + CALL C_F_POINTER(CTRAN_PTR,CTRAN,(/ ((IELEM+1)*IELEM)**2 /)) + CALL C_F_POINTER(IPERT_PTR,IPERT,(/ NBLOS /)) + CALL C_F_POINTER(FRZ_PTR,FRZ,(/ NBLOS /)) + CALL PNSH3D(ITY,IPR,NBMIX,NBLOS,IELEM,ICOL,NLF,NVD,NAN,L4,LL4F, + 1 LL4W,LL4X,LL4Y,MAT,SGD(1,1),SGD(1,NAN+1),SIDE,ZZ,FRZ,QFR,IPERT, + 2 KN,LC,R,V,CTRAN,F2,F3) + ELSE + CALL PNSZ3D(ITY,IPR,NREG,IELEM,ICOL,XX,YY,ZZ,MAT,VOL,NBMIX,NLF, + 1 NVD,NAN,SGD(1,1),SGD(1,NAN+1),L4,KN,QFR,LC,R,V,F2,F3) + ENDIF + IF(ITY.EQ.1) THEN + DO 30 I=1,LL4 + F3(I)=-F3(I) + 30 CONTINUE + ENDIF + DEALLOCATE(V,R,ZZ) + IF(.NOT.CHEX) DEALLOCATE(YY,XX) + DEALLOCATE(IQFR,QFR,KN,VOL,MAT) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SGD) + RETURN + END diff --git a/Trivac/src/FLDXCO.f b/Trivac/src/FLDXCO.f new file mode 100755 index 0000000..a1022cc --- /dev/null +++ b/Trivac/src/FLDXCO.f @@ -0,0 +1,72 @@ +*DECK FLDXCO + SUBROUTINE FLDXCO(IPFLUX,L4,NUN,VECT,LMPR,B) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compare two solutions and print the logarithm of error. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPFLUX L_FLUX pointer to the solution. +* L4 order of matrix systems. +* NUN number of unknowns in each energy group. +* VECT unknown vector. +* LMPR logarithm print flag (.true. to print the logarithm value). +* +*Parameters: output +* B base 10 logarithm of the error. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPFLUX + INTEGER L4,NUN + REAL VECT(NUN),B + LOGICAL LMPR +*---- +* LOCAL VARIABLES +*---- + REAL, DIMENSION(:), ALLOCATABLE :: REF +* + CALL LCMLEN(IPFLUX,'REF',ILONG,ITYLCM) + IF(ILONG.EQ.0) RETURN + IF(ILONG.NE.NUN) CALL XABORT('FLDXCO: INVALID LENGTH FOR REF.') + ALLOCATE(REF(ILONG)) + CALL LCMGET(IPFLUX,'REF',REF) + IN=0 + ERR1=0.0 + DO 5 I=1,L4 + IF(ABS(REF(I)).GT.ERR1) THEN + IN=I + ERR1=ABS(REF(I)) + ENDIF + 5 CONTINUE + WEIGHT=REF(IN)/VECT(IN) + ERR2=0.0 + DO 10 I=1,L4 + ERR2=AMAX1(ERR2,ABS(REF(I)-VECT(I)*WEIGHT)) + 10 CONTINUE + DEALLOCATE(REF) + A=ERR2/ERR1 + IF(A.GT.0.0) THEN + B=LOG10(A) + ELSE + B=-5.0 + ENDIF + IF(LMPR) WRITE (6,20) A,B + RETURN +* + 20 FORMAT (7H ERROR=,1P,E10.2,5X,11HLOG(ERROR)=,E10.2) + END diff --git a/Trivac/src/GEOD.f b/Trivac/src/GEOD.f new file mode 100755 index 0000000..497760f --- /dev/null +++ b/Trivac/src/GEOD.f @@ -0,0 +1,84 @@ +*DECK GEO + SUBROUTINE GEOD(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Geometry definition operator. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version. +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1): create or modification type(L_GEOM). +* HENTRY(2): optional read-only type(L_GEOM). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + CHARACTER TEXT12*12,TEXT13*12 + TYPE(C_PTR) IPLIST +*---- +* PARAMETER VALIDATION +*---- + IF(NENTRY.EQ.0) CALL XABORT('GEOD: PARAMETER EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('GEOD: LCM' + 1 //' OBJECT EXPECTED AT LHS.') + IF((JENTRY(1).NE.0).AND.(JENTRY(1).NE.1)) CALL XABORT('GEOD: CRE' + 1 //'ATE OR MODIFICATION MODE EXPECTED.') + ITYPE=JENTRY(1) + IPLIST=KENTRY(1) +* + IMPX=1 + IF((ITYPE.EQ.0).AND.(NENTRY.GT.1)) THEN +* CREATE A NEW GEOMETRY BASED ON AN EXISTING ONE. + IF(JENTRY(2).NE.2) CALL XABORT('GEOD: RHS GEOMETRY EXPECTED O' + 1 //'PEN IN READ-ONLY MODE.') + IF((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2)) CALL XABORT('GEOD: ' + 1 //'LCM OBJECT EXPECTED AT RHS.') + CALL LCMGTC(KENTRY(2),'SIGNATURE',12,TEXT12) + IF(TEXT12.NE.'L_GEOM') THEN + TEXT13=HENTRY(2) + CALL XABORT('GEOD: SIGNATURE OF '//TEXT13//' IS '//TEXT12// + 1 '. L_GEOM EXPECTED(1).') + ENDIF + CALL LCMEQU(KENTRY(2),IPLIST) + ELSE IF(ITYPE.EQ.1) THEN +* MODIFY AN EXISTING GEOMETRY USING THE SAME NAME. + CALL LCMGTC(IPLIST,'SIGNATURE',12,TEXT12) + IF(TEXT12.NE.'L_GEOM') THEN + TEXT13=HENTRY(1) + CALL XABORT('GEOD: SIGNATURE OF '//TEXT13//' IS '//TEXT12// + 1 '. L_GEOM EXPECTED(2).') + ENDIF + ENDIF +* + TEXT12='/' + CALL GEODIN(TEXT12,IPLIST,1,IMPX,MAXMIX) + RETURN + END diff --git a/Trivac/src/GEODIN.f b/Trivac/src/GEODIN.f new file mode 100755 index 0000000..7d8725e --- /dev/null +++ b/Trivac/src/GEODIN.f @@ -0,0 +1,765 @@ +*DECK GEODIN + SUBROUTINE GEODIN (GEONAM,IPLIST,LEVEL,IMPX,MAXMIX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read and/or modify an object oriented geometry +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* GEONAM name of the directory where the geometry is stored. +* IPLIST pointer to the geometry LCM object (L_GEOM signature). +* LEVEL hierarchical level of the geometry. +* IMPX print flag (IMPX=0 for no print). +* +*Parameters: output +* MAXMIX maximum number of mixtures, considering all sub-geometries. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIST + INTEGER LEVEL,IMPX,MAXMIX + CHARACTER GEONAM*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MAXCOD=21,MAXHEX=9,MAXTEX=4,MAXTUR=12,MAXTYP=30, + 1 MXCL=500,NSTATE=40,IOUT=6) + LOGICAL LHEX,LTRI,EMPTY,LCM,SWANG + LOGICAL LTOT,LCOUR + CHARACTER NAMT*12,COND(MAXCOD)*4,CHEX(MAXHEX)*8,CHET(MAXTEX)*8, + 1 CTUR(MAXTUR)*1,TYPE(0:MAXTYP)*16,TEXT4*4,CARLIR*12,TEXT12*12, + 2 DIR*1 + INTEGER ISTATE(NSTATE),NCODE(6),ICODE(6) + REAL ZCODE(6) + DOUBLE PRECISION DBLLIR + EQUIVALENCE (LR,ISTATE(2)),(LX,ISTATE(3)),(LY,ISTATE(4)), + 1 (LZ,ISTATE(5)),(LREG,ISTATE(6)) + INTEGER, DIMENSION(:), ALLOCATABLE :: MIX,MERGE,TURN,MESH + REAL, DIMENSION(:), ALLOCATABLE :: RMESH,XR0,RR0,ANG + CHARACTER(LEN=12), DIMENSION(:), ALLOCATABLE :: CELL +*---- +* Data +*---- + SAVE COND,CHEX,CTUR,TYPE + DATA COND + > /'VOID','REFL','DIAG','TRAN','SYME', + > 'ALBE','ZERO','PI/2','PI' ,'SSYM', + > 9*' ','CYLI','ACYL'/ + DATA CHEX + > /'S30 ','SA60 ','SB60 ','S90 ','R120 ', + > 'R180 ','SA180 ','SB180 ','COMPLETE'/ + DATA CTUR + > /'A','B','C','D','E','F','G','H','I','J','K','L'/ + DATA TYPE + > /'VIRTUAL ','HOMOGENEOUS ','CARTESIAN 1-D ', + > 'TUBE 1-D ','SPHERE 1-D ','CARTESIAN 2-D ', + > 'TUBE 2-D (Z) ','CARTESIAN 3-D ','HEXAGONAL 2-D ', + > 'HEXAGONE 3-D (Z)','TUBE 2-D (X) ','TUBE 2-D (Y) ', + > 'R-THETA ','TRIANGULAR 2-D ','TRIANGULAR 3-D ', + > ' ',' ',' ', + > ' ',' ','2-D RECT. CELL ', + > '3-D RECT. CELL X','3-D RECT. CELL Y','3-D RECT. CELL X', + > '2-D HEX. CELL ','3-D HEX. CELL Z ',' ', + > ' ',' ',' ', + > 'DO-IT-YOURSELF '/ +* + MINMIX=0 + MINICO=1 + CALL LCMLEN(IPLIST,'SIGNATURE',ILONG,ITYX) + IF(ILONG.EQ.0) THEN +* INPUT A NEW GEOMETRY. + DO 10 I=1,NSTATE + ISTATE(I)=0 + 10 CONTINUE + LHEX=.FALSE. + LTRI=.FALSE. + LCOUR=.FALSE. + DO 20 I=1,6 + NCODE(I)=0 + ZCODE(I)=0.0 + ICODE(I)=0 + 20 CONTINUE + ELSE +* MODIFY AN EXISTING GEOMETRY. + CALL LCMGTC(IPLIST,'SIGNATURE',12,CARLIR) + IF(CARLIR.NE.'L_GEOM') THEN + NAMT=GEONAM + CALL XABORT('GEODIN: SIGNATURE OF '//NAMT//' IS '//CARLIR + 1 //'. L_GEOM EXPECTED.') + ENDIF + CALL LCMGET(IPLIST,'STATE-VECTOR',ISTATE) + LHEX=(ISTATE(1).EQ.8).OR.(ISTATE(1).EQ.9).OR.(ISTATE(1).EQ.24) + 1 .OR.(ISTATE(1).EQ.25) + LTRI=(ISTATE(1).EQ.13).OR.(ISTATE(1).EQ.14) + LCOUR=.FALSE. + IF(LHEX) THEN + CALL LCMLEN(IPLIST,'IHEX',ILONG,ITYX) + IF(ILONG.EQ.0) CALL XABORT('GEODIN: MISSING IHEX RECORD.') + CALL LCMGET(IPLIST,'IHEX',IHEX) + LCOUR=IHEX.EQ.9 + ENDIF + CALL LCMGET(IPLIST,'NCODE',NCODE) + CALL LCMGET(IPLIST,'ZCODE',ZCODE) + CALL LCMGET(IPLIST,'ICODE',ICODE) + IF(LEVEL.EQ.1) GO TO 50 + ENDIF +* + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('GEODIN: CHARACTER DATA EXPECTED(1).') + IF(CARLIR.EQ.'VIRTUAL') THEN + ISTATE(1)=0 + ELSE IF(CARLIR.EQ.'HOMOGE') THEN + ISTATE(1)=1 + LREG=1 + ELSE IF(CARLIR.EQ.'CAR1D') THEN + ISTATE(1)=2 + CALL REDGET(ITYPLU,LX,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') + LREG=LX + ELSE IF(CARLIR.EQ.'SPHERE') THEN + ISTATE(1)=4 + CALL REDGET(ITYPLU,LR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') + LREG=LR + ELSE IF(CARLIR.EQ.'CAR2D') THEN + ISTATE(1)=5 + CALL REDGET(ITYPLU,LX,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') + CALL REDGET(ITYPLU,LY,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') + LREG=LX*LY + ELSE IF(CARLIR.EQ.'CAR3D') THEN + ISTATE(1)=7 + CALL REDGET(ITYPLU,LX,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') + CALL REDGET(ITYPLU,LY,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') + CALL REDGET(ITYPLU,LZ,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') + LREG=LX*LY*LZ + ELSE IF(CARLIR.EQ.'HEX') THEN + ISTATE(1)=8 + LHEX=.TRUE. + CALL REDGET(ITYPLU,LX,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') + LREG=LX + ELSE IF(CARLIR.EQ.'HEXZ') THEN + ISTATE(1)=9 + LHEX=.TRUE. + CALL REDGET(ITYPLU,LX,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') + CALL REDGET(ITYPLU,LZ,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') + LREG=LX*LZ + ELSE IF(CARLIR.EQ.'TRI') THEN + ISTATE(1)=13 + LTRI=.TRUE. + CALL REDGET(ITYPLU,LX,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') + LREG=LX + ELSE IF(CARLIR.EQ.'TRIZ') THEN + ISTATE(1)=14 + LTRI=.TRUE. + CALL REDGET(ITYPLU,LX,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') + CALL REDGET(ITYPLU,LZ,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') + LREG=LX*LZ + ELSE IF(CARLIR.EQ.'RTHETA') THEN + ISTATE(1)=12 + CALL REDGET(ITYPLU,LR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') + CALL REDGET(ITYPLU,LZ,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') + LREG=LR*LZ + ELSE IF(CARLIR(1:4).EQ.'TUBE') THEN + DIR=CARLIR(5:5) + CALL REDGET(ITYPLU,LR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') + IF(DIR.EQ.' ') THEN + ISTATE(1)=3 + LX=1 + LY=1 + IRLXY=1 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.EQ.3) THEN + IRLXY=0 + ELSE IF(ITYPLU.EQ.2) THEN + CALL XABORT('GEODIN: INVALID REAL DATA.') + ELSE + LX=INTLIR + CALL REDGET(ITYPLU,LY,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTE' + 1 //'D.') + ENDIF + LREG=LR*LY*LX + IF(IRLXY.EQ.0) GO TO 60 + ELSE + LX=1 + LY=1 + LZ=1 + CALL REDGET(ITYPLU,LX,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IRLYZ=-99 + IF(ITYPLU.EQ.3) THEN + IRLYZ=0 + ELSE IF(ITYPLU.EQ.2) THEN + CALL XABORT('GEODIN: REAL DATA NOT EXPECTED.') + ELSE + LY=INTLIR + IRLYZ=1 + CALL REDGET(ITYPLU,LZ,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTE' + 1 //'D.') + ENDIF + LREG=LR*LY*LZ*LX + IF(DIR.EQ.'X') THEN + ISTATE(1)=10 + IF(IRLYZ.EQ.0) GO TO 60 + ELSE IF(DIR.EQ.'Y') THEN + ISTATE(1)=11 + IF(IRLYZ.EQ.0) THEN + LY=LX + LX=1 + GO TO 60 + ENDIF + ELSE IF(DIR.EQ.'Z') THEN + ISTATE(1)=6 + IF(IRLYZ.EQ.0) THEN + LZ=LX + LX=1 + GO TO 60 + ENDIF + ELSE + CALL XABORT('GEODIN: INVALID DATA IN TUBE CONSTRUCT.') + ENDIF + ENDIF + ELSE IF(CARLIR(1:6).EQ.'CARCEL') THEN + CALL REDGET(ITYPLU,LR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') + DIR=CARLIR(7:7) + IF(DIR.EQ.' ') THEN + ISTATE(1)=20 + LX=1 + LY=1 + IRLXY=1 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.EQ.3) THEN + IRLXY=0 + ELSE IF(ITYPLU.EQ.2) THEN + CALL XABORT('GEODIN: INVALID REAL DATA.') + ELSE + LX=INTLIR + CALL REDGET(ITYPLU,LY,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTE' + 1 //'D.') + ENDIF + LREG=(LR+1)*LY*LX + IF(IRLXY.EQ.0) GO TO 60 + ELSE + LX=1 + LY=1 + LZ=1 + CALL REDGET(ITYPLU,LX,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IRLYZ=-99 + IF(ITYPLU.EQ.3) THEN + IRLYZ=0 + ELSE IF(ITYPLU.EQ.2) THEN + CALL XABORT('GEODIN: INVALID REAL DATA.') + ELSE + LY=INTLIR + IRLYZ=1 + CALL REDGET(ITYPLU,LZ,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTE' + 1 //'D.') + ENDIF + LREG=(LR+1)*LY*LZ*LX + IF(DIR.EQ.'X') THEN + ISTATE(1)=21 + ELSE IF(DIR.EQ.'Y') THEN + ISTATE(1)=22 + IF(IRLYZ.EQ.0) THEN + LY=LX + LX=1 + GO TO 60 + ENDIF + ELSE IF(DIR.EQ.'Z') THEN + ISTATE(1)=23 + IF(IRLYZ.EQ.0) THEN + LZ=LX + LX=1 + GO TO 60 + ENDIF + ELSE + CALL XABORT('GEODIN: INVALID DATA.') + ENDIF + ENDIF + ELSE IF(CARLIR(1:6).EQ.'HEXCEL') THEN + LHEX=.TRUE. + CALL REDGET(ITYPLU,LR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') + LX=1 + IF(CARLIR(7:7).EQ.' ') THEN + ISTATE(1)=24 + LREG=LR+1 + ELSE IF(CARLIR(7:7).EQ.'Z') THEN + ISTATE(1)=27 + CALL REDGET(ITYPLU,LZ,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') + LREG=(LR+1)*LZ + ELSE + CALL XABORT('GEODIN: INVALID SUFFIX FOR HEXCEL.') + ENDIF + ELSE IF(CARLIR.EQ.'GROUP') THEN +* DO-IT-YOURSELF OPTION. + ISTATE(1)=30 + CALL REDGET(ITYPLU,LX,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') + LREG=LX + ELSE IF(CARLIR.NE.GEONAM) THEN +* COPY ATTRIBUTES FROM AN EXISTING GEOMETRY LOCATED ON A PARALLEL +* DIRECTORY OF THE LCM OBJECT POINTED BY IPLIST. + IF(LEVEL.EQ.1) CALL XABORT('GEODIN: THE GEOMETRY NAME SHOULD A' + 1 //'PPEAR BEFORE THE ::.') + CALL LCMSIX(IPLIST,' ',2) + CALL LCMLEN(IPLIST,CARLIR,ILONG,ITYX) + IF(ILONG.EQ.0) CALL XABORT('GEODIN: UNKNOWN GEOMETRY.') + CALL LCMSIX(IPLIST,CARLIR,1) + IFILE=KDROPN('DUMMYSQ',0,2,0,0) + IF(IFILE.LE.0) CALL XABORT('GEODIN: KDROPN FAILURE.') + CALL LCMEXP(IPLIST,0,IFILE,1,1) + REWIND(IFILE) + CALL LCMSIX(IPLIST,' ',2) + CALL LCMSIX(IPLIST,GEONAM,1) + CALL LCMEXP(IPLIST,0,IFILE,1,2) + IRC=KDRCLS(IFILE,2) + IF(IRC.LT.0) CALL XABORT('GEODIN: KDRCLS FAILURE.') + CALL LCMGET(IPLIST,'STATE-VECTOR',ISTATE) + LHEX=(ISTATE(1).EQ.8).OR.(ISTATE(1).EQ.9).OR.(ISTATE(1).EQ.24) + 1 .OR.(ISTATE(1).EQ.25) + LTRI=(ISTATE(1).EQ.13).OR.(ISTATE(1).EQ.14) + CALL LCMGET(IPLIST,'NCODE',NCODE) + CALL LCMGET(IPLIST,'ZCODE',ZCODE) + CALL LCMGET(IPLIST,'ICODE',ICODE) + ENDIF +* + 50 CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('GEODIN: CHARACTER DATA EXPECTED(2).') + 60 IF(CARLIR.EQ.'EDIT') THEN + CALL REDGET(ITYPLU,IMPX,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') + ELSE IF((CARLIR.EQ.'MIX').OR.(CARLIR.EQ.'CELL')) THEN +* INPUT MIXTURE NUMBERS OR FORCE SUB GEOMETRIES AT SPECIFIC +* LOCATIONS. + ALLOCATE(CELL(LREG),MIX(LREG)) + MIX(:LREG)=0 + LTOT=.TRUE. + I=0 + IKG=0 + 70 I=I+1 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.EQ.3) THEN + IF(CARLIR.EQ.'PLANE') THEN + IF(I.EQ.1) THEN + IF(ISTATE(1).EQ.7.OR.ISTATE(1).EQ.9) THEN + IF(ISTATE(1).EQ.9) LY=1 + CALL GEODMI(LX,LY,LZ,LCOUR,MIX,MINMIX,ISTATE(7)) + LTOT=.FALSE. + GO TO 70 + ELSE + CALL XABORT('GEODIN: INVALID KEY WORD PLANE FOR NON ' + 1 //' 3-D GEOMETRY') + ENDIF + ELSE + CALL XABORT('GEODIN: WRONG USE OF KEYWORD PLANE.') + ENDIF + ENDIF + IF((CARLIR(2:2).EQ.'-').OR.(CARLIR(2:2).EQ.'+').OR. + 1 (CARLIR.EQ.'HBC').OR.(CARLIR(1:4).EQ.'MESH').OR. + 2 (CARLIR(1:5).EQ.'SPLIT').OR.(CARLIR.EQ.'SIDE').OR. + 3 (CARLIR(:3).EQ.'MIX').OR.(CARLIR.EQ.'MERGE').OR. + 4 (CARLIR.EQ.'TURN').OR.(CARLIR.EQ.'CLUSTER').OR. + 5 (CARLIR(2:4).EQ.'PIN').OR.(CARLIR.EQ.'BIHET').OR. + 6 (CARLIR.EQ.'POURCE').OR.(CARLIR.EQ.'PROCEL').OR. + 7 (CARLIR.EQ.'SECT').OR.(CARLIR.EQ.'RADIUS').OR. + 8 (CARLIR.EQ.';').OR.(CARLIR.EQ.':::')) GO TO 90 + IF(I.GT.LREG) CALL XABORT('GEODIN: MIX/CELL INDEX OVERFLO' + 1 //'W.') + DO 80 J=1,I-1 + JKG=-MIX(J) + IF(CARLIR.EQ.CELL(JKG)) THEN + MIX(I)=-JKG + GO TO 70 + ENDIF + 80 CONTINUE + IKG=IKG+1 + ISTATE(8)=1 + MIX(I)=-IKG + CELL(IKG)=CARLIR + ELSE IF(ITYPLU.EQ.1) THEN + IF(I.GT.LREG) CALL XABORT('GEODIN: MIX INDEX OVERFLOW.') + MIX(I)=INTLIR + ISTATE(7)=MAX(ISTATE(7),MIX(I)) + MINMIX=MIN(MINMIX,MIX(I)) + ELSE + CALL XABORT('GEODIN: INTEGER OR CHARACTER DATA EXPECTED.') + ENDIF + GO TO 70 + 90 CONTINUE + IF(CARLIR.EQ.'REPEAT') THEN + NBR=LREG/(I-1) + NBRR=NBR*(I-1) + IF(NBRR.NE.LREG) THEN + WRITE(IOUT,530) I-1,LREG + CALL XABORT('GEODIN: IMPOSSIBLE TO REPEAT AN INTEGER NUMB' + 1 //'ER OF TIMES.') + ENDIF + JREP=I-1 + DO IREP=1,NBR-1 + DO II=1,I-1 + JREP=JREP+1 + MIX(JREP)=MIX(II) + ENDDO + ENDDO + I=JREP+1 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('GEODIN: CHARACTER DATA EXPECTE' + 1 //'D.') + ENDIF + IF(LTOT) LREG=I-1 + IF(IKG.GT.0) CALL LCMPTC(IPLIST,'CELL',12,IKG,CELL) + CALL LCMPUT(IPLIST,'MIX',LREG,1,MIX) + DEALLOCATE(MIX,CELL) + GO TO 60 + ELSE IF(CARLIR(1:4).EQ.'MESH') THEN +* INPUT CARTESIAN COORDINATES. + IF(CARLIR(5:5).EQ.'X') THEN + IF(LX.EQ.0) CALL XABORT('GEODIN: MESHX - LX=0.') + LMESH=LX+1 + ELSE IF(CARLIR(5:5).EQ.'Y') THEN + IF(LY.EQ.0) CALL XABORT('GEODIN: MESHY - LY=0.') + LMESH=LY+1 + ELSE IF(CARLIR(5:5).EQ.'Z') THEN + IF(LZ.EQ.0) CALL XABORT('GEODIN: MESHZ - LZ=0.') + LMESH=LZ+1 + ELSE + CALL XABORT('GEODIN: INVALID MESH SUFFIX.') + ENDIF + ALLOCATE(RMESH(LMESH)) + DO 100 I=1,LMESH + CALL REDGET(ITYPLU,INTLIR,RMESH(I),TEXT12,DBLLIR) + IF(ITYPLU.NE.2) CALL XABORT('GEODIN: REAL DATA EXPECTED.') + IF(I.GT.1) THEN + IF(RMESH(I).LE.RMESH(I-1)) THEN + CALL XABORT('GEODIN: NON INCREASING MESHES.') + ENDIF + ENDIF + 100 CONTINUE + CALL LCMPUT(IPLIST,CARLIR,LMESH,2,RMESH) + DEALLOCATE(RMESH) + ELSE IF(CARLIR.EQ.'SIDE') THEN +* INPUT THE SIDE LENGTH IN TRIANGULAR OR HEXAGONAL GEOMETRY. + IF((.NOT.LHEX).AND.(.NOT.LTRI)) CALL XABORT('GEODIN: SIDE PRO' + 1 //'HIBITED.') + CALL REDGET(ITYPLU,INTLIR,SIDE,CARLIR,DBLLIR) + IF(ITYPLU.NE.2) CALL XABORT('GEODIN: REAL DATA EXPECTED.') + CALL LCMPUT(IPLIST,'SIDE',1,2,SIDE) + ELSE IF (CARLIR.EQ.'RADS') THEN +* OPTIONS FOR CYLINDRICAL CORRECTION IN CARTESIAN GEOMETRY. + IF((ISTATE(1).NE.5).AND.(ISTATE(1).NE.7)) CALL XABORT('GEO' + 1 //'IN1: OPTION RADS IS LIMITED TO CARTESIAN GEOMETRIES.') + CALL REDGET(INDIC,NR0,REALIR,TEXT4,DBLLIR) + SWANG=TEXT4.EQ.'ANG' + IF(SWANG) CALL REDGET(INDIC,NR0,REALIR,TEXT4,DBLLIR) + IF(INDIC.NE.1) CALL XABORT('GEO: INTEGER DATA EXPECTED.') + IF(NR0.EQ.0) CALL XABORT('GEODIN: NON-ZERO INTEGER EXPECTED.') + ALLOCATE(XR0(NR0),RR0(NR0),ANG(NR0)) + DO 135 I=1,NR0 + CALL REDGET(INDIC,INTLIR,XR0(I),TEXT4,DBLLIR) + IF(INDIC.NE.2) CALL XABORT('GEODIN: REAL DATA EXPECTED.') + CALL REDGET(INDIC,INTLIR,RR0(I),TEXT4,DBLLIR) + IF(INDIC.NE.2) CALL XABORT('GEODIN: REAL DATA EXPECTED.') + IF(SWANG) THEN + CALL REDGET(INDIC,INTLIR,ANG(I),TEXT4,DBLLIR) + IF(INDIC.NE.2) CALL XABORT('GEODIN: REAL DATA EXPECTED.') + ELSE +* USE PI/2 + 0.1 + ANG(I)=1.670796327 + ENDIF + 135 CONTINUE + CALL LCMPUT(IPLIST,'XR0',NR0,2,XR0) + CALL LCMPUT(IPLIST,'RR0',NR0,2,RR0) + CALL LCMPUT(IPLIST,'ANG',NR0,2,ANG) + DEALLOCATE(ANG,RR0,XR0) + ELSE IF(CARLIR(1:5).EQ.'SPLIT') THEN +* INPUT MESH SPLITTING FACTORS. + ISTATE(11)=1 + IF(CARLIR(6:6).EQ.'X') THEN + IF(LX.EQ.0) CALL XABORT('GEODIN: SPLITX - LX=0.') + LMESH=LX + ELSE IF(CARLIR(6:6).EQ.'Y') THEN + IF(LY.EQ.0) CALL XABORT('GEODIN: SPLITY - LY=0.') + LMESH=LY + ELSE IF(CARLIR(6:6).EQ.'Z') THEN + IF(LZ.EQ.0) CALL XABORT('GEODIN: SPLITZ - LZ=0.') + LMESH=LZ + ELSE IF(CARLIR(6:6).EQ.'R') THEN + IF(LR.EQ.0) CALL XABORT('GEODIN: SPLITR - LR=0.') + LMESH=LR + ELSE IF(CARLIR(6:6).EQ.'H') THEN + IF(LX.EQ.0) CALL XABORT('GEODIN: SPLITH - LX=0.') + LMESH=1 + ELSE IF(CARLIR(6:6).EQ.'L') THEN + IF(LX.EQ.0) CALL XABORT('GEODIN: SPLITL - LX=0.') + LMESH=1 + ELSE + CALL XABORT('GEODIN: INVALID SPLIT SUFFIX.') + ENDIF + ALLOCATE(MESH(LMESH)) + DO 140 I=1,LMESH + CALL REDGET(ITYPLU,MESH(I),REALIR,TEXT12,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') + IF(CARLIR.EQ.'SPLITR') THEN + IF(MESH(I).EQ.0) THEN + CALL XABORT('GEODIN: INVALID MESH-SPLITTING INDEX(1).') + ENDIF + ELSE IF((CARLIR.EQ.'SPLITH').OR.(CARLIR.EQ.'SPLITL')) THEN + IF(MESH(I).LT.0) THEN + CALL XABORT('GEODIN: INVALID MESH-SPLITTING INDEX(2).') + ENDIF + ELSE + IF(MESH(I).LE.0) THEN + CALL XABORT('GEODIN: INVALID MESH-SPLITTING INDEX(3).') + ENDIF + ENDIF + 140 CONTINUE + CALL LCMPUT(IPLIST,CARLIR,LMESH,1,MESH) + DEALLOCATE(MESH) + ELSE IF(CARLIR.EQ.'MERGE') THEN +* INPUT CELL-MERGING INDICES. + ISTATE(10)=1 + ALLOCATE(MERGE(LREG)) + I=0 + 150 I=I+1 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.EQ.3) GO TO 160 + IF(ITYPLU.NE.1) CALL XABORT('GEODIN: INTEGER DATA EXPECTED.') + IF(I.GT.LREG) CALL XABORT('GEODIN: MERGE INDEX OVERFLOW.') + MERGE(I)=INTLIR + GO TO 150 + 160 LREG=I-1 + CALL LCMPUT(IPLIST,'MERGE',LREG,1,MERGE) + DEALLOCATE(MERGE) + GO TO 60 + ELSE IF(CARLIR.EQ.'TURN') THEN +* INPUT ORIENTATION INFORMATION. + ALLOCATE(TURN(LREG)) + I=0 + 170 I=I+1 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('GEODIN: CHARACTER DATA EXPECTED.') + DO 180 J=1,MAXTUR + IF(CARLIR.EQ.CTUR(J)) THEN + IF(I.GT.LREG) CALL XABORT('GEODIN: TURN INDEX OVERFLOW(1).') + TURN(I)=J + GO TO 170 + ELSE IF(CARLIR.EQ.'-'//CTUR(J)) THEN + IF(I.GT.LREG) CALL XABORT('GEODIN: TURN INDEX OVERFLOW(2).') + TURN(I)=MAXTUR+J + GO TO 170 + ENDIF + 180 CONTINUE + LREG=I-1 + CALL LCMPUT(IPLIST,'TURN',LREG,1,TURN) + DEALLOCATE(TURN) + GO TO 60 + ELSE IF((CARLIR(2:2).EQ.'+').OR.(CARLIR(2:2).EQ.'-').OR. + 1 (CARLIR.EQ.'HBC')) THEN +* INPUT BOUNDARY CONDITIONS. + ISURF=-99 + IF(CARLIR.EQ.'X-') THEN + ISURF=1 + IF(LX.EQ.0) CALL XABORT('GEODIN: HBC X- -> LX=0.') + ELSE IF(CARLIR.EQ.'X+') THEN + ISURF=2 + IF(LX.EQ.0) CALL XABORT('GEODIN: HBC X+ -> LX=0.') + ELSE IF(CARLIR.EQ.'R+') THEN + ISURF=2 + IF(LR.EQ.0) CALL XABORT('GEODIN: HBC R+ -> LR=0.') + ELSE IF(CARLIR.EQ.'Y-') THEN + ISURF=3 + IF(LY.EQ.0) CALL XABORT('GEODIN: HBC Y- -> LY=0.') + ELSE IF(CARLIR.EQ.'Y+') THEN + ISURF=4 + IF(LY.EQ.0) CALL XABORT('GEODIN: HBC Y+ -> LY=0.') + ELSE IF(CARLIR.EQ.'Z-') THEN + ISURF=5 + IF(LZ.EQ.0) CALL XABORT('GEODIN: HBC Z- -> LZ=0.') + ELSE IF(CARLIR.EQ.'Z+') THEN + ISURF=6 + IF(LZ.EQ.0) CALL XABORT('GEODIN: HBC Z+ -> LZ=0.') + ELSE IF(CARLIR.EQ.'HBC') THEN + ISURF=1 + IF(.NOT.LHEX) CALL XABORT('GEODIN: HBC PROHIBITED.') + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('GEODIN: CHARACTER DATA EXPECTE' + 1 //'D.') + DO 330 I=1,MAXHEX + IF(CARLIR.EQ.CHEX(I)) THEN + IHEX=I + GO TO 340 + ENDIF + 330 CONTINUE + CALL XABORT('GEODIN: INVALID TYPE OF HEXAGONAL SYMMETRY.') + 340 CALL LCMPUT(IPLIST,'IHEX',1,1,IHEX) + LCOUR=IHEX.EQ.9 + ELSE IF(CARLIR.EQ.'TBC') THEN + ISURF=1 + IF(.NOT.LTRI) CALL XABORT('GEODIN: TBC PROHIBITED.') + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('GEODIN: CHARACTER DATA EXPECTE' + 1 //'D.') + DO 350 I=1,MAXTEX + IF(CARLIR.EQ.CHET(I)) THEN + ITRI=I + GO TO 360 + ENDIF + 350 CONTINUE + CALL XABORT('GEODIN: INVALID TYPE OF TRIANGULAR SYMMETRY.') + 360 CALL LCMPUT(IPLIST,'ITRI',1,1,ITRI) + ELSE + CALL XABORT('GEODIN: INVALID KEY WORD '//CARLIR//'.') + ENDIF + CALL REDGET(ITYPLU,INTLIR,REALIR,TEXT4,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('GEODIN: CHARACTER DATA EXPECTED.') + DO 370 I=1,MAXCOD + IF(TEXT4.EQ.COND(I)) THEN + NCODE(ISURF)=I + IF(TEXT4.EQ.'ACYL') NCODE(ISURF)=I-1 + GO TO 380 + ENDIF + 370 CONTINUE + CALL XABORT('GEODIN: INVALID TYPE OF BOUNDARY CONDITION.') + 380 IF(TEXT4.EQ.'ALBE') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,TEXT4,DBLLIR) + IF(ITYPLU.EQ.1) THEN + ICODE(ISURF)=INTLIR + MINICO=MIN(MINICO,INTLIR) + ELSE IF(ITYPLU.EQ.2) THEN + ZCODE(ISURF)=REALIR + ELSE + CALL XABORT('GEODIN: INTEGER OR REAL DATA EXPECTED.') + ENDIF + ELSE IF(TEXT4.EQ.'ACYL') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,TEXT4,DBLLIR) + IF(ITYPLU.EQ.1) THEN + ICODE(ISURF)=INTLIR + MINICO=MIN(MINICO,INTLIR) + ELSE IF(ITYPLU.EQ.2) THEN + ZCODE(ISURF)=REALIR + ELSE + CALL XABORT('GEODIN: INTEGER OR REAL DATA EXPECTED ' + 1 //'AFTER ACYL.') + ENDIF + ELSE IF(TEXT4.EQ.'REFL') THEN + ZCODE(ISURF)=1.0 + ELSE IF(TEXT4.EQ.'VOID') THEN + ZCODE(ISURF)=0.0 + ENDIF + ELSE IF(CARLIR.EQ.';') THEN +* END-OF-GEOMETRY. + GO TO 410 + ELSE IF(CARLIR.EQ.':::') THEN +* INPUT A SUB GEOMETRY. + CALL XABORT('GEODIN: SUB-GEOMETRY NOT ALLOWED.') + ELSE IF(CARLIR.EQ.'MIX-NAMES') THEN +* DEFINE MIXTURE CHARACTER NAMES. + IF(LEVEL.NE.1) CALL XABORT('GEODIN: MIX-NAMES DATA SHOULD BE ' + 1 //'WRITTEN ON FIRST DIRECTORY LEVEL.') + ALLOCATE(CELL(LREG)) + I=0 + 390 I=I+1 + CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR) + IF(ITYPLU.NE.3) CALL XABORT('GEODIN: CHARACTER DATA EXPECTED.') + IF((CARLIR(2:2).EQ.'-').OR.(CARLIR(2:2).EQ.'+').OR. + 1 (CARLIR.EQ.'HBC').OR.(CARLIR(1:4).EQ.'MESH').OR.(CARLIR(1:5) + 2 .EQ.'SPLIT').OR.(CARLIR.EQ.'SIDE').OR.(CARLIR(:3).EQ.'MIX').OR. + 3 (CARLIR.EQ.'CELL').OR.(CARLIR.EQ.'MERGE').OR.(CARLIR.EQ.'TURN') + 4 .OR.(CARLIR(2:4).EQ.'PIN').OR.(CARLIR.EQ.'BIHET').OR. + 5 (CARLIR.EQ.'POURCE').OR.(CARLIR.EQ.'PROCEL').OR. + 6 (CARLIR.EQ.'SECT').OR.(CARLIR.EQ.'RADIUS').OR.(CARLIR.EQ.';') + 7 .OR. (CARLIR.EQ.':::')) GO TO 400 + IF(I.GT.LREG) CALL XABORT('GEODIN: MIX-NAMES INDEX OVERFLOW.') + CELL(I)=CARLIR + GO TO 390 + 400 CALL LCMPTC(IPLIST,'MIX-NAMES',12,I-1,CELL) + ISTATE(13)=I-1 + DEALLOCATE(CELL) + GO TO 60 + ELSE + CALL XABORT('GEODIN: '//CARLIR//' IS AN INVALID KEY WORD.') + ENDIF + GO TO 50 +* + 410 CARLIR='L_GEOM' + CALL LCMPTC(IPLIST,'SIGNATURE',12,CARLIR) + CALL LCMPUT(IPLIST,'STATE-VECTOR',NSTATE,1,ISTATE) + CALL LCMPUT(IPLIST,'NCODE',6,1,NCODE) + CALL LCMPUT(IPLIST,'ZCODE',6,2,ZCODE) + CALL LCMPUT(IPLIST,'ICODE',6,1,ICODE) + IF(MINMIX.LT.0) + > CALL XABORT('GEODIN: NEGATIVE MIXTURE NUMBERS INVALID') + IF(MINICO.LT.1) + > CALL XABORT('GEODIN: ALBEDO NUMBER MUST BE GREATER THAN 0') + MAXMIX=ISTATE(7) + IF(IMPX.GT.0) THEN + CALL LCMINF(IPLIST,CARLIR,TEXT12,EMPTY,ILONG,LCM) + WRITE (IOUT,510) LEVEL,GEONAM,CARLIR,TYPE(ISTATE(1)) + ENDIF + IF(IMPX.GT.1) THEN + WRITE (IOUT,520) ISTATE(1),TYPE(ISTATE(1)),(ISTATE(I),I=2,14) + ENDIF + IF((ISTATE(8).EQ.1).AND.(ISTATE(9).EQ.0)) CALL XABORT('GEODIN: ' + 1 //'CELL OPTION ACTIVATED WITHOUT SUB-GEOMETRIES.') + RETURN +* + 510 FORMAT(/20H CREATION OF A LEVEL,I3,27H GEOMETRY ON THE DIRECTORY , + 1 7HNAMED ',A12,21H' OF THE LCM OBJECT ',A12,12H' WITH TYPE ,A16, + 2 1H.) + 520 FORMAT(/14H STATE VECTOR:/ + 1 7H ITYPE ,I6, 4H (,A16,1H)/ + 2 7H LR ,I6,20H (NUMBER OF TUBES)/ + 3 7H LX ,I6,22H (X-DIMENSION INDEX)/ + 4 7H LY ,I6,22H (Y-DIMENSION INDEX)/ + 5 7H LZ ,I6,22H (Z-DIMENSION INDEX)/ + 6 7H LREG ,I6,22H (NUMBER OF REGIONS)/ + 7 7H MAXMIX,I6,48H (MAX. NB. OF MIXTURES/0=TRANSPARENT GEOMETRY)/ + 8 7H ISUB1 ,I6,34H (1=COMMAND CELL IS USED/0=ELSE)/ + 9 7H ISUB2 ,I6,29H (NUMBER OF SUB GEOMETRIES)/ + 1 7H IMERGE,I6,26H (1=CELL-MERGING/0=ELSE)/ + 2 7H ISPLIT,I6,28H (1=MESH-SPLITTING/0=ELSE)/ + 3 7H IBIHET,I6,34H (1=DOUBLE HETEROGENEITY/0=ELSE)/ + 4 7H ICLUST,I6,28H (NUMBER OF CLUSTER RINGS)/ + 5 7H ISECT ,I6,26H (TYPE OF SECTORIZATION)) + 530 FORMAT(' ***** Error in GEODIN *****'/ + 1 ' Initial number of mixtures ',I10/ + 2 ' Cannot be repeated an integer number of times', + 3 ' to fill ',I10,' mixtures') + END diff --git a/Trivac/src/GEODMI.f b/Trivac/src/GEODMI.f new file mode 100755 index 0000000..fd06cab --- /dev/null +++ b/Trivac/src/GEODMI.f @@ -0,0 +1,244 @@ +*DECK GEODMI
+ SUBROUTINE GEODMI(LX,LY,LZ,LCOUR,MIX,MINMIX,MAXMIX)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Build array MIX from plane-defined information.
+*
+*Copyright:
+* Copyright (C) 2002 Ecole Polytechnique de Montreal
+* This library is free software; you can redistribute it and/or
+* modify it under the terms of the GNU Lesser General Public
+* License as published by the Free Software Foundation; either
+* version 2.1 of the License, or (at your option) any later version
+*
+*Author(s): E. Varin and R. Roy
+*
+*Parameters: input
+* LX number of meshes along X-axis.
+* LY number of meshes along Y-axis.
+* LZ number of meshes along Z-axis.
+* LCOUR flag indicating if 'CROWN' or 'UPTO' keywords are allowed.
+* MIX array of material mixtures.
+*
+*Parameters: output
+* MINMIX minimum number of mixtures, considering all sub-geometries.
+* MAXMIX maximum number of mixtures, considering all sub-geometries.
+*
+*-----------------------------------------------------------------------
+*
+ IMPLICIT NONE
+*----
+* SUBROUTINE ARGUMENTS
+*----
+ INTEGER LX,LY,LZ,MIX(LX,LY,LZ),MINMIX,MAXMIX
+ LOGICAL LCOUR
+*----
+* LOCAL VARIABLES
+*----
+ INTEGER IZ1,IZ2,IZ3,IX,IY,NZ,NC,NCSAME,IC,INDIC,NITMA,IHEX
+ CHARACTER TEXT12*12
+ REAL FLOTT
+ DOUBLE PRECISION DFLOTT
+*----
+* READ AN OPTION KEYWORD
+*----
+ IHEX= 0
+ NC = -1
+ NZ = 0
+ 5 IZ2 = 0
+ CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+ IF(INDIC.EQ.1) THEN
+ NZ = NZ + 1
+ IZ1 = NITMA
+ IF( IZ1.LT.1.OR.IZ1.GT.LZ )THEN
+ CALL XABORT('GEODMI: INVALID PLANE NUMBER'//
+ > '(GREATER THAN *LZ*).')
+ ENDIF
+ ELSE
+ CALL XABORT('GEODMI: PLANE NUMBER MUST BE READ'//
+ > '(INTEGER EXPECTED).')
+ ENDIF
+ CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+ IF( INDIC.EQ.3 )THEN
+ IF(TEXT12.EQ.'SAME') THEN
+ CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+ IF(INDIC.EQ.1) THEN
+ IZ2 = NITMA
+ IF( IZ2.GT.IZ1 )THEN
+ CALL XABORT('GEODMI: INVALID PLANE NUMBER'//
+ > '(GREATER THAN PREVIOUS).')
+ ENDIF
+ GOTO 20
+ ELSE
+ CALL XABORT('GEODMI: SAME AS WHICH PLANE? '//
+ > '(INTEGER EXPECTED).')
+ ENDIF
+ ELSEIF((TEXT12.EQ.'CROWN'.OR.TEXT12.EQ.'UPTO').AND.LCOUR) THEN
+ NCSAME= 1
+ IF( TEXT12.EQ.'UPTO' )THEN
+ CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+ IF(INDIC.NE.1) CALL XABORT('GEODMI: INTEGER DATA'//
+ > ' EXPECTED AFTER *UPTO* KEYWORD')
+ NCSAME= NITMA
+ ENDIF
+ GO TO 30
+ ELSEIF(.NOT.LCOUR.AND.(TEXT12.EQ.'CROWN'.OR.TEXT12.EQ.'UPTO'))
+ > THEN
+ CALL XABORT('GEODMI: UNSUPPORTED KEYWORD *CROWN* OR *UPTO*'
+ > //': HEX3D COMPLETE ONLY')
+ ELSE
+ CALL XABORT('GEODMI: INVALID CHARACTER VARIABLE '//TEXT12)
+ ENDIF
+ ELSEIF (INDIC.EQ.1) THEN
+ GOTO 20
+ ELSE
+ CALL XABORT('GEODMI: INTEGER OR CHARACTER VARIABLE EXPECTED')
+ ENDIF
+*----
+* READ A CWOWN
+*----
+ 30 CONTINUE
+ NC= NC+1
+ CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+ IF( INDIC.EQ.3 )THEN
+ IF(TEXT12.EQ.'SAME') THEN
+ CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+ IF(INDIC.EQ.1) THEN
+ IZ3= NITMA
+ IF( IZ3.GT.IZ1 )THEN
+ CALL XABORT('GEODMI: INVALID PLANE NUMBER'//
+ > '(GREATER THAN PREVIOUS).')
+ ENDIF
+ DO 41 IC= 1, NCSAME
+ IF( NC.EQ.0 )THEN
+ MIX(IHEX+1,1,IZ1)= MIX(IHEX+1,1,IZ3)
+ IHEX= IHEX+1
+ ELSE
+ DO 31 IX= IHEX+1, IHEX+6*NC
+ MIX(IX,1,IZ1)= MIX(IX,1,IZ3)
+ 31 CONTINUE
+ IHEX= IHEX+6*NC
+ ENDIF
+ NC= NC+1
+ 41 CONTINUE
+ NC= NC -1
+ ELSE
+ CALL XABORT('GEODMI: SAME AS WHICH PLANE? '//
+ > '(INTEGER EXPECTED).')
+ ENDIF
+ ELSEIF(TEXT12.EQ.'ALL') THEN
+ CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+ IF(INDIC.EQ.1) THEN
+ MAXMIX=MAX(MAXMIX,NITMA)
+ MINMIX=MIN(MINMIX,NITMA)
+ DO 42 IC= 1, NCSAME
+ IF( NC.EQ.0 )THEN
+ MIX(IHEX+1,1,IZ1)= NITMA
+ IHEX= IHEX+1
+ ELSE
+ DO 32 IX= IHEX+1, IHEX+6*NC
+ MIX(IX,1,IZ1)= NITMA
+ 32 CONTINUE
+ IHEX= IHEX+6*NC
+ ENDIF
+ NC= NC+1
+ 42 CONTINUE
+ NC= NC -1
+ ELSE
+ CALL XABORT('GEODMI: ALL OF WHICH MIX? '//
+ > '(INTEGER EXPECTED).')
+ ENDIF
+ ELSE
+ CALL XABORT('GEODMI: KEYWORD *SAME* OR *ALL* '//
+ > '(CHARACTER EXPECTED).')
+ ENDIF
+ ELSEIF( INDIC.EQ.1 )THEN
+ IF( NCSAME.NE.1 )THEN
+ CALL XABORT('GEODMI: INVALID INTEGER WITH *UPTO* ')
+ ENDIF
+ IF( NC.EQ.0 )THEN
+ MIX(IHEX+1,1,IZ1)= NITMA
+ IHEX= IHEX+1
+ ELSE
+ DO 33 IX= 1, 6*NC
+ IF(.NOT.(IX.EQ.1) ) THEN
+ CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+ IF(INDIC.NE.1)THEN
+ WRITE(6,*) 'NC=',NC,' IZ1=',IZ1,' NCSAME=',NCSAME
+ WRITE(6,*) 'IHEX=',IHEX,' INDIC=',INDIC,' C=',TEXT12
+ CALL XABORT('GEODMI: 1. INTEGER DATA EXPECTED')
+ ENDIF
+ ENDIF
+ MIX(IHEX+IX,1,IZ1) = NITMA
+ MAXMIX=MAX(MAXMIX,NITMA)
+ MINMIX=MIN(MINMIX,NITMA)
+ 33 CONTINUE
+ IHEX= IHEX+6*NC
+ ENDIF
+ ELSE
+ CALL XABORT('GEODMI: MIXTURE # EXPECTED '//
+ > '(INTEGER EXPECTED).')
+ ENDIF
+ IF( IHEX.LT.LX )THEN
+ CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+ IF(INDIC.NE.3)THEN
+ WRITE(6,*) ' TEST IZ1-2-3',IZ1,IZ2,IZ3,' IHEX NC',IHEX,NC
+ CALL XABORT('GEODMI: KEYWORD *CROWN* OR *UPTO*'//
+ > ' MUST BE READ.')
+ ENDIF
+ IF( TEXT12.EQ.'CROWN') THEN
+ NCSAME= 1
+ ELSEIF( TEXT12.EQ.'UPTO') THEN
+ CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+ IF(INDIC.NE.1) CALL XABORT('GEODMI: INTEGER DATA'//
+ > ' EXPECTED AFTER *UPTO* KEYWORD')
+ NCSAME= NITMA-NC-1
+ ELSE
+ CALL XABORT('GEODMI: KEYWORD *CROWN* OR *UPTO*'//
+ > ' MUST BE READ.')
+ ENDIF
+ GO TO 30
+ ELSEIF( IHEX.EQ.LX )THEN
+ GO TO 25
+ ELSE
+ CALL XABORT('GEODMI: INVALID # OF MIX IN THIS PLANE.')
+ ENDIF
+*----
+* READ MIXTURE INDICES BY PLANE
+*----
+ 20 IF (IZ2.EQ.0) THEN
+ DO 22 IY=1,LY
+ DO 21 IX=1,LX
+ IF(.NOT.((IX.EQ.1).AND.(IY.EQ.1))) THEN
+ CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+ IF(INDIC.NE.1) CALL XABORT('GEODMI: 2. INTEGER DATA EXPECTED')
+ ENDIF
+ MIX(IX,IY,IZ1) = NITMA
+ MAXMIX=MAX(MAXMIX,NITMA)
+ MINMIX=MIN(MINMIX,NITMA)
+ 21 CONTINUE
+ 22 CONTINUE
+ ELSE
+ DO 24 IY=1,LY
+ DO 23 IX=1,LX
+ MIX(IX,IY,IZ1) = MIX(IX,IY,IZ2)
+ 23 CONTINUE
+ 24 CONTINUE
+ ENDIF
+*
+ 25 CONTINUE
+ IF (NZ.LT.LZ) THEN
+ CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+ IF(INDIC.NE.3.OR.TEXT12.NE.'PLANE') THEN
+ CALL XABORT('GEODMI: KEYWORD *PLANE* MUST BE READ.')
+ ENDIF
+ NC= -1
+ IHEX= 0
+ GO TO 5
+ ENDIF
+ IF (NZ.NE.LZ) CALL XABORT('GEODMI: WRONG NUMBER OF PLANES')
+*
+ RETURN
+ END
diff --git a/Trivac/src/GPTAFL.f b/Trivac/src/GPTAFL.f new file mode 100755 index 0000000..4fc87c8 --- /dev/null +++ b/Trivac/src/GPTAFL.f @@ -0,0 +1,235 @@ +*DECK GPTAFL + SUBROUTINE GPTAFL (IPTRK,IPSYS0,IPFLUP,LL4,ITY,NUN,NGRP,ICL1,ICL2, + 1 NSTART,IMPX,IMPH,TITR,EPS2,MAXINR,EPSINR,NADI,MAXX0,FKEFF,EVECT, + 2 ADECT,FKEFF2,EASS,SOUR) +* +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solution of a multigroup fixed source eigenvalue problem for the +* calculation of an adjoint gpt solution in Trivac. use the precondi- +* tioned power method. +* +*Copyright: +* Copyright (C) 1987 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK L_TRACK pointer to the tracking information +* IPSYS0 L_SYSTEM pointer to unperturbed system matrices +* IPFLUP L_FLUX pointer to the gpt solution +* LL4 order of the system matrices. +* ITY type of solution (2: classical Trivac; 3: Thomas-Raviart). +* NUN number of unknowns in each energy group. +* NGRP number of energy groups. +* ICL1 number of free iterations in one cycle of the inverse power +* method +* ICL2 number of accelerated iterations in one cycle +* NSTART GMRES method flag. =0: use Livolant acceleration; +* >0: restarts the GMRES method every NSTART iterations. +* IMPX print parameter. =0: no print; =1: minimum printing; +* =2: iteration history is printed; =3: solution is printed. +* IMPH =0: no action is taken +* =1: the flux is compared to a reference flux stored on lcm +* =2: the convergence histogram is printed +* =3: the convergence histogram is printed with axis and +* titles. the plotting file is completed +* =4: the convergence histogram is printed with axis, acce- +* leration factors and titles. the plotting file is +* completed. +* TITR character*72 title +* EPS2 convergence criteria for the flux +* MAXINR maximum number of thermal iterations. +* EPSINR thermal iteration epsilon. +* NADI initial number of inner adi iterations per outer iteration +* MAXX0 maximum number of outer iterations +* FKEFF effective multiplication factor +* EVECT unknown vector for the non perturbed direct flux +* ADECT unknown vector for the non perturbed adjoint flux +* SOUR fixed source +* +*Parameters: output +* FKEFF2 perturbed effective multiplication factor +* EASS converged generalized adjoint +* +*References: +* A. H\'ebert, 'Preconditioning the power method for reactor +* calculations', Nucl. Sci. Eng., 94, 1 (1986). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPSYS0,IPFLUP + CHARACTER TITR*72,HSMG*131 + INTEGER LL4,ITY,NUN,NGRP,ICL1,ICL2,NSTART,IMPX,IMPH,MAXINR,NADI, + 1 MAXX0 + REAL EPS2,EPSINR,FKEFF,EVECT(NUN,NGRP),ADECT(NUN,NGRP),FKEFF2, + 1 EASS(NUN,NGRP),SOUR(NUN,NGRP) +*---- +* LOCAL VARIABLES +*---- + CHARACTER*12 TEXT12 + DOUBLE PRECISION AIL,BIL,EVAL,ZNORM,GAZ,DAZ + REAL TKT,TKB + REAL, DIMENSION(:), ALLOCATABLE :: WORK1,WORK3 + REAL, DIMENSION(:,:), ALLOCATABLE :: GRAD1,GAR1 + REAL, DIMENSION(:), POINTER :: AGAR + TYPE(C_PTR) AGAR_PTR + DATA EPS1/1.0E-4/ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(GRAD1(NUN,NGRP),GAR1(NUN,NGRP),WORK1(NUN)) +* + CALL MTOPEN(IMPX,IPTRK,LL4) + IF(LL4.GT.NUN) CALL XABORT('DELDFL: INVALID NUMBER OF UNKNOWNS.') +*---- +* UNPERTURBED EIGENVALUE CALCULATION. +*---- + AIL=0.0D0 + BIL=0.0D0 + DO 85 IGR=1,NGRP + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL MTLDLM(TEXT12,IPTRK,IPSYS0,LL4,ITY,EVECT(1,IGR),GRAD1(1,IGR)) + WORK1(:LL4)=0.0 + DO 70 JGR=1,NGRP + IF(JGR.EQ.IGR) GO TO 40 + WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS0,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 40 + IF(ITY.EQ.13) THEN + ALLOCATE(WORK3(LL4)) + CALL MTLDLM(TEXT12,IPTRK,IPSYS0,LL4,ITY,EVECT(1,JGR),WORK3(1)) + DO 20 I=1,LL4 + GRAD1(I,IGR)=GRAD1(I,IGR)-WORK3(I) + 20 CONTINUE + DEALLOCATE(WORK3) + ELSE + CALL LCMGPD(IPSYS0,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ NUN /)) + DO 30 I=1,ILONG + GRAD1(I,IGR)=GRAD1(I,IGR)-AGAR(I)*EVECT(I,JGR) + 30 CONTINUE + ENDIF +* + 40 WRITE(TEXT12,'(1HB,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS0,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 70 + CALL LCMGPD(IPSYS0,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ NUN /)) + DO 60 I=1,ILONG + WORK1(I)=WORK1(I)+AGAR(I)*EVECT(I,JGR) + 60 CONTINUE +* + 70 CONTINUE + DO 80 I=1,LL4 + AIL=AIL+ADECT(I,IGR)*GRAD1(I,IGR) + BIL=BIL+ADECT(I,IGR)*WORK1(I) + 80 CONTINUE + 85 CONTINUE + EVAL=AIL/BIL + FKEFF2=REAL(1.0D0/EVAL) + IF(ABS(FKEFF-1.0/EVAL).GT.EPS1) CALL XABORT('GPTAFL: THE COMPUTE' + 1 //'D AND PROVIDED K-EFFECTIVES ARE INCONSISTENTS.') +*---- +* VALIDATION OF THE FIXED SOURCE TERM. +*---- + AIL=0.0D0 + BIL=0.0D0 + DO 95 IGR=1,NGRP + DO 90 I=1,LL4 + GAZ=EVECT(I,IGR)*SOUR(I,IGR) + DAZ=EVECT(I,IGR)**2 + AIL=AIL+GAZ + BIL=BIL+DAZ + 90 CONTINUE + 95 CONTINUE + GAZ=ABS(AIL)/ABS(BIL)/REAL(LL4) + IF(AIL.EQ.0.0) THEN + EASS(:NUN,:NGRP)=0.0 + FKEFF2=0.0 + DEALLOCATE(GRAD1,GAR1,WORK1) + RETURN + ENDIF + IF(IMPX.GE.1) THEN + WRITE(6,'(/28H GPTAFL: ORTHONORMALIZATION=,1P,E11.4)') GAZ + ENDIF + IF(GAZ.GT.EPS2) THEN + WRITE(HSMG,'(46HGPTAFL: THE SOURCE TERM IS NOT ORTHOGONAL TO T, + 1 26HHE DIRECT REFERENCE FLUX (,1P,E11.4,2H).)') GAZ + CALL XABORT(HSMG) + ENDIF +*---- +* ORTHONORMALIZATION OF THE SOURCE TERM. +*---- + AIL=0.0D0 + BIL=0.0D0 + GAR1(:NUN,:NGRP)=0.0 + DO 110 IGR=1,NGRP + DO 100 JGR=1,NGRP + WRITE(TEXT12,'(1HB,2I3.3)') JGR,IGR + CALL LCMLEN(IPSYS0,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 100 + CALL LCMGPD(IPSYS0,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ NUN /)) + DO I=1,ILONG + GAR1(I,IGR)=GAR1(I,IGR)+AGAR(I)*ADECT(I,JGR) + ENDDO + 100 CONTINUE + DO I=1,LL4 + AIL=AIL+EVECT(I,IGR)*SOUR(I,IGR) + BIL=BIL+EVECT(I,IGR)*GAR1(I,IGR) + ENDDO + 110 CONTINUE + DO 125 IGR=1,NGRP + DO 120 I=1,LL4 + SOUR(I,IGR)=SOUR(I,IGR)-REAL(AIL/BIL)*GAR1(I,IGR) + 120 CONTINUE + 125 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION. +*---- + DEALLOCATE(GRAD1,GAR1,WORK1) +*---- +* LIVOLANT ACCELERATION. +*---- + IF(IMPX.GE.1) WRITE (6,600) NADI + IF(NSTART.EQ.0) THEN + CALL GPTLIV(IPTRK,IPSYS0,IPFLUP,.TRUE.,LL4,ITY,NUN,NGRP,ICL1, + 1 ICL2,IMPX,IMPH,TITR,NADI,MAXINR,MAXX0,EPS2,EPSINR,EVAL,EVECT, + 2 ADECT,EASS,SOUR,TKT,TKB,ZNORM,M) +*---- +* GMRES. +*---- + ELSE IF(NSTART.GT.0) THEN + CALL GPTMRA(IPTRK,IPSYS0,IPFLUP,.TRUE.,LL4,ITY,NUN,NGRP,ICL1, + 1 ICL2,IMPX,NADI,MAXINR,NSTART,MAXX0,EPS2,EPSINR,EVAL,EVECT,ADECT, + 2 EASS,SOUR,TKT,TKB,ZNORM,M) + ENDIF +*---- +* SOLUTION EDITION. +*---- + IF(IMPX.GE.1) WRITE (6,610) M + IF(IMPX.GE.3) THEN + DO 130 IGR=1,NGRP + WRITE (6,620) IGR,(EASS(I,IGR),I=1,LL4) + 130 CONTINUE + ENDIF + RETURN +* + 600 FORMAT(1H1/50H GPTAFL: ITERATIVE PROCEDURE BASED ON PRECONDITION, + 1 17HED POWER METHOD (,I2,37H ADI ITERATIONS PER OUTER ITERATION)./ + 2 9X,40HADJOINT FIXED SOURCE EIGENVALUE PROBLEM.) + 610 FORMAT(/23H GPTAFL: CONVERGENCE IN,I4,12H ITERATIONS.) + 620 FORMAT(//52H GPTAFL: GENERALIZED ADJOINT CORRESPONDING TO THE GR, + 1 3HOUP,I4//(5X,1P,8E14.5)) + END diff --git a/Trivac/src/GPTDFL.f b/Trivac/src/GPTDFL.f new file mode 100755 index 0000000..1496d51 --- /dev/null +++ b/Trivac/src/GPTDFL.f @@ -0,0 +1,233 @@ +*DECK GPTDFL + SUBROUTINE GPTDFL (IPTRK,IPSYS0,IPFLUP,LL4,ITY,NUN,NGRP,ICL1,ICL2, + 1 NSTART,IMPX,IMPH,TITR,EPS2,MAXINR,EPSINR,NADI,MAXX0,FKEFF,EVECT, + 2 ADECT,FKEFF2,EASS,SOUR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solution of a multigroup fixed source eigenvalue problem for the +* calculation of a direct GPT solution in Trivac. Use the precondi- +* tioned power method. +* +*Copyright: +* Copyright (C) 1987 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK L_TRACK pointer to the tracking information +* IPSYS0 L_SYSTEM pointer to unperturbed system matrices +* IPFLUP L_FLUX pointer to the gpt solution +* LL4 order of the system matrices. +* ITY type of solution (2: classical Trivac; 3: Thomas-Raviart). +* NUN number of unknowns in each energy group. +* NGRP number of energy groups. +* ICL1 number of free iterations in one cycle of the inverse power +* method +* ICL2 number of accelerated iterations in one cycle +* NSTART GMRES method flag. =0: use Livolant acceleration; +* >0: restarts the GMRES method every NSTART iterations. +* IMPX print parameter. =0: no print; =1: minimum printing; +* =2: iteration history is printed; =3: solution is printed. +* IMPH =0: no action is taken +* =1: the flux is compared to a reference flux stored on lcm +* =2: the convergence histogram is printed +* =3: the convergence histogram is printed with axis and +* titles. the plotting file is completed +* =4: the convergence histogram is printed with axis, acce- +* leration factors and titles. the plotting file is +* completed. +* TITR character*72 title +* EPS2 convergence criteria for the flux +* MAXINR maximum number of thermal iterations. +* EPSINR thermal iteration epsilon. +* NADI number of inner adi iterations per outer iteration +* MAXX0 maximum number of outer iterations +* FKEFF effective multiplication factor +* EVECT unknown vector for the non perturbed direct flux +* ADECT unknown vector for the non perturbed adjoint flux +* SOUR fixed source +* +*Parameters: output +* FKEFF2 perturbed effective multiplication factor +* EASS converged solution +* +*References: +* A. H\'ebert, 'Preconditioning the power method for reactor +* calculations', Nucl. Sci. Eng., 94, 1 (1986). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPSYS0,IPFLUP + CHARACTER TITR*72 + INTEGER LL4,ITY,NUN,NGRP,ICL1,ICL2,NSTART,IMPX,IMPH,MAXINR,NADI, + 1 MAXX0 + REAL EPS2,EPSINR,FKEFF,EVECT(NUN,NGRP),ADECT(NUN,NGRP),FKEFF2, + 1 EASS(NUN,NGRP),SOUR(NUN,NGRP) +*---- +* LOCAL VARIABLES +*---- + CHARACTER*12 TEXT12,HSMG*131 + DOUBLE PRECISION AIL,BIL,EVAL,ZNORM,GAZ,DAZ + REAL TKT,TKB + REAL, DIMENSION(:), ALLOCATABLE :: WORK1,WORK3 + REAL, DIMENSION(:,:), ALLOCATABLE :: GRAD1,GAR1 + REAL, DIMENSION(:), POINTER :: AGAR + TYPE(C_PTR) AGAR_PTR + DATA EPS1/1.0E-4/ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(GRAD1(NUN,NGRP),GAR1(NUN,NGRP),WORK1(NUN)) +* + CALL MTOPEN(IMPX,IPTRK,LL4) + IF(LL4.GT.NUN) CALL XABORT('GPTDFL: INVALID NUMBER OF UNKNOWNS.') +*---- +* UNPERTURBED EIGENVALUE CALCULATION. +*---- + AIL=0.0D0 + BIL=0.0D0 + TEST=0.0 + DO 85 IGR=1,NGRP + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL MTLDLM(TEXT12,IPTRK,IPSYS0,LL4,ITY,EVECT(1,IGR),GRAD1(1,IGR)) + WORK1(:LL4)=0.0 + DO 70 JGR=1,NGRP + IF(JGR.EQ.IGR) GO TO 40 + WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS0,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 40 + IF(ITY.EQ.13) THEN + ALLOCATE(WORK3(LL4)) + CALL MTLDLM(TEXT12,IPTRK,IPSYS0,LL4,ITY,EVECT(1,JGR),WORK3(1)) + DO 20 I=1,LL4 + GRAD1(I,IGR)=GRAD1(I,IGR)-WORK3(I) + 20 CONTINUE + DEALLOCATE(WORK3) + ELSE + CALL LCMGPD(IPSYS0,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ NUN /)) + DO 30 I=1,ILONG + GRAD1(I,IGR)=GRAD1(I,IGR)-AGAR(I)*EVECT(I,JGR) + 30 CONTINUE + ENDIF + 40 WRITE(TEXT12,'(1HB,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS0,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 70 + CALL LCMGPD(IPSYS0,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ NUN /)) + DO 60 I=1,ILONG + WORK1(I)=WORK1(I)+AGAR(I)*EVECT(I,JGR) + 60 CONTINUE + 70 CONTINUE + DO 80 I=1,LL4 + AIL=AIL+ADECT(I,IGR)*GRAD1(I,IGR) + BIL=BIL+ADECT(I,IGR)*WORK1(I) + 80 CONTINUE + 85 CONTINUE + EVAL=AIL/BIL + FKEFF2=REAL(1.0D0/EVAL) + IF(ABS(FKEFF-1.0/EVAL).GT.EPS1) CALL XABORT('GPTDFL: THE COMPUTE' + 1 //'D AND PROVIDED K-EFFECTIVES ARE INCONSISTENTS.') +*---- +* VALIDATION OF THE FIXED SOURCE TERM. +*---- + AIL=0.0D0 + BIL=0.0D0 + DO 95 IGR=1,NGRP + DO 90 I=1,LL4 + GAZ=ADECT(I,IGR)*SOUR(I,IGR) + DAZ=ADECT(I,IGR)**2 + AIL=AIL+GAZ + BIL=BIL+DAZ + 90 CONTINUE + 95 CONTINUE + IF(AIL.EQ.0.0) THEN + EASS(:NUN,:NGRP)=0.0 + FKEFF2=0.0 + DEALLOCATE(GRAD1,GAR1,WORK1) + RETURN + ENDIF + GAZ=ABS(AIL)/ABS(BIL)/REAL(LL4) + IF(IMPX.GE.1) THEN + WRITE(6,'(/28H GPTDFL: ORTHONORMALIZATION=,1P,E11.4)') GAZ + ENDIF + IF(GAZ.GT.EPS2) THEN + WRITE(HSMG,'(46HGPTDFL: THE SOURCE TERM IS NOT ORTHOGONAL TO T, + 1 27HHE ADJOINT REFERENCE FLUX (,1P,E11.4,2H).)') GAZ + CALL XABORT(HSMG) + ENDIF +*---- +* ORTHONORMALIZATION OF THE SOURCE TERM. +*---- + AIL=0.0D0 + BIL=0.0D0 + GAR1(:NUN,:NGRP)=0.0 + DO 110 IGR=1,NGRP + DO 100 JGR=1,NGRP + WRITE(TEXT12,'(1HB,2I3.3)') JGR,IGR + CALL LCMLEN(IPSYS0,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 100 + CALL LCMGPD(IPSYS0,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ NUN /)) + DO I=1,ILONG + GAR1(I,IGR)=GAR1(I,IGR)+AGAR(I)*EVECT(I,JGR) + ENDDO + 100 CONTINUE + DO I=1,LL4 + AIL=AIL+ADECT(I,IGR)*SOUR(I,IGR) + BIL=BIL+ADECT(I,IGR)*GAR1(I,IGR) + ENDDO + 110 CONTINUE + DO 125 IGR=1,NGRP + DO 120 I=1,LL4 + SOUR(I,IGR)=SOUR(I,IGR)-REAL(AIL/BIL)*GAR1(I,IGR) + 120 CONTINUE + 125 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION. +*---- + DEALLOCATE(GRAD1,GAR1,WORK1) +*---- +* LIVOLANT ACCELERATION. +*---- + IF(IMPX.GE.1) WRITE (6,600) NADI + IF(NSTART.EQ.0) THEN + CALL GPTLIV(IPTRK,IPSYS0,IPFLUP,.FALSE.,LL4,ITY,NUN,NGRP,ICL1, + 1 ICL2,IMPX,IMPH,TITR,NADI,MAXINR,MAXX0,EPS2,EPSINR,EVAL,EVECT, + 2 ADECT,EASS,SOUR,TKT,TKB,ZNORM,M) +*---- +* GMRES. +*---- + ELSE IF(NSTART.GT.0) THEN + CALL GPTMRA(IPTRK,IPSYS0,IPFLUP,.FALSE.,LL4,ITY,NUN,NGRP,ICL1, + 1 ICL2,IMPX,NADI,MAXINR,NSTART,MAXX0,EPS2,EPSINR,EVAL,EVECT,ADECT, + 2 EASS,SOUR,TKT,TKB,ZNORM,M) + ENDIF +*---- +* SOLUTION EDITION. +*---- + IF(IMPX.EQ.1) WRITE (6,610) M + IF(IMPX.GE.3) THEN + DO 130 IGR=1,NGRP + WRITE (6,620) IGR,(EASS(I,IGR),I=1,LL4) + 130 CONTINUE + ENDIF + RETURN +* + 600 FORMAT(1H1/50H GPTDFL: ITERATIVE PROCEDURE BASED ON PRECONDITION, + 1 17HED POWER METHOD (,I2,37H ADI ITERATIONS PER OUTER ITERATION)./ + 2 9X,39HDIRECT FIXED SOURCE EIGENVALUE PROBLEM.) + 610 FORMAT(/23H GPTDFL: CONVERGENCE IN,I4,12H ITERATIONS.) + 620 FORMAT(//52H GPTDFL: DIRECT FIXED SOURCE PROBLEM SOLUTION CORRES, + 1 20HPONDING TO THE GROUP,I4//(5X,1P,8E14.5)) + END diff --git a/Trivac/src/GPTFLU.f b/Trivac/src/GPTFLU.f new file mode 100755 index 0000000..03a8ce0 --- /dev/null +++ b/Trivac/src/GPTFLU.f @@ -0,0 +1,398 @@ +*DECK GPTFLU + SUBROUTINE GPTFLU(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Computes generalized adjoints. +* GPTFLU = Generalized Perturbation Theory FLUx calculation +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert, E. Varin and R. Chambon +* +*Parameters: input/ouput +* NENTRY number of linked lists or files used by the module +* HENTRY character*12 name of each linked list or file +* HENTRY(1): create or modification type(L_FLUX) (GPT solution) +* HENTRY(2): read-only type(L_SOURCE) => GPT fixed source +* HENTRY(3): read-only type(L_FLUX) => unperturbed solution +* HENTRY(4): read-only type(L_SYSTEM) => reference matrices +* HENTRY(5): read-only type(L_TRACK) => TRIVAC tracking. +* IENTRY =1 linked list; =2 xsm file; =3 sequential binary file; +* =4 sequential ascii file +* JENTRY =0 the linked list or file is created +* =1 the linked list or file is open for modifications; +* =2 the linked list or file is open in read-only mode +* KENTRY =file unit number; =linked list address otherwise. +* +*Comments: +* The GPTFLU: calling specifications are: +* FLUX\_GPT := GPTFLU: [ FLUX\_GPT ] GPT FLUX0 SYST TRACK :: (gptflu\_data) ; +* where +* FLUX\_GPT : name of the \emph{lcm} object (type L\_FLUX) containing the GPT +* solution. If FLUX\_GPT} appears on the RHS, the solution previously stored +* in FLUX\_GPT} is used to initialize the new iterative process; otherwise, +* a uniform unknown vector is used. +* GPT : name of the \emph{lcm} object (type L\_GPT) containing the +* fixed sources. +* FLUX0 : name of the \emph{lcm} object (type L\_FLUX) containing the +* unperturbed flux used to decontaminate the GPT solution. +* SYST : name of the \emph{lcm} object (type L\_SYSTEM) containing the +* unperturbed system matrices. +* TRACK : name of the \emph{lcm} object (type L\_TRACK) containing the +* \emph{tracking}. +* gptflu\_data}] : structure containing the data to module GPTFLU:} +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 + TYPE(C_PTR) KENTRY(NENTRY) +*---- +* LOCAL VARIABLES +*---- + INTEGER IPRINT,NITMA,I,J,IGR,ITYP,LENGT,SIGNA(3),ITY,NSTART + DOUBLE PRECISION DFLOTT + REAL FLOTT + CHARACTER TEXT12*12,CMODUL*12 + LOGICAL LFLU + INTEGER NEL,NUN,NGRP,LL4,ISRC + CHARACTER TITLE*72 +*---- +* STATE-VECTOR VARIABLES +*---- + INTEGER NSTATE + PARAMETER (NSTATE=40) + INTEGER FLUPRM(NSTATE),SYSPRM(NSTATE),TRKPRM(NSTATE), + 1 GPTPRM(NSTATE) +*---- +* Generalized Adjoint calculation +*---- + INTEGER SRCFRM,SRCTO,MAXOUT,ICL1,ICL2,NADI,IMPH,NLF,MAXINR + REAL FKEFF,FKEFF2,EPSOUT,EPSINR,EPSCON(5) + LOGICAL ADJ,REC,RECP + INTEGER, DIMENSION(:), ALLOCATABLE :: MAT,IDL + REAL, DIMENSION(:), ALLOCATABLE :: VOL + REAL, DIMENSION(:,:), ALLOCATABLE :: EVECT,ADECT,EASS,SOUR + TYPE(C_PTR) IPFLUP,IPFLU,IPGPT,IPTRK,IPSYS,JPFLU1,JPFLU2,JPGPT, + 1 KPGPT,JPFLUP,KPFLUP +*---- +* VALIDITY OF OBJECTS +*---- + IF(NENTRY.LT.4) CALL XABORT('GPTFLU: 5 OBJECTS EXPECTED.') + IPFLUP=C_NULL_PTR + IPFLU =C_NULL_PTR + IPGPT =C_NULL_PTR + IPTRK =C_NULL_PTR + IPSYS =C_NULL_PTR + RECP=(JENTRY(1).EQ.1) + LFLU=.FALSE. + DO 2 I=1,NENTRY + TEXT12=HENTRY(I) + IF((IENTRY(I).NE.1).AND.(IENTRY(I).NE.2))CALL XABORT('GPTFLU:' + 1 //' LINKED LIST OR XSM FILE EXPECTED ('//TEXT12//')') + IF((JENTRY(I).EQ.0).AND.(I.EQ.1)) THEN + TEXT12='L_FLUX' + READ(TEXT12,'(3A4)') (SIGNA(J),J=1,3) + CALL LCMPUT(KENTRY(I),'SIGNATURE',3,3,SIGNA) + ELSE + CALL LCMGET(KENTRY(I),'SIGNATURE',SIGNA) + WRITE(TEXT12,'(3A4)') (SIGNA(J),J=1,3) + IF(JENTRY(I).EQ.0) CALL XABORT('GPTFLU:'//TEXT12//' IS ' + 1 //'NOT ON RHS') + ENDIF + IF(TEXT12.EQ.'L_FLUX') THEN + IF(LFLU) THEN + IPFLU=KENTRY(I) + ELSE + IPFLUP=KENTRY(I) + LFLU=.TRUE. + ENDIF + ELSEIF(TEXT12.EQ.'L_SOURCE') THEN + IPGPT=KENTRY(I) + ELSEIF(TEXT12.EQ.'L_TRACK') THEN + IPTRK=KENTRY(I) + ELSEIF(TEXT12.EQ.'L_SYSTEM') THEN + IPSYS=KENTRY(I) + ELSE + CALL XABORT('GPTFLU: NOT GOOD TYPE OF OBJECT') + ENDIF + 2 CONTINUE + IF(.NOT.C_ASSOCIATED(IPGPT)) + 1 CALL XABORT('GPTFLU: MISSING GPT SOURCE OBJECT.') + IF(.NOT.C_ASSOCIATED(IPFLU)) + 1 CALL XABORT('GPTFLU: MISSING FLUX OBJECT.') + IF(.NOT.C_ASSOCIATED(IPSYS)) + 1 CALL XABORT('GPTFLU: MISSING SYSTEM OBJECT.') + IF(.NOT.C_ASSOCIATED(IPTRK)) + 1 CALL XABORT('GPTFLU: MISSING TRACK OBJECT.') +*---- +* VARIABLE INITIALISATION +*---- + CALL LCMGET(IPFLU,'STATE-VECTOR',FLUPRM) + NGRP = FLUPRM(1) + NUN = FLUPRM(2) + MAXINR = FLUPRM(11) + MAXOUT = FLUPRM(12) + CALL LCMGET(IPFLU,'EPS-CONVERGE',EPSCON) + EPSINR=EPSCON(1) + EPSOUT=EPSCON(2) + CALL LCMGET(IPTRK,'STATE-VECTOR',TRKPRM) + NEL = TRKPRM(1) + IF(NUN.NE.TRKPRM(2)) CALL XABORT('GPTFLU: TRACKING AND UNPERTURB' + + //'ED FLUX HAVE DIFFERENT NUMBER OF UNKNOWS') + CALL LCMLEN(IPTRK,'TITLE',LENGT,ITYP) + IF(LENGT.GT.0) THEN + CALL LCMGTC(IPTRK,'TITLE',72,TITLE) + ELSE + TITLE='*** NO TITLE PROVIDED ***' + ENDIF + CALL LCMGTC(IPTRK,'TRACK-TYPE',12,CMODUL) + IF(CMODUL.NE.'TRIVAC') CALL XABORT('GPTFLU: TRIVAC TRACKING EXPE' + + //'CTED.') + LL4 = TRKPRM(11) + NLF = TRKPRM(30) + CALL LCMGET(IPSYS,'STATE-VECTOR',SYSPRM) + IF( SYSPRM(1).NE.NGRP )CALL XABORT('GPTFLU: L_SYSTEM AND L_FLUX' + + //'FOR UNPERTURBED STATE HAVE DIFFERENT NUMBER OF GROUPS') + IF( SYSPRM(2).NE.LL4 )CALL XABORT('GPTFLU: UNPERTURBED SYSTEM A' + + //'ND TRACKING OBJECTS HAVE DIFFERENT NUMBER OF LINEAR ORDER') + ITY = SYSPRM(4) + IF(ITY.EQ.13) LL4=LL4*NLF/2 + CALL LCMGET(IPGPT,'STATE-VECTOR',GPTPRM) + IF( GPTPRM(1).NE.NGRP )CALL XABORT('GPTFLU: L_SOURCE AND L_FLUX ' + + //'HAVE DIFFERENT NUMBER OF GROUPS') + IF( GPTPRM(2).NE.NUN )CALL XABORT('GPTFLU: L_SOURCE AND L_FLUX H' + + //'AVE DIFFERENT NUMBER OF UNKNOWS') +*---- +* READ USER INPUT: +*---- + IPRINT=0 + IMPH=0 + IF(RECP) THEN +* RECOVER EXISTING OPTIONS. + CALL LCMGET(IPFLU,'STATE-VECTOR',FLUPRM) + ICL1=FLUPRM(8) + ICL2=FLUPRM(9) + MAXINR=FLUPRM(11) + MAXOUT=FLUPRM(12) + NADI=FLUPRM(13) + NSTART=FLUPRM(16) + CALL LCMGET(IPFLU,'EPS-CONVERGE',EPSCON) + EPSINR=EPSCON(1) + EPSOUT=EPSCON(2) + ELSE +* DEFAULT OPTIONS. + ICL1=3 + ICL2=3 + NADI=TRKPRM(33) + MAXINR=0 + MAXOUT=200 + NSTART=0 + EPSINR=1.0E-2 + EPSOUT=1.0E-4 + ENDIF + IF(GPTPRM(3).LE.GPTPRM(4)) THEN + ADJ=.FALSE. + ELSE + ADJ=.TRUE. + ENDIF + REC=.FALSE. + 505 CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + 506 IF(ITYP.NE.3) CALL XABORT('GPTFLU: CHARACTER DATA EXPECTED.') + IF(TEXT12.EQ.'EDIT') THEN + CALL REDGET(ITYP,IPRINT,FLOTT,TEXT12,DFLOTT) + IF(ITYP.NE.1) CALL XABORT('GPTFLU: *IPRINT* MUST BE INTEGER') + GO TO 505 + ELSEIF((TEXT12.EQ.'VAR1').OR.(TEXT12.EQ.'ACCE')) THEN + CALL REDGET(ITYP,ICL1,FLOTT,TEXT12,DFLOTT) + IF(ITYP.NE.1) CALL XABORT('GPTFLU: INTEGER DATA EXPECTED.') + CALL REDGET(ITYP,ICL2,FLOTT,TEXT12,DFLOTT) + IF(ITYP.NE.1) CALL XABORT('GPTFLU: INTEGER DATA EXPECTED.') + GO TO 505 + ELSEIF(TEXT12.EQ.'GMRES') THEN + CALL REDGET(ITYP,NSTART,FLOTT,TEXT12,DFLOTT) + IF(ITYP.NE.1) CALL XABORT('GPTFLU: INTEGER DATA EXPECTED.') + IF(NSTART.LT.0) CALL XABORT('GPTFLU: POSITIVE VALUE EXPECTED.') + GO TO 505 + ELSEIF(TEXT12.EQ.'IMPLICIT') THEN + ADJ=.TRUE. + GO TO 505 + ELSEIF(TEXT12.EQ.'EXPLICIT') THEN + ADJ=.FALSE. + GO TO 505 + ELSEIF(TEXT12.EQ.'RCVR-LAST') THEN + REC=.TRUE. + GO TO 505 + ELSEIF(TEXT12.EQ.'EXTE') THEN + 507 CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF(ITYP.EQ.1) THEN + MAXOUT=NITMA + ELSE IF(ITYP.EQ.2) THEN + EPSOUT=FLOTT + ELSE + GO TO 506 + ENDIF + GO TO 507 + ELSEIF(TEXT12.EQ.'ADI') THEN + CALL REDGET(ITYP,NADI,FLOTT,TEXT12,DFLOTT) + IF(ITYP.NE.1) CALL XABORT('GPTFLU: INTEGER DATA EXPECTED.') + GO TO 505 + ELSEIF(TEXT12.EQ.'THER') THEN + MAXINR = NGRP*2 + 508 CALL REDGET(ITYP,NITMA,FLOTT,TEXT12,DFLOTT) + IF(ITYP.EQ.1) THEN + MAXINR=NITMA + ELSEIF(ITYP.EQ.2) THEN + EPSINR=FLOTT + ELSE + GO TO 506 + ENDIF + GO TO 508 + ELSEIF(TEXT12.EQ.'HIST') THEN + CALL REDGET(ITYP,IMPH,FLOTT,TEXT12,DFLOTT) + IF(ITYP.NE.1) CALL XABORT('GPTFLU: INTEGER DATA EXPECTED.') + GO TO 505 + ENDIF + IF(TEXT12.EQ.'FROM-TO') THEN + CALL REDGET(ITYP,SRCFRM,FLOTT,TEXT12,DFLOTT) + IF((ITYP.EQ.3).AND.(TEXT12.EQ.'ALL')) THEN + SRCFRM=1 + IF(ADJ) THEN + SRCTO=GPTPRM(4) + ELSE + SRCTO=GPTPRM(3) + ENDIF + ELSE + IF(ITYP.NE.1) CALL XABORT('GPTFLU: INTEGER DATA EXPECTED.') + CALL REDGET(ITYP,SRCTO,FLOTT,TEXT12,DFLOTT) + IF(ITYP.NE.1) CALL XABORT('GPTFLU: INTEGER DATA EXPECTED.') + IF(ADJ) THEN + IF(SRCTO.GT.GPTPRM(4)) WRITE(6,*) 'THE NUMBER OF THE '// + 1 'SOURCE ',SRCTO,' IS GREATER THAN THE NUMBER OF CONST'// + 2 'RAINTS +1',GPTPRM(4) + ELSE + IF(SRCTO.GT.GPTPRM(3)) WRITE(6,*) 'THE NUMBER OF THE '// + 1 'SOURCE ',SRCTO,' IS GREATER THAN THE NUMBER OF VARIA'// + 2 'BLES',GPTPRM(3) + ENDIF + IF(SRCFRM.GT.SRCTO) CALL XABORT('GPTFLU:SCRFRM .GT. SCRTO') + ENDIF + ELSEIF(TEXT12.EQ.';') THEN + GO TO 1000 + ELSE + WRITE(6,*) 'Your keyword is : ',TEXT12 + CALL XABORT('GPTFLU:"FROM-TO" or ";" EXPECTED') + ENDIF +*---- +* RECOVER TRACKING INFORMATION +*---- + ALLOCATE(MAT(NEL),VOL(NEL),IDL(NEL)) + CALL LCMGET(IPTRK,'MATCOD',MAT) + CALL LCMGET(IPTRK,'VOLUME',VOL) + CALL LCMGET(IPTRK,'KEYFLX',IDL) +*---- +* RECOVER UNPERTURBED K-EFFECTIVE AND FLUXES. +*---- + ALLOCATE(EVECT(NUN,NGRP),ADECT(NUN,NGRP),EASS(NUN,NGRP)) + CALL LCMGET(IPFLU,'K-EFFECTIVE',FKEFF) + JPFLU1=LCMGID(IPFLU,'FLUX') + JPFLU2=LCMGID(IPFLU,'AFLUX') + DO 510 IGR=1,NGRP + CALL LCMGDL(JPFLU1,IGR,EVECT(1,IGR)) + CALL LCMGDL(JPFLU2,IGR,ADECT(1,IGR)) + 510 CONTINUE + ALLOCATE(SOUR(NUN,NGRP)) +*---- +* RECOVER FIXED SOURCE AND SET INITIAL VALUE OF GPFLUX +*---- + IF(ADJ) THEN + JPFLUP=LCMLID(IPFLUP,'ADFLUX',SRCTO) + ELSE + JPFLUP=LCMLID(IPFLUP,'DFLUX',SRCTO) + ENDIF + DO 590 ISRC=SRCFRM,SRCTO + IF(ADJ) THEN + JPGPT=LCMGID(IPGPT,'ASOUR') + ELSE + JPGPT=LCMGID(IPGPT,'DSOUR') + ENDIF + CALL LCMLEL(JPGPT,ISRC,LENGT,ITYP) + IF(LENGT.EQ.0) GO TO 590 + KPGPT=LCMGIL(JPGPT,ISRC) + DO 520 IGR=1,NGRP + CALL LCMGDL(KPGPT,IGR,SOUR(1,IGR)) + 520 CONTINUE + IF(REC.AND.(IMPH.EQ.0)) THEN + CALL LCMLEL(JPFLUP,ISRC,LENGT,ITYP) + IF(LENGT.EQ.0) THEN + WRITE(TEXT12,'(I4,3H-TH)') ISRC + CALL XABORT('GPTFLU: '//TEXT12//' GENERALIZED ADJOINT CANN' + 1 //'OT BE RECOVERED.') + ENDIF + KPFLUP=LCMGIL(JPFLUP,ISRC) + DO 530 IGR=1,NGRP + CALL LCMGDL(KPFLUP,IGR,EASS(1,IGR)) + 530 CONTINUE + ELSE + EASS(:NUN,:NGRP)=1.0 + ENDIF +*---- +* ADJOINT NEUTRON FLUX CALCULATION +*---- + IF(IPRINT.GE.1) WRITE(6,*) 'GPTFLU: ISRC=',ISRC + IF(ADJ) THEN + IF(IPRINT.GE.2) WRITE(6,*) 'implicit' + CALL GPTAFL(IPTRK,IPSYS,IPFLUP,LL4,ITY,NUN,NGRP,ICL1,ICL2, + 1 NSTART,IPRINT,IMPH,TITLE,EPSOUT,MAXINR,EPSINR,NADI,MAXOUT, + 2 FKEFF,EVECT,ADECT,FKEFF2,EASS,SOUR) + ELSE + IF(IPRINT.GE.2) WRITE(6,*) 'explicit' + CALL GPTDFL(IPTRK,IPSYS,IPFLUP,LL4,ITY,NUN,NGRP,ICL1,ICL2, + 1 NSTART,IPRINT,IMPH,TITLE,EPSOUT,MAXINR,EPSINR,NADI,MAXOUT, + 2 FKEFF,EVECT,ADECT,FKEFF2,EASS,SOUR) + ENDIF + CALL LCMPUT(IPFLUP,'K-EFFECTIVE',1,2,FKEFF2) + KPFLUP=LCMLIL(JPFLUP,ISRC,NGRP) + DO 550 IGR=1,NGRP + CALL FLDTRI(IPTRK,NEL,NUN,EASS(1,IGR),MAT,VOL,IDL) + CALL LCMPDL(KPFLUP,IGR,NUN,2,EASS(1,IGR)) + 550 CONTINUE + 590 CONTINUE + DEALLOCATE(EASS,ADECT,EVECT,SOUR,IDL,VOL,MAT) + GO TO 505 +*---- +* END +*---- + 1000 CALL LCMPTC(IPFLUP,'TRACK-TYPE',12,CMODUL) + IF(ADJ) THEN + FLUPRM(3)=1000 + ELSE + FLUPRM(3)=100 + ENDIF + FLUPRM(5)=SRCTO + FLUPRM(6)=1 + FLUPRM(16)=NSTART + IF(IPRINT.GT.0) WRITE(6,2020) (FLUPRM(I),I=1,5),FLUPRM(16) + CALL LCMPUT(IPFLUP,'STATE-VECTOR',NSTATE,1,FLUPRM) + RETURN +* + 2020 FORMAT(/8H OPTIONS/8H -------/ + 1 7H NGRP ,I8,28H (NUMBER OF ENERGY GROUPS)/ + 2 7H NUN ,I8,40H (NUMBER OF UNKNOWNS PER ENERGY GROUP)/ + 3 7H IADJ ,I8,30H (=100/1000: DIRECT/ADJOINT)/ + 4 7H NMOD ,I8,13H (NOT USED)/ + 5 7H SRCTO ,I8,48H (NUMBER OF FIXED-SOURCE EIGENVALUE EQUATIONS)/ + 6 7H NSTART,I8,46H (NUMBER OF GMRES ITERATIONS BEFORE RESTART)) + END diff --git a/Trivac/src/GPTGRA.f b/Trivac/src/GPTGRA.f new file mode 100755 index 0000000..f1867a3 --- /dev/null +++ b/Trivac/src/GPTGRA.f @@ -0,0 +1,298 @@ +*DECK GPTGRA + SUBROUTINE GPTGRA(IPTRK,IPSYS,IPFLUP,LADJ,LGAR1,LL4,ITY,NUN,NGRP, + 1 ICL1,ICL2,IMPX,NNADI,MAXINR,EPSINR,EVAL,EVECT,ADECT,EASS,SOUR, + 2 GAR1,ITER,TKT,TKB,ZNORM,GRAD) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute multigroup delta flux in a fixed source eigenvalue iteration. +* +*Copyright: +* Copyright (C) 2019 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK L_TRACK pointer to the tracking information. +* IPSYS L_SYSTEM pointer to system matrices. +* IPFLUP L_FLUX pointer to the gpt solution +* LADJ flag set to .TRUE. for adjoint solution acceleration. +* LGAR1 flag set to .TRUE. for recomputing GAR1. +* LL4 order of the system matrices. +* ITY type of solution (2: classical Trivac; 3: Thomas-Raviart). +* NUN number of unknowns in each energy group. +* NGRP number of energy groups. +* ICL1 number of free up-scattering iterations in one cycle of the +* inverse power method. +* ICL2 number of accelerated up-scattering iterations in one cycle. +* IMPX print parameter (set to 0 for no printing). +* NNADI number of inner ADI iterations per outer iteration. +* MAXINR maximum number of thermal iterations. +* EPSINR thermal iteration epsilon. +* EVAL eigenvalue. +* EVECT unknown vector for the non perturbed direct flux +* ADECT unknown vector for the non perturbed adjoint flux +* EASS solution of the fixed source eigenvalue problem +* SOUR fixed source +* GAR1 delta flux for this iteration before Hotelling deflation. +* +*Parameters: input/output +* ITER actual number of thermal iterations. +* TKT CPU time spent to compute the solution of linear systems. +* TKB CPU time spent to compute the bilinear products. +* ZNORM Hotelling deflation accuracy. +* GRAD delta flux for this iteration. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPSYS,IPFLUP + LOGICAL LADJ,LGAR1 + INTEGER LL4,ITY,NUN,NGRP,ICL1,ICL2,IMPX,NNADI,MAXINR,ITER + REAL EPSINR,EVECT(NUN,NGRP),ADECT(NUN,NGRP),EASS(NUN,NGRP), + 1 SOUR(NUN,NGRP),GAR1(NUN,NGRP),TKT,TKB,GRAD(NUN,NGRP) + DOUBLE PRECISION EVAL,ZNORM +*---- +* LOCAL VARIABLES +*---- + CHARACTER*12 TEXT12 + DOUBLE PRECISION DDELN1,DDELD1 + REAL, DIMENSION(:), ALLOCATABLE :: WORK1,WORK3 + REAL, DIMENSION(:), POINTER :: AGAR + TYPE(C_PTR) AGAR_PTR +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(WORK1(NUN)) +* + IF(LADJ) THEN + CALL KDRCPU(TK1) +* ADJOINT SOLUTION + IF(LGAR1) THEN + DO 55 IGR=1,NGRP + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,EASS(1,IGR), + 1 GAR1(1,IGR)) + DO 50 JGR=1,NGRP + IF(JGR.EQ.IGR) GO TO 30 + WRITE(TEXT12,'(1HA,2I3.3)') JGR,IGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 30 + IF(ITY.EQ.13) THEN + ALLOCATE(WORK3(LL4)) + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,EASS(1,JGR), + 1 WORK3(1)) + DO 10 I=1,LL4 + GAR1(I,IGR)=GAR1(I,IGR)-WORK3(I) + 10 CONTINUE + DEALLOCATE(WORK3) + ELSE + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ NUN /)) + DO 20 I=1,ILONG + GAR1(I,IGR)=GAR1(I,IGR)-AGAR(I)*EASS(I,JGR) + 20 CONTINUE + ENDIF + 30 WRITE(TEXT12,'(1HB,2I3.3)') JGR,IGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 50 + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ NUN /)) + DO 40 I=1,ILONG + GAR1(I,IGR)=GAR1(I,IGR)-REAL(EVAL)*AGAR(I)*EASS(I,JGR) + 40 CONTINUE + 50 CONTINUE + 55 CONTINUE + ENDIF +*---- +* DIRECTION EVALUATION. +*---- + DO 100 IGR=NGRP,1,-1 + DO 60 I=1,LL4 + GRAD(I,IGR)=-SOUR(I,IGR)-GAR1(I,IGR) + 60 CONTINUE + DO 90 JGR=NGRP,IGR+1,-1 + WRITE(TEXT12,'(1HA,2I3.3)') JGR,IGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 90 + IF(ITY.EQ.13) THEN + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD(1,JGR),WORK1(1)) + DO 70 I=1,LL4 + GRAD(I,IGR)=GRAD(I,IGR)+WORK1(I) + 70 CONTINUE + ELSE + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ NUN /)) + DO 80 I=1,ILONG + GRAD(I,IGR)=GRAD(I,IGR)+AGAR(I)*GRAD(I,JGR) + 80 CONTINUE + ENDIF + 90 CONTINUE +* + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL FLDADI(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD(1,IGR),NNADI) + 100 CONTINUE + CALL KDRCPU(TK2) + TKB=TKB+(TK2-TK1) +*---- +* PERFORM THERMAL (UP-SCATTERING) ITERATIONS +*---- + ITER=1 + IF(MAXINR.GT.1) THEN + CALL FLDTHR(IPTRK,IPSYS,IPFLUP,.TRUE.,LL4,ITY,NUN,NGRP, + 1 ICL1,ICL2,IMPX,NNADI,0,MAXINR,EPSINR,ITER,TKT,TKB,GRAD) + ENDIF +*---- +* HOTELLING DEFLATION. +*---- + CALL KDRCPU(TK1) + DDELN1=0.0D0 + DDELD1=0.0D0 + DO 135 IGR=1,NGRP + WORK1(:LL4)=0.0 + DO 120 JGR=1,NGRP + WRITE(TEXT12,'(1HB,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 120 + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ NUN /)) + DO 110 I=1,ILONG + WORK1(I)=WORK1(I)+AGAR(I)*EVECT(I,JGR) + 110 CONTINUE + 120 CONTINUE + DO 130 I=1,LL4 + DDELN1=DDELN1+WORK1(I)*EASS(I,IGR) + DDELD1=DDELD1+WORK1(I)*ADECT(I,IGR) + 130 CONTINUE + 135 CONTINUE + ZNORM=DDELN1/DDELD1 + DO 145 IGR=1,NGRP + DO 140 I=1,LL4 + GRAD(I,IGR)=GRAD(I,IGR)-REAL(ZNORM)*ADECT(I,IGR) + 140 CONTINUE + 145 CONTINUE + CALL KDRCPU(TK2) + TKB=TKB+(TK2-TK1) + ELSE + CALL KDRCPU(TK1) +* DIRECT SOLUTION + IF(LGAR1) THEN + DO 195 IGR=1,NGRP + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,EASS(1,IGR), + 1 GAR1(1,IGR)) + DO 190 JGR=1,NGRP + IF(JGR.EQ.IGR) GO TO 170 + WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 170 + IF(ITY.EQ.13) THEN + ALLOCATE(WORK3(LL4)) + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,EASS(1,JGR), + 1 WORK3(1)) + DO 150 I=1,LL4 + GAR1(I,IGR)=GAR1(I,IGR)-WORK3(I) + 150 CONTINUE + DEALLOCATE(WORK3) + ELSE + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ NUN /)) + DO 160 I=1,ILONG + GAR1(I,IGR)=GAR1(I,IGR)-AGAR(I)*EASS(I,JGR) + 160 CONTINUE + ENDIF + 170 WRITE(TEXT12,'(1HB,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 190 + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ NUN /)) + DO 180 I=1,ILONG + GAR1(I,IGR)=GAR1(I,IGR)-REAL(EVAL)*AGAR(I)*EASS(I,JGR) + 180 CONTINUE + 190 CONTINUE + 195 CONTINUE + ENDIF +*---- +* DIRECTION EVALUATION. +*---- + DO 240 IGR=1,NGRP + DO 200 I=1,LL4 + GRAD(I,IGR)=-SOUR(I,IGR)-GAR1(I,IGR) + 200 CONTINUE + DO 230 JGR=1,IGR-1 + WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 230 + IF(ITY.EQ.13) THEN + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD(1,JGR),WORK1(1)) + DO 210 I=1,LL4 + GRAD(I,IGR)=GRAD(I,IGR)+WORK1(I) + 210 CONTINUE + ELSE + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ NUN /)) + DO 220 I=1,ILONG + GRAD(I,IGR)=GRAD(I,IGR)+AGAR(I)*GRAD(I,JGR) + 220 CONTINUE + ENDIF + 230 CONTINUE +* + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL FLDADI(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD(1,IGR),NNADI) + 240 CONTINUE + CALL KDRCPU(TK2) + TKB=TKB+(TK2-TK1) +*---- +* PERFORM THERMAL (UP-SCATTERING) ITERATIONS +*---- + ITER=1 + IF(MAXINR.GT.1) THEN + CALL FLDTHR(IPTRK,IPSYS,IPFLUP,.FALSE.,LL4,ITY,NUN,NGRP, + 1 ICL1,ICL2,IMPX,NNADI,0,MAXINR,EPSINR,ITER,TKT,TKB,GRAD) + ENDIF +*---- +* HOTELLING DEFLATION. +*---- + CALL KDRCPU(TK1) + DDELN1=0.0D0 + DDELD1=0.0D0 + DO 275 IGR=1,NGRP + WORK1(:LL4)=0.0 + DO 260 JGR=1,NGRP + WRITE(TEXT12,'(1HB,2I3.3)') JGR,IGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 260 + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ NUN /)) + DO 250 I=1,ILONG + WORK1(I)=WORK1(I)+AGAR(I)*ADECT(I,JGR) + 250 CONTINUE + 260 CONTINUE + DO 270 I=1,LL4 + DDELN1=DDELN1+WORK1(I)*EASS(I,IGR) + DDELD1=DDELD1+WORK1(I)*EVECT(I,IGR) + 270 CONTINUE + 275 CONTINUE + ZNORM=DDELN1/DDELD1 + DO 285 IGR=1,NGRP + DO 280 I=1,LL4 + GRAD(I,IGR)=GRAD(I,IGR)-REAL(ZNORM)*EVECT(I,IGR) + 280 CONTINUE + 285 CONTINUE + CALL KDRCPU(TK2) + TKB=TKB+(TK2-TK1) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(WORK1) + RETURN + END diff --git a/Trivac/src/GPTLIV.f b/Trivac/src/GPTLIV.f new file mode 100755 index 0000000..934277a --- /dev/null +++ b/Trivac/src/GPTLIV.f @@ -0,0 +1,285 @@ +*DECK GPTLIV + SUBROUTINE GPTLIV(IPTRK,IPSYS,IPFLUP,LADJ,LL4,ITY,NUN,NGRP,ICL1, + 1 ICL2,IMPX,IMPH,TITR,NADI,MAXINR,MAXX0,EPS2,EPSINR,EVAL,EVECT, + 2 ADECT,EASS,SOUR,TKT,TKB,ZNORM,M) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solution of a multigroup fixed source eigenvalue problem for the +* calculation of a gpt solution in Trivac. Use the preconditioned power +* method with two parameter SVAT acceleration. +* +*Copyright: +* Copyright (C) 2019 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK L_TRACK pointer to the tracking information. +* IPSYS L_SYSTEM pointer to system matrices. +* IPFLUP L_FLUX pointer to the gpt solution +* LADJ flag set to .TRUE. for adjoint solution acceleration. +* LL4 order of the system matrices. +* ITY type of solution (2: classical Trivac; 3: Thomas-Raviart). +* NUN number of unknowns in each energy group. +* NGRP number of energy groups. +* ICL1 number of free up-scattering iterations in one cycle of the +* inverse power method. +* ICL2 number of accelerated up-scattering iterations in one cycle. +* IMPX print parameter. =0: no print; =1: minimum printing; +* =2: iteration history is printed; =3: solution is printed. +* IMPH =0: no action is taken +* =1: the flux is compared to a reference flux stored on lcm +* =2: the convergence histogram is printed +* =3: the convergence histogram is printed with axis and +* titles. the plotting file is completed +* =4: the convergence histogram is printed with axis, acce- +* leration factors and titles. the plotting file is +* completed. +* TITR character*72 title +* NADI initial number of inner ADI iterations per outer iteration. +* MAXINR maximum number of thermal iterations. +* EPSINR thermal iteration epsilon. +* EVAL eigenvalue. +* EVECT unknown vector for the non perturbed direct flux +* ADECT unknown vector for the non perturbed adjoint flux +* EASS solution of the fixed source eigenvalue problem +* SOUR fixed source +* +*Parameters: input/output +* TKT CPU time spent to compute the solution of linear systems. +* TKB CPU time spent to compute the bilinear products. +* ZNORM Hotelling deflation accuracy. +* M number of iterations. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPSYS,IPFLUP + CHARACTER TITR*72 + LOGICAL LADJ + INTEGER LL4,ITY,NUN,NGRP,ICL1,ICL2,IMPX,IMPH,NNADI,MAXINR,MAXX0,M + REAL EPS2,EPSINR,EVECT(NUN,NGRP),ADECT(NUN,NGRP),EASS(NUN,NGRP), + 1 SOUR(NUN,NGRP),TKT,TKB + DOUBLE PRECISION EVAL,ZNORM +*---- +* LOCAL VARIABLES +*---- + CHARACTER*12 TEXT12 + LOGICAL LGAR1,LOGTES,LMPH + DOUBLE PRECISION D2F(2,3),ALP,BET + REAL ERR(250),ALPH(250),BETA(250) + REAL, DIMENSION(:,:), ALLOCATABLE :: GRAD1,GRAD2,GAR1,GAR2,GAR3 + REAL, DIMENSION(:), ALLOCATABLE :: WORK1,WORK2 + REAL, DIMENSION(:), POINTER :: AGAR + TYPE(C_PTR) AGAR_PTR +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(GRAD1(NUN,NGRP),GRAD2(NUN,NGRP),GAR1(NUN,NGRP), + 1 GAR2(NUN,NGRP),GAR3(NUN,NGRP),WORK1(NUN),WORK2(NUN)) +* + TEST=0.0 + ISTART=1 + NNADI=NADI + IF(IMPX.GE.2) WRITE(6,500) + M=0 + 100 M=M+1 +* + LGAR1=(MOD(M-ISTART+1,ICL1+ICL2).EQ.1).OR.(M.EQ.1) + CALL GPTGRA(IPTRK,IPSYS,IPFLUP,LADJ,LGAR1,LL4,ITY,NUN,NGRP,ICL1, + 1 ICL2,IMPX,NNADI,MAXINR,EPSINR,EVAL,EVECT,ADECT,EASS,SOUR,GAR1, + 2 ITER,TKT,TKB,ZNORM,GRAD1) +*---- +* EVALUATION OF THE DISPLACEMENT AND OF THE TWO ACCELERATION PARAMETERS +* ALP AND BET. +*---- + ALP=1.0D0 + BET=0.0D0 + DO 240 I=1,2 + DO 230 J=1,3 + D2F(I,J)=0.0D0 + 230 CONTINUE + 240 CONTINUE + DO 285 IGR=1,NGRP + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD1(1,IGR),GAR2(1,IGR)) + DO 280 JGR=1,NGRP + IF(JGR.EQ.IGR) GO TO 260 + IF(LADJ) THEN + WRITE(TEXT12,'(1HA,2I3.3)') JGR,IGR + ELSE + WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR + ENDIF + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 260 + IF(ITY.EQ.13) THEN + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD1(1,JGR),WORK1(1)) + DO 245 I=1,LL4 + GAR2(I,IGR)=GAR2(I,IGR)-WORK1(I) + 245 CONTINUE + ELSE + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ NUN /)) + DO 250 I=1,ILONG + GAR2(I,IGR)=GAR2(I,IGR)-AGAR(I)*GRAD1(I,JGR) + 250 CONTINUE + ENDIF + 260 IF(LADJ) THEN + WRITE(TEXT12,'(1HB,2I3.3)') JGR,IGR + ELSE + WRITE(TEXT12,'(1HB,2I3.3)') IGR,JGR + ENDIF + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 280 + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ NUN /)) + DO 270 I=1,ILONG + GAR2(I,IGR)=GAR2(I,IGR)-REAL(EVAL)*AGAR(I)*GRAD1(I,JGR) + 270 CONTINUE + 280 CONTINUE + 285 CONTINUE + IF(1+MOD(M-ISTART,ICL1+ICL2).GT.ICL1) THEN + DO 295 IGR=1,NGRP + DO 290 I=1,LL4 + D2F(1,1)=D2F(1,1)+GAR2(I,IGR)**2 + D2F(1,2)=D2F(1,2)+GAR2(I,IGR)*GAR3(I,IGR) + D2F(2,2)=D2F(2,2)+GAR3(I,IGR)**2 + D2F(1,3)=D2F(1,3)-(GAR1(I,IGR)+SOUR(I,IGR))*GAR2(I,IGR) + D2F(2,3)=D2F(2,3)-(GAR1(I,IGR)+SOUR(I,IGR))*GAR3(I,IGR) + 290 CONTINUE + 295 CONTINUE + D2F(2,1)=D2F(1,2) +* SOLUTION OF A LINEAR SYSTEM. + CALL ALSBD(2,1,D2F,IER,2) + IF(IER.NE.0) CALL XABORT('GPTLIV: SINGULAR MATRIX.') + ALP=D2F(1,3) + BET=D2F(2,3)/ALP + IF((ALP.LT.1.0D0).AND.(ALP.GT.0.0D0)) THEN + ALP=1.0D0 + BET=0.0D0 + ELSE IF(ALP.LE.0.0D0) THEN + ISTART=M+1 + ALP=1.0D0 + BET=0.0D0 + ENDIF + DO 305 IGR=1,NGRP + DO 300 I=1,LL4 + GRAD1(I,IGR)=REAL(ALP)*(GRAD1(I,IGR)+REAL(BET)*GRAD2(I,IGR)) + GAR2(I,IGR)=REAL(ALP)*(GAR2(I,IGR)+REAL(BET)*GAR3(I,IGR)) + 300 CONTINUE + 305 CONTINUE + ENDIF +* + LOGTES=(M.LT.ICL1).OR.(MOD(M-ISTART,ICL1+ICL2).EQ.ICL1-1) + IF(LOGTES) THEN + DELT=0.0 + DO 350 IGR=1,NGRP + WORK1(:LL4)=0.0 + WORK2(:LL4)=0.0 + DO 320 JGR=1,NGRP + IF(LADJ) THEN + WRITE(TEXT12,'(1HB,2I3.3)') JGR,IGR + ELSE + WRITE(TEXT12,'(1HB,2I3.3)') IGR,JGR + ENDIF + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 320 + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ NUN /)) + DO 310 I=1,ILONG + WORK1(I)=WORK1(I)+AGAR(I)*EASS(I,JGR) + WORK2(I)=WORK2(I)+AGAR(I)*GRAD1(I,JGR) + 310 CONTINUE + 320 CONTINUE + DELN=0.0 + DELD=0.0 + DO 340 I=1,LL4 + EASS(I,IGR)=EASS(I,IGR)+GRAD1(I,IGR) + GAR1(I,IGR)=GAR1(I,IGR)+GAR2(I,IGR) + GRAD2(I,IGR)=GRAD1(I,IGR) + GAR3(I,IGR)=GAR2(I,IGR) + DELN=MAX(DELN,ABS(WORK2(I))) + DELD=MAX(DELD,ABS(WORK1(I))) + 340 CONTINUE + IF(DELD.NE.0.0) DELT=MAX(DELT,DELN/DELD) + 350 CONTINUE + IF(IMPX.GE.2) WRITE(6,510) M,ALP,BET,ZNORM,DELT,ITER +* COMPUTE THE CONVERGENCE HISTOGRAM. + IF(IMPH.GE.1) THEN + LMPH=IMPH.GE.1 + CALL FLDXCO(IPFLUP,LL4,NUN,EASS(1,NGRP),LMPH,ERR(M)) + ALPH(M)=REAL(ALP) + BETA(M)=REAL(BET) + ENDIF + IF(DELT.LT.EPS2) GO TO 370 + ELSE + DO 365 IGR=1,NGRP + DO 360 I=1,LL4 + EASS(I,IGR)=EASS(I,IGR)+GRAD1(I,IGR) + GAR1(I,IGR)=GAR1(I,IGR)+GAR2(I,IGR) + GRAD2(I,IGR)=GRAD1(I,IGR) + GAR3(I,IGR)=GAR2(I,IGR) + 360 CONTINUE + 365 CONTINUE + IF(IMPX.GE.2) WRITE(6,510) M,ALP,BET,ZNORM,0.0,ITER +* COMPUTE THE CONVERGENCE HISTOGRAM. + IF(IMPH.GE.1) THEN + LMPH=IMPH.GE.1 + CALL FLDXCO(IPFLUP,LL4,NUN,EASS(1,NGRP),LMPH,ERR(M)) + ALPH(M)=REAL(ALP) + BETA(M)=REAL(BET) + ENDIF + ENDIF + IF(M.EQ.1) TEST=DELT + IF((M.GT.20).AND.(DELT.GT.TEST)) CALL XABORT('GPTLIV: CONVERGENC' + 1 //'E FAILURE.') + IF(M.GE.MAXX0) THEN + WRITE(6,520) + GO TO 370 + ENDIF + IF(MOD(M,36).EQ.0) THEN + ISTART=M+1 + NNADI=NNADI+1 + IF(IMPX.NE.0) WRITE(6,530) NNADI + ENDIF + GO TO 100 +*---- +* SAVE THE CONVERGENCE HISTOGRAM ON LCM. +*---- + 370 IF(IMPH.GE.2) THEN + IGRAPH=0 + 390 IGRAPH=IGRAPH+1 + WRITE(TEXT12,'(5HHISTO,I3)') IGRAPH + CALL LCMLEN (IPFLUP,TEXT12,ILENG,ITYLCM) + IF(ILENG.EQ.0) THEN + CALL LCMSIX (IPFLUP,TEXT12,1) + CALL LCMPTC (IPFLUP,'HTITLE',72,TITR) + CALL LCMPUT (IPFLUP,'ALPHA',M,2,ALPH) + CALL LCMPUT (IPFLUP,'BETA',M,2,BETA) + CALL LCMPUT (IPFLUP,'ERROR',M,2,ERR) + CALL LCMPUT (IPFLUP,'IMPH',1,1,IMPH) + CALL LCMSIX (IPFLUP,' ',2) + ELSE + GO TO 390 + ENDIF + ENDIF + DEALLOCATE(WORK2,WORK1,GAR3,GAR2,GAR1,GRAD2,GRAD1) + RETURN +* + 500 FORMAT (/29X,15HORTHONORMALIZA-/11X,5HALPHA,3X,4HBETA,6X, + 1 11HTION FACTOR,6X,8HACCURACY,5X,7HTHERMAL) + 510 FORMAT (1X,I3,4X,2F8.3,1P,E14.2,6X,E10.2,5X,1H(,I4,1H)) + 520 FORMAT(/53H GPTLIV: ***WARNING*** THE MAXIMUM NUMBER OF OUTER IT, + 1 20HERATIONS IS REACHED.) + 530 FORMAT(/53H GPTLIV: INCREASING THE NUMBER OF INNER ITERATIONS TO, + 1 I3,36H ADI ITERATIONS PER OUTER ITERATION./) + END diff --git a/Trivac/src/GPTMRA.f b/Trivac/src/GPTMRA.f new file mode 100755 index 0000000..e2dda52 --- /dev/null +++ b/Trivac/src/GPTMRA.f @@ -0,0 +1,222 @@ +*DECK GPTMRA + SUBROUTINE GPTMRA(IPTRK,IPSYS,IPFLUP,LADJ,LL4,ITY,NUN,NGRP,ICL1, + 1 ICL2,IMPX,NADI,MAXINR,NSTART,MAXX0,EPS2,EPSINR,EVAL,EVECT,ADECT, + 2 EASS,SOUR,TKT,TKB,ZNORM,ITER) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solution of a multigroup fixed source eigenvalue problem for the +* calculation of a gpt solution in Trivac. Use the preconditioned power +* method with GMRES(m) acceleration. +* +*Copyright: +* Copyright (C) 2019 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK L_TRACK pointer to the tracking information. +* IPSYS L_SYSTEM pointer to system matrices. +* IPFLUP L_FLUX pointer to the gpt solution +* LADJ flag set to .TRUE. for adjoint solution acceleration. +* LL4 order of the system matrices. +* ITY type of solution (2: classical Trivac; 3: Thomas-Raviart). +* NUN number of unknowns in each energy group. +* NGRP number of energy groups. +* ICL1 number of free up-scattering iterations in one cycle of the +* inverse power method. +* ICL2 number of accelerated up-scattering iterations in one cycle. +* IMPX print parameter (set to 0 for no printing). +* NADI initial number of inner ADI iterations per outer iteration. +* MAXINR maximum number of thermal iterations. +* NSTART restarts the GMRES method every NSTART iterations. +* MAXX0 maximum number of outer iterations +* EPS2 outer iteration convergence criterion +* EPSINR thermal iteration convergence criterion +* EVAL eigenvalue. +* EVECT unknown vector for the non perturbed direct flux +* ADECT unknown vector for the non perturbed adjoint flux +* SOUR fixed source +* +*Parameters: input/output +* EASS solution of the fixed source eigenvalue problem +* TKT CPU time spent to compute the solution of linear systems. +* TKB CPU time spent to compute the bilinear products. +* ZNORM Hotelling deflation accuracy. +* ITER number of iterations. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPSYS,IPFLUP + LOGICAL LADJ + INTEGER LL4,ITY,NUN,NGRP,ICL1,ICL2,IMPX,NADI,MAXINR,NSTART,MAXX0, + 1 ITER + REAL EPS2,EPSINR,EVECT(NUN,NGRP),ADECT(NUN,NGRP),EASS(NUN*NGRP), + 1 SOUR(NUN,NGRP),TKT,TKB,SDOT + DOUBLE PRECISION EVAL,ZNORM +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IUNOUT=6) +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: RR,QQ,VV,GAR1 + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: V,H + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: G,C,S,X +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(V(NUN*NGRP,NSTART+1),G(NSTART+1),H(NSTART+1,NSTART+1), + 1 C(NSTART+1),S(NSTART+1),X(NUN*NGRP),GAR1(NUN*NGRP)) +*---- +* GLOBAL GMRES ITERATION. +*---- + ALLOCATE(RR(NUN*NGRP),QQ(NUN*NGRP),VV(NUN*NGRP)) + + EPS1=EPS2*SQRT(SDOT(NUN*NGRP,SOUR,1,SOUR,1)) + RHO=1.0E10 + ITER=0 + NITER=1 + NNADI=NADI + DO WHILE((RHO.GT.EPS1).AND.(ITER.LT.MAXX0)) + CALL GPTGRA(IPTRK,IPSYS,IPFLUP,LADJ,.TRUE.,LL4,ITY,NUN,NGRP, + 1 ICL1,ICL2,IMPX,NNADI,MAXINR,EPSINR,EVAL,EVECT,ADECT,EASS(1), + 2 SOUR(1,1),GAR1,JTER0,TKT,TKB,ZNORM,RR) + NITER=NITER+1 + DO I=1,NUN*NGRP + X(I)=RR(I) + ENDDO + RHO=SQRT(DDOT(NUN*NGRP,X(1),1,X(1),1)) +*---- +* TEST FOR TERMINATION ON ENTRY +*---- + IF(RHO.LT.EPS1) THEN + DEALLOCATE(VV,QQ,RR) + GO TO 100 + ENDIF +* + V(:NUN*NGRP,:NSTART+1)=0.0D0 + G(:NSTART+1)=0.0D0 + H(:NSTART+1,:NSTART+1)=0.0D0 + C(:NSTART+1)=0.0D0 + S(:NSTART+1)=0.0D0 + G(1)=RHO + DO I=1,NUN*NGRP + V(I,1)=X(I)/RHO + ENDDO +*---- +* GMRES(1) ITERATION +*---- + K=0 + DO WHILE((RHO.GT.EPS1).AND.(K.LT.NSTART).AND.(ITER.LT.MAXX0)) + K=K+1 + ITER=ITER+1 + IF(IMPX.GT.1) WRITE(IUNOUT,300) ITER,RHO,JTER0 + DO I=1,NUN*NGRP + VV(I)=REAL(V(I,K)) + QQ(I)=0.0 + ENDDO + CALL GPTGRA(IPTRK,IPSYS,IPFLUP,LADJ,.TRUE.,LL4,ITY,NUN,NGRP, + 1 ICL1,ICL2,IMPX,NNADI,MAXINR,EPSINR,EVAL,EVECT,ADECT,VV(1), + 2 QQ(1),GAR1,JTER,TKT,TKB,ZNORM,RR) + IF(JTER.NE.JTER0) CALL XABORT('GPTMRA: INCONSISTENT PRECONDIT' + 1 //'IONING IN GMRES.') + NITER=NITER+1 + DO I=1,NUN*NGRP + V(I,K+1)=-RR(I) + ENDDO +*---- +* MODIFIED GRAM-SCHMIDT +*---- + DO J=1,K + HR=DDOT(NUN*NGRP,V(1,J),1,V(1,K+1),1) + H(J,K)=HR + DO I=1,NUN*NGRP + V(I,K+1)=V(I,K+1)-HR*V(I,J) + ENDDO + ENDDO + H(K+1,K)=SQRT(DDOT(NUN*NGRP,V(1,K+1),1,V(1,K+1),1)) +*---- +* REORTHOGONALIZE +*---- + DO J=1,K + HR=DDOT(NUN*NGRP,V(1,J),1,V(1,K+1),1) + H(J,K)=H(J,K)+HR + DO I=1,NUN*NGRP + V(I,K+1)=V(I,K+1)-HR*V(I,J) + ENDDO + ENDDO + H(K+1,K)=SQRT(DDOT(NUN*NGRP,V(1,K+1),1,V(1,K+1),1)) +*---- +* WATCH OUT FOR HAPPY BREAKDOWN +*---- + IF(H(K+1,K).NE.0.0) THEN + DO I=1,NUN*NGRP + V(I,K+1)=V(I,K+1)/H(K+1,K) + ENDDO + ENDIF +*---- +* FORM AND STORE THE INFORMATION FOR THE NEW GIVENS ROTATION +*---- + DO I=1,K-1 + W1=C(I)*H(I,K)-S(I)*H(I+1,K) + W2=S(I)*H(I,K)+C(I)*H(I+1,K) + H(I,K)=W1 + H(I+1,K)=W2 + ENDDO + ZNU=SQRT(H(K,K)**2+H(K+1,K)**2) + IF(ZNU.NE.0.0) THEN + C(K)=H(K,K)/ZNU + S(K)=-H(K+1,K)/ZNU + H(K,K)=C(K)*H(K,K)-S(K)*H(K+1,K) + H(K+1,K)=0.0D0 + W1=C(K)*G(K)-S(K)*G(K+1) + W2=S(K)*G(K)+C(K)*G(K+1) + G(K)=W1 + G(K+1)=W2 + ENDIF +*---- +* UPDATE THE RESIDUAL NORM +*---- + RHO=ABS(G(K+1)) + ENDDO +*---- +* AT THIS POINT EITHER K > NSTART OR RHO < EPS1. +* IT'S TIME TO COMPUTE X AND CYCLE. +*---- + DO J=1,K + H(J,K+1)=G(J) + ENDDO + CALL ALSBD(K,1,H,IER,NSTART+1) + IF(IER.NE.0) CALL XABORT('GPTMRA: SINGULAR MATRIX.') + DO I=1,NUN*NGRP + EASS(I)=EASS(I)+REAL(DDOT(K,V(I,1),NUN*NGRP,H(1,K+1),1)) + ENDDO + IF(K.EQ.NSTART) THEN + NNADI=NNADI+1 + IF(IMPX.NE.0) WRITE (6,310) NNADI + ENDIF + ENDDO + DEALLOCATE(VV,QQ,RR) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + 100 DEALLOCATE(GAR1,X,S,C,H,G,V) + RETURN +* + 300 FORMAT(24H GPTMRA: OUTER ITERATION,I4,10H L2 NORM=,1P,E11.4, + 1 28H (NB. OF THERMAL ITERATIONS=,I4,1H)) + 310 FORMAT(/53H GPTMRA: INCREASING THE NUMBER OF INNER ITERATIONS TO, + 1 I3,36H ADI ITERATIONS PER OUTER ITERATION./) + END diff --git a/Trivac/src/KINB01.f b/Trivac/src/KINB01.f new file mode 100755 index 0000000..efb6028 --- /dev/null +++ b/Trivac/src/KINB01.f @@ -0,0 +1,104 @@ +*DECK KINB01 + SUBROUTINE KINB01(MAXKN,SGD,CYLIND,NREG,LL4,NBMIX,XX,DD,MAT,KN, + 1 VOL,LC,R,RS,F2,F3) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Multiplication of a matrix by a vector in primal finite element +* diffusion approximation (Cartesian geometry). Special version for +* Bivac. +* +*Copyright: +* Copyright (C) 2010 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXKN dimension of array KN. +* SGD mixture-ordered cross sections. +* CYLIND cylinderization flag (=.true. for cylindrical geometry). +* NREG number of elements in Bivac. +* LL4 order of matrix SYS. +* NBMIX number of macro-mixtures. +* XX X-directed mesh spacings. +* DD value used with a cylindrical geometry. +* MAT mixture index per region. +* KN element-ordered unknown list. +* VOL volume of regions. +* LC number of polynomials in a complete 1-D basis. +* R Cartesian mass matrix. +* RS cylindrical mass matrix. +* F2 vector to multiply. +* +*Parameters: output +* F3 result of the multiplication. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MAXKN,NREG,LL4,NBMIX,MAT(NREG),KN(MAXKN),LC + REAL SGD(NBMIX),XX(NREG),DD(NREG),VOL(NREG),R(LC,LC),RS(LC,LC), + 1 F2(LL4),F3(LL4) + LOGICAL CYLIND +*---- +* LOCAL VARIABLES +*---- + INTEGER IJ1(25),IJ2(25) + REAL R2DP(25,25),R2DC(25,25) +*---- +* COMPUTE VECTORS IJ1 AND IJ2. +*---- + LL=LC*LC + DO 10 I=1,LL + IJ1(I)=1+MOD(I-1,LC) + IJ2(I)=1+(I-IJ1(I))/LC + 10 CONTINUE +*---- +* COMPUTE THE CARTESIAN 2-D MASS MATRICES FROM TENSORIAL PRODUCTS OF +* 1-D MATRICES. +*---- + DO 25 I=1,LL + I1=IJ1(I) + I2=IJ2(I) + DO 20 J=1,LL + J1=IJ1(J) + J2=IJ2(J) + R2DP(I,J)=R(I1,J1)*R(I2,J2) + R2DC(I,J)=RS(I1,J1)*R(I2,J2) + 20 CONTINUE + 25 CONTINUE +*---- +* MULTIPLICATION. +*---- + NUM1=0 + DO 60 K=1,NREG + L=MAT(K) + IF(L.EQ.0) GO TO 60 + IF(VOL(K).EQ.0.0) GO TO 50 + DX=XX(K) + DO 40 I=1,LL + IND1=KN(NUM1+I) + IF(IND1.EQ.0) GO TO 40 + DO 30 J=1,LL + IND2=KN(NUM1+J) + IF(IND2.EQ.0) GO TO 30 + IF(CYLIND) THEN + RR=R2DP(I,J)+R2DC(I,J)*DX/DD(K) + ELSE + RR=R2DP(I,J) + ENDIF + IF(RR.EQ.0.0) GO TO 30 + F3(IND1)=F3(IND1)+RR*SGD(L)*VOL(K)*F2(IND2) + 30 CONTINUE + 40 CONTINUE + 50 NUM1=NUM1+LL + 60 CONTINUE + RETURN + END diff --git a/Trivac/src/KINB02.f b/Trivac/src/KINB02.f new file mode 100755 index 0000000..b9eccc4 --- /dev/null +++ b/Trivac/src/KINB02.f @@ -0,0 +1,58 @@ +*DECK KINB02 + SUBROUTINE KINB02(SGD,IELEM,NREG,LL4,NBMIX,MAT,KN,VOL,F2,F3) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Multiplication of a matrix by a vector in mixed-dual finite element +* diffusion approximation (Cartesian geometry). Special version for +* Bivac. +* +*Copyright: +* Copyright (C) 2010 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* SGD mixture-ordered cross sections. +* IELEM degree of the Lagrangian finite elements: =1 (linear); +* =2 (parabolic); =3 (cubic); =4 (quartic). +* NREG number of elements in Bivac. +* LL4 number of unknowns per group in Bivac. +* NBMIX number of macro-mixtures. +* MAT mixture index per region. +* KN element-ordered unknown list. +* VOL volume of regions. +* F2 vector to multiply. +* +*Parameters: output +* F3 result of the multiplication. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IELEM,NREG,LL4,NBMIX,MAT(NREG),KN(5*NREG) + REAL SGD(NBMIX),VOL(NREG),F2(LL4),F3(LL4) +* + NUM1=0 + DO 30 K=1,NREG + L=MAT(K) + IF(L.EQ.0) GO TO 30 + VOL0=VOL(K) + IF(VOL0.EQ.0.0) GO TO 20 + DO 15 I0=1,IELEM + DO 10 J0=1,IELEM + JND1=KN(NUM1+1)+(I0-1)*IELEM+J0-1 + F3(JND1)=F3(JND1)+VOL0*SGD(L)*F2(JND1) + 10 CONTINUE + 15 CONTINUE + 20 NUM1=NUM1+5 + 30 CONTINUE + RETURN + END diff --git a/Trivac/src/KINB03.f b/Trivac/src/KINB03.f new file mode 100755 index 0000000..9ac2f97 --- /dev/null +++ b/Trivac/src/KINB03.f @@ -0,0 +1,114 @@ +*DECK KINB03 + SUBROUTINE KINB03(MAXKN,MAXQF,SGD,NREG,LL4,ISPLH,NELEM,NBMIX, + 1 MAT,KN,QFR,VOL,RH,RT,F2,F3) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Multiplication of a matrix by a vector in mesh-corner finite- +* difference diffusion approximation (hexagonal geometry). Special +* version for Bivac. +* +*Copyright: +* Copyright (C) 2010 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXKN dimension of array KN. +* MAXQF dimension of array QFR. +* SGD mixture-ordered cross sections. +* NREG number of hexagons in Bivac. +* LL4 number of unknowns (order of the system matrices). +* ISPLH hexagonal geometry flag: +* =1: hexagonal elements; >1: triangular elements. +* NELEM number of finite elements (hexagons or triangles) excluding +* the virtual elements. +* NBMIX number of macro-mixtures. +* MAT mixture index per hexagon. +* KN element-ordered unknown list. +* QFR element-ordered information. +* VOL volume of the hexagons. +* RH unit matrix. +* RT unit matrix. +* F2 vector to multiply. +* +*Parameters: output +* F3 result of the multiplication. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MAXKN,MAXQF,NREG,LL4,ISPLH,NELEM,NBMIX,MAT(NREG),KN(MAXKN) + REAL SGD(NBMIX),QFR(MAXQF),VOL(NREG),RH(6,6),RT(3,3),F2(LL4), + 1 F3(LL4) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION RRH + INTEGER ISR(6,2),ISRH(6,2),ISRT(3,2) + REAL RH2(6,6) + DATA ISRH/2,1,4,5,6,3,1,4,5,6,3,2/ + DATA ISRT/1,2,3,2,3,1/ +*---- +* RECOVER THE HEXAGONAL MASS (RH2) AND STIFFNESS (QH2) MATRICES. +*---- + IF(ISPLH.EQ.1) THEN +* HEXAGONAL BASIS. + LH=6 + DO 15 I=1,6 + DO 10 J=1,2 + ISR(I,J)=ISRH(I,J) + 10 CONTINUE + 15 CONTINUE + DO 25 I=1,6 + DO 20 J=1,6 + RH2(I,J)=RH(I,J) + 20 CONTINUE + 25 CONTINUE + CONST=1.5*SQRT(3.0) + ELSE +* TRIANGULAR BASIS. + LH=3 + DO 35 I=1,3 + DO 30 J=1,2 + ISR(I,J)=ISRT(I,J) + 30 CONTINUE + 35 CONTINUE + DO 45 I=1,3 + DO 40 J=1,3 + RH2(I,J)=RT(I,J) + 40 CONTINUE + 45 CONTINUE + CONST=0.25*SQRT(3.0) + ENDIF +*---- +* MULTIPLICATION +*---- + NUM1=0 + DO 80 K=1,NELEM + KHEX=KN(NUM1+LH+1) + IF(VOL(KHEX).EQ.0.0) GO TO 70 + L=MAT(KHEX) + VOL0=QFR(NUM1+LH+1) + DO 60 I=1,LH + IND1=KN(NUM1+I) + IF(IND1.EQ.0) GO TO 60 + DO 50 J=1,LH + IND2=KN(NUM1+J) + IF(IND2.EQ.0) GO TO 50 + RRH=RH2(I,J)/CONST + IF(RRH.EQ.0.0) GO TO 50 + F3(IND1)=F3(IND1)+REAL(RRH)*SGD(L)*VOL0*F2(IND2) + 50 CONTINUE + 60 CONTINUE + 70 NUM1=NUM1+LH+1 + 80 CONTINUE + RETURN + END diff --git a/Trivac/src/KINB04.f b/Trivac/src/KINB04.f new file mode 100755 index 0000000..0517873 --- /dev/null +++ b/Trivac/src/KINB04.f @@ -0,0 +1,66 @@ +*DECK KINB04 + SUBROUTINE KINB04(MAXKN,MAXQF,SGD,NREG,LL4,ISPLH,NBMIX,MAT,KN, + 1 QFR,VOL,F2,F3) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Multiplication of a matrix by a vector in mesh-centered finite- +* difference diffusion approximation (hexagonal geometry). Special +* version for Bivac. +* +*Copyright: +* Copyright (C) 2010 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXKN dimension of array KN. +* MAXQF dimension of array QFR. +* SGD mixture-ordered cross sections. +* NREG number of hexagons in Bivac. +* LL4 number of unknowns per group in Bivac. Equal to the number +* of finite elements (hexagons or triangles) excluding the +* virtual elements. +* ISPLH type of hexagonal mesh-splitting: +* =1: hexagonal elements; >1: triangular elements. +* NBMIX number of macro-mixtures. +* MAT mixture index per hexagon. +* KN element-ordered unknown list. +* QFR element-ordered information. +* VOL volume of hexagons. +* F2 vector to multiply. +* +*Parameters: output +* F3 result of the multiplication. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MAXKN,MAXQF,NREG,LL4,ISPLH,NBMIX,MAT(NREG),KN(MAXKN) + REAL SGD(NBMIX),QFR(MAXQF),VOL(NREG),F2(LL4),F3(LL4) +* + IF(ISPLH.EQ.1) THEN + NSURF=6 + ELSE + NSURF=3 + ENDIF +*---- +* MULTIPLICATION. +*---- + NUM1=0 + DO 20 IND1=1,LL4 + KHEX=KN(NUM1+NSURF+1) + IF(VOL(KHEX).EQ.0.0) GO TO 10 + L=MAT(KHEX) + F3(IND1)=F3(IND1)+SGD(L)*QFR(NUM1+NSURF+1)*F2(IND1) + 10 NUM1=NUM1+NSURF+1 + 20 CONTINUE + RETURN + END diff --git a/Trivac/src/KINB05.f b/Trivac/src/KINB05.f new file mode 100755 index 0000000..157367b --- /dev/null +++ b/Trivac/src/KINB05.f @@ -0,0 +1,68 @@ +*DECK KINB05 + SUBROUTINE KINB05(SGD,IELEM,NBLOS,LL4,NBMIX,SIDE,MAT,IPERT, + 1 KN,F2,F3) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Multiplication of a matrix by a vector in Thomas-Raviart-Schneider +* (dual) finite element diffusion approximation (hexagonal geometry). +* Special version for Bivac. +* +*Copyright: +* Copyright (C) 2010 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +* SGD mixture-ordered cross sections. +* IELEM degree of the Lagrangian finite elements: =1 (linear); +* =2 (parabolic); =3 (cubic); =4 (quartic). +* NBLOS number of lozenges per direction, taking into account +* mesh-splitting. +* LL4 number of unknowns per group in Bivac. +* NBMIX number of macro-mixtures. +* SIDE side of the hexagons. +* MAT mixture index per region. +* IPERT mixture permutation index. +* KN element-ordered unknown list. +* F2 vector to multiply. +* +*Parameters: output +* F3 result of the multiplication. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IELEM,NBLOS,LL4,NBMIX,MAT(3,NBLOS),IPERT(NBLOS), + 1 KN(NBLOS,4+6*IELEM*(IELEM+1)) + REAL SGD(NBMIX),SIDE,F2(LL4),F3(LL4) +*---- +* ASSEMBLY OF A SYSTEM MATRIX. +*---- + TTTT=0.5*SQRT(3.0)*SIDE*SIDE + NUM=0 + DO 20 KEL=1,NBLOS + IF(IPERT(KEL).EQ.0) GO TO 20 + NUM=NUM+1 + IBM=MAT(1,IPERT(KEL)) + IF(IBM.EQ.0) GO TO 20 + SIG=SGD(IBM) + DO 15 K2=0,IELEM-1 + DO 10 K1=0,IELEM-1 + JND1=KN(NUM,1)+K2*IELEM+K1 + JND2=KN(NUM,2)+K2*IELEM+K1 + JND3=KN(NUM,3)+K2*IELEM+K1 + F3(JND1)=F3(JND1)+TTTT*SIG*F2(JND1) + F3(JND2)=F3(JND2)+TTTT*SIG*F2(JND2) + F3(JND3)=F3(JND3)+TTTT*SIG*F2(JND3) + 10 CONTINUE + 15 CONTINUE + 20 CONTINUE + RETURN + END diff --git a/Trivac/src/KINBLM.f b/Trivac/src/KINBLM.f new file mode 100755 index 0000000..3bdd40b --- /dev/null +++ b/Trivac/src/KINBLM.f @@ -0,0 +1,129 @@ +*DECK KINBLM + SUBROUTINE KINBLM(IPTRK,NBM,LDIM,SGD,F2,F3) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Driver for the multiplication of a matrix by a vector. Special +* version for Bivac. +* +*Copyright: +* Copyright (C) 2010 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK L_TRACK pointer to the tracking information. +* NBM number of material mixtures. +* LDIM dimension of vectors F2 and F3. +* SGD mixture-ordered cross sections. +* F2 vector to multiply. +* +*Parameters: output +* F3 result of the multiplication. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK + INTEGER NBM,LDIM + REAL SGD(NBM),F2(LDIM),F3(LDIM) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + INTEGER ISTATE(NSTATE) + LOGICAL CYLIND + INTEGER, DIMENSION(:), ALLOCATABLE :: MAT,KN,IPERT + REAL, DIMENSION(:), ALLOCATABLE :: VOL,QFR,XX,DD + REAL, DIMENSION(:,:), ALLOCATABLE :: R,RS,RH,RT +*---- +* RECOVER TRACKING INFORMATION. +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + NREG=ISTATE(1) + NBMIX=ISTATE(4) + ITYPE=ISTATE(6) + ALLOCATE(MAT(NREG),VOL(NREG)) + CALL LCMLEN(IPTRK,'KN',MAXKN,ITYLCM) + CALL LCMLEN(IPTRK,'QFR',MAXQF,ITYLCM) + ALLOCATE(KN(MAXKN),QFR(MAXQF)) + CALL LCMGET(IPTRK,'MATCOD',MAT) + CALL LCMGET(IPTRK,'VOLUME',VOL) + CALL LCMGET(IPTRK,'KN',KN) + CALL LCMGET(IPTRK,'QFR',QFR) +*---- +* ALGORITHM-DEPENDENT MULTIPLICATION +*---- + F3(:LDIM)=0.0 + ITYPE=ISTATE(6) + CYLIND=(ITYPE.EQ.3).OR.(ITYPE.EQ.6) + IHEX=ISTATE(7) + IELEM=ISTATE(8) + ICOL=ISTATE(9) + ISPLH=ISTATE(10) + LL4=ISTATE(11) + LX=ISTATE(12) + LY=ISTATE(13) + NVD=ISTATE(17) + IF(LL4.GT.LDIM) CALL XABORT('KINBLM: LDIM OVERFLOW.') + ALLOCATE(XX(LX*LY),DD(LX*LY)) + IF(ITYPE.EQ.8) THEN + CALL LCMGET(IPTRK,'SIDE',SIDE) + ELSE + CALL LCMGET(IPTRK,'XX',XX) + CALL LCMGET(IPTRK,'DD',DD) + ENDIF + IF((IHEX.EQ.0).AND.(IELEM.LT.0)) THEN +* --- PRIMAL FINITE ELEMENTS (CARTESIAN) + CALL LCMSIX(IPTRK,'BIVCOL',1) + CALL LCMLEN(IPTRK,'T',LC,ITYLCM) + ALLOCATE(R(LC,LC),RS(LC,LC)) + CALL LCMGET(IPTRK,'R',R) + CALL LCMGET(IPTRK,'RS',RS) + CALL LCMSIX(IPTRK,' ',2) + CALL KINB01(MAXKN,SGD,CYLIND,NREG,LL4,NBMIX,XX,DD,MAT,KN,VOL, + 1 LC,R,RS,F2,F3) + DEALLOCATE(RS,R) + ELSE IF((IHEX.EQ.0).AND.(IELEM.GT.0)) THEN +* --- MIXED-DUAL FINITE ELEMENTS (CARTESIAN) + CALL KINB02(SGD,IELEM,NREG,LL4,NBMIX,MAT,KN,VOL,F2,F3) + ELSE IF((IELEM.LT.0).AND.(ITYPE.EQ.8)) THEN +* --- MESH CORNER FINITE DIFFERENCES (HEXAGONAL) + ALLOCATE(RH(6,6),RT(3,3)) + CALL LCMSIX(IPTRK,'BIVCOL',1) + CALL LCMGET(IPTRK,'RH',RH) + CALL LCMGET(IPTRK,'RT',RT) + CALL LCMSIX(IPTRK,' ',2) + IF(ISPLH.EQ.1) THEN + NELEM=MAXKN/7 + ELSE + NELEM=MAXKN/4 + ENDIF + CALL KINB03(MAXKN,MAXQF,SGD,NREG,LL4,ISPLH,NELEM,NBMIX,MAT,KN, + 1 QFR,VOL,RH,RT,F2,F3) + DEALLOCATE(RT,RH) + ELSE IF((IELEM.GT.0).AND.(ITYPE.EQ.8).AND.(ICOL.EQ.4)) THEN +* --- MESH CENTERED FINITE DIFFERENCES FOR HEXAGONS + CALL KINB04(MAXKN,MAXQF,SGD,NREG,LL4,ISPLH,NBMIX,MAT,KN,QFR, + 1 VOL,F2,F3) + ELSE IF((IELEM.GT.0).AND.(ITYPE.EQ.8)) THEN +* --- THOMAS-RAVIART-SCHNEIDER METHOD (HEXAGONAL) + NBLOS=LX/3 + ALLOCATE(IPERT(NBLOS)) + CALL LCMGET(IPTRK,'IPERT',IPERT) + CALL KINB05(SGD,IELEM,NBLOS,LL4,NBMIX,SIDE,MAT,IPERT,KN,F2,F3) + DEALLOCATE(IPERT) + ELSE + CALL XABORT('KINBLM: TRACKING NOT AVAILABLE.') + ENDIF + DEALLOCATE(DD,XX,QFR,KN,VOL,MAT) + RETURN + END diff --git a/Trivac/src/KINDRV.f b/Trivac/src/KINDRV.f new file mode 100755 index 0000000..8ad451d --- /dev/null +++ b/Trivac/src/KINDRV.f @@ -0,0 +1,295 @@ +*DECK KINDRV + SUBROUTINE KINDRV(NEN,KEN,CMOD,NGR,NBM,NBFIS,NDG,NLF,ITY,NEL, + 1 LL4,NUN,NUP,TTF,TTP,DT,IMPH,ICL1,ICL2,NADI,ADJ,MAXOUT,EPSOUT, + 2 MAXINR,EPSINR,IFL,IPR,IEXP,INORM,IMPX,POWTOT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Driver to perform the space-time kinetics calculations. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal. +* +*Author(s): D. Sekki +* +*Parameters: input +* NEN number of LCM objects used in the module. +* KEN addresses of LCM objects: (1) L_KINET; (2) L_MACROLIB; +* (3) L_TRACK; (4) L_SYSTEM; (5) L_MACROLIB. +* CMOD name of the assembly door (BIVAC or TRIVAC). +* NGR number of energy groups. +* NBM number of material mixtures. +* NBFIS number of fissile isotopes. +* NDG number of delayed-neutron groups. +* NLF number of Legendre orders for fluxes. +* ITY type of finite elements and tracking. +* NEL total number of finite elements. +* LL4 number of flux unknowns per energy group. +* NUN total number of unknowns per energy group. +* NUP number of precursor unknowns per delayed group. +* TTF value of theta-parameter for fluxes. +* TTP value of theta-parameter for precursors. +* DT current time increment. +* IMPH management of convergence histogram. +* ICL1 number of free iterations in one cycle of the inverse power +* method +* ICL2 number of accelerated iterations in one cycle +* NADI number of inner adi iterations per outer iteration +* ADJ flag for adjoint space-time kinetics calculation +* MAXOUT maximum number of outer iterations +* EPSOUT convergence criteria for the flux +* MAXINR maximum number of thermal iterations. +* EPSINR thermal iteration epsilon. +* IFL temporal integration scheme for fluxes. +* IPR temporal integration scheme for precursors. +* IEXP exponential transformation flag (=1 to activate). +* INORM type of flux normalization (=0: no normalization; =1: imposed +* factor; =2: maximum flux; =3 initial power). +* IMPX printing parameter (=0 for no print). +* +*Parameter: output +* POWTOT power. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NEN,NGR,NBM,NBFIS,NDG,NLF,ITY,NEL,LL4,NUN,NUP,IMPH,ICL1, + 1 ICL2,NADI,MAXOUT,MAXINR,IFL,IPR,IEXP,INORM,IMPX + TYPE(C_PTR) KEN(NEN) + REAL TTF,TTP,DT,EPSOUT,EPSINR,POWTOT + CHARACTER CMOD*12 + LOGICAL ADJ +*---- +* LOCAL VARIABLES +*---- + PARAMETER(IOS=6) + INTEGER MAT(NEL),IDL(NEL),IDLPC(NEL) + REAL VOL(NEL),PDC(NDG),PMAX(NDG,NBFIS) + LOGICAL LNUD,LCHD + TYPE(C_PTR) IPMAC,IPSYS + REAL, DIMENSION(:), ALLOCATABLE :: DNF,AVG1,AVG2,WORK1,RM + REAL, DIMENSION(:,:), ALLOCATABLE :: EVECT,DNS,PHO,OVR,OMEGA + REAL, DIMENSION(:,:,:), ALLOCATABLE :: PC,CHI,SGF + REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: SGD,CHD,SGO + DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: SRC +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(EVECT(NUN,NGR),PC(NUP,NDG,NBFIS),SGD(NBM,NBFIS,NGR,NDG), + 1 OMEGA(NBM,NGR)) +*---- +* RECOVER INFORMATION +*---- + CALL KDRCPU(TK1) + TA1=TK1 + IF(IMPX.GT.0) WRITE(IOS,1001) + CALL LCMGET(KEN(1),'E-KEFF',EVL) + CALL LCMGET(KEN(1),'LAMBDA-D',PDC) + CALL LCMGET(KEN(1),'E-IDLPC',IDLPC) + CALL LCMLEN(KEN(1),'OMEGA',ILONG,ITYLCM) + IF((IEXP.EQ.0).OR.(ILONG.EQ.0)) THEN + OMEGA(:NBM,:NGR)=0.0 + ELSE + CALL LCMGET(KEN(1),'OMEGA',OMEGA) + ENDIF + CALL LCMGET(KEN(3),'VOLUME',VOL) + CALL LCMGET(KEN(3),'MATCOD',MAT) + CALL LCMGET(KEN(3),'KEYFLX',IDL) +*---- +* RECOVER CROSS SECTIONS (BEGINNING-OF-STEP) +*---- + ALLOCATE(DNF(NDG),DNS(NGR,NDG)) + CALL LCMLEN(KEN(1),'BETA-D',LEN,ITYL) + LNUD=(LEN.EQ.NDG) + IF(LNUD) CALL LCMGET(KEN(1),'BETA-D',DNF) + CALL LCMLEN(KEN(1),'CHI-D',LEN,ITYL) + LCHD=(LEN.EQ.NGR*NDG) + IF(LCHD) CALL LCMGET(KEN(1),'CHI-D',DNS) + ALLOCATE(OVR(NBM,NGR),CHI(NBM,NBFIS,NGR),CHD(NBM,NBFIS,NGR,NDG), + 1 SGF(NBM,NBFIS,NGR),SGO(NBM,NBFIS,NGR,NDG)) + IF(NEN.EQ.4) THEN + IPMAC=KEN(2) + IPSYS=KEN(4) + ELSE IF(NEN.EQ.6) THEN + IPMAC=KEN(5) + IPSYS=KEN(6) + ENDIF + CALL KINXSD(IPMAC,NGR,NBM,NBFIS,NDG,EVL,DT,DNF,DNS,LNUD,LCHD,OVR, + 1 CHI,CHD,SGF,SGO) +*---- +* COMPUTE THE SOURCE TERM +*---- + LL4B=LL4 + IF((ITY.EQ.11).OR.(ITY.EQ.13)) LL4B=LL4*NLF/2 + ALLOCATE(PHO(NUN,NGR),SRC(NUN,NGR)) + CALL LCMGET(KEN(1),'E-PREC',PC) + CALL LCMGET(KEN(1),'E-VECTOR',PHO) + CALL KINSRC(KEN(3),IPSYS,CMOD,IMPX,IFL,IPR,IEXP,NGR,NBM,NBFIS,NDG, + 1 ITY,LL4B,NUN,NUP,PDC,TTF,TTP,DT,ADJ,OVR,CHI,CHD,SGF,SGO,OMEGA, + 2 PHO,PC,SRC) +*---- +* RECOVER CROSS SECTIONS (END-OF-STEP) +*---- + CALL KINXSD(KEN(2),NGR,NBM,NBFIS,NDG,EVL,DT,DNF,DNS,LNUD,LCHD, + 1 OVR,CHI,CHD,SGF,SGD) + DEALLOCATE(DNS,DNF) +*---- +* RECOVER THE BEGINNING-OF-STEP FLUX +*---- + IF(IMPX.GT.0)THEN + CALL KDRCPU(TA2) + WRITE(IOS,1002) TA2-TA1 + WRITE(IOS,1003) + ENDIF + DO 15 IGR=1,NGR + DO 10 IND=1,NUN + EVECT(IND,IGR)=PHO(IND,IGR) + 10 CONTINUE + 15 CONTINUE +*---- +* COMPUTE THE FLUX SOLUTION +*---- + IF(CMOD.EQ.'BIVAC')THEN + IF(ADJ) CALL XABORT('KINDRV: ADJOINT CALCULATION NOT IMPLEMENT' + 1 //'ED WITH BIVAC.') + CALL KINSLB(KEN(3),KEN(4),KEN(1),LL4B,ITY,NUN,NGR,IFL,IPR, + 1 IEXP,NBM,NBFIS,NDG,ICL1,ICL2,IMPX,IMPH,TITR,EPSOUT,MAXINR, + 2 EPSINR,MAXOUT,PDC,TTF,TTP,DT,OVR,CHI,CHD,SGF,SGD,OMEGA,EVECT, + 3 SRC) + ELSEIF(CMOD.EQ.'TRIVAC')THEN + CALL KINSLT(KEN(3),KEN(4),KEN(1),LL4B,ITY,NUN,NGR,IFL,IPR, + 1 IEXP,NBM,NBFIS,NDG,ICL1,ICL2,IMPX,IMPH,TITR,EPSOUT,MAXINR, + 2 EPSINR,NADI,ADJ,MAXOUT,PDC,TTF,TTP,DT,OVR,CHI,CHD,SGF,SGD, + 3 OMEGA,EVECT,SRC) + ENDIF + DEALLOCATE(SRC) +*---- +* COMPUTE THE PRECURSOR SOLUTION +*---- + CALL KINPRC(KEN(3),KEN(4),CMOD,NGR,NBM,NBFIS,NDG,NEL,LL4,NUN,NUP, + 1 MAT,VOL,IDLPC,EVECT,PHO,CHD,CHO,SGD,SGO,PDC,DT,ADJ,TTP,PC,IPR, + 2 IEXP,OMEGA,IMPX) + CALL LCMPUT(KEN(1),'E-PREC',NDG*NUP*NBFIS,2,PC) +*---- +* COMPUTE THE EXPONENTIAL TRANSFORMATION FACTORS +*---- + IF(IEXP.EQ.1) THEN + ALLOCATE(WORK1(LL4),RM(LL4),AVG1(NBM),AVG2(NBM)) + DO 35 IGR=1,NGR + DO 20 IBM=1,NBM + AVG1(IBM)=EXP(OMEGA(IBM,IGR)*DT) + 20 CONTINUE + IF(CMOD.EQ.'BIVAC')THEN + CALL KINBLM(KEN(3),NBM,LL4,AVG1,EVECT(1,IGR),WORK1) + CALL MTLDLS('RM',KEN(3),KEN(4),LL4,1,WORK1) + ELSEIF(CMOD.EQ.'TRIVAC')THEN + CALL KINTLM(KEN(3),NBM,LL4,AVG1,EVECT(1,IGR),WORK1) + CALL LCMLEN(KEN(4),'RM',ILONG,ITYLCM) + CALL LCMGET(KEN(4),'RM',RM) + DO 25 IND=1,ILONG + FACT=RM(IND) + IF(FACT.EQ.0.0) CALL XABORT('KINDRV: SINGULAR RM.') + WORK1(IND)=WORK1(IND)/FACT + 25 CONTINUE + ENDIF + DO 30 IND=1,LL4 + EVECT(IND,IGR)=WORK1(IND) + 30 CONTINUE + 35 CONTINUE + CALL LCMPUT(KEN(1),'E-VECTOR',NGR*NUN,2,EVECT) +* + DO 60 IGR=1,NGR + AVG1(:NBM)=0.0 + AVG2(:NBM)=0.0 + DO 40 IEL=1,NEL + IBM=MAT(IEL) + IF(IBM.GT.0) THEN + AVG1(IBM)=AVG1(IBM)+VOL(IEL)*PHO(IDL(IEL),IGR) + AVG2(IBM)=AVG2(IBM)+VOL(IEL)*EVECT(IDL(IEL),IGR) + ENDIF + 40 CONTINUE + DO 50 IBM=1,NBM + RATIO=MIN(10.0,ABS(AVG2(IBM)/AVG1(IBM))) + OMEGA(IBM,IGR)=LOG(RATIO)/DT + 50 CONTINUE + IF(IMPX.GT.1) THEN + WRITE(IOS,1006) (OMEGA(IBM,IGR),IBM=1,NBM) + ENDIF + 60 CONTINUE + CALL LCMPUT(KEN(1),'OMEGA',NBM*NGR,2,OMEGA) + DEALLOCATE(AVG2,AVG1,RM,WORK1) + ENDIF +*---- +* COMPUTE AVERAGED FLUX VALUES. +*---- + DO 70 IGR=1,NGR + IF(CMOD.EQ.'BIVAC')THEN + CALL FLDBIV(KEN(3),NEL,NUP,EVECT(1,IGR),MAT,VOL,IDL) + ELSEIF(CMOD.EQ.'TRIVAC')THEN + CALL FLDTRI(KEN(3),NEL,NUP,EVECT(1,IGR),MAT,VOL,IDL) + ENDIF + 70 CONTINUE + CALL LCMPUT(KEN(1),'E-VECTOR',NGR*NUN,2,EVECT) +*---- +* FIND THE MAXIMUM FLUX VALUE +*---- + FMAX=0.0 + IDMX=0 + DO 85 IGR=1,NGR + DO 80 IEL=1,NEL + IND=IDL(IEL) + IF(IND.EQ.0) GO TO 80 + IF(ABS(EVECT(IND,IGR)).GT.FMAX) THEN + FMAX=EVECT(IND,IGR) + IDMX=IEL + IGMX=IGR + ENDIF + 80 CONTINUE + 85 CONTINUE + IF(IDMX.EQ.0) CALL XABORT('KINDRV: UNABLE TO SET FMAX.') + IND=IDLPC(IDMX) + IF(IND.EQ.0) CALL XABORT('KINDRV: UNABLE TO SET PMAX.') + DO 95 IFIS=1,NBFIS + DO 90 IDG=1,NDG + PMAX(IDG,IFIS)=PC(IND,IDG,IFIS) + 90 CONTINUE + 95 CONTINUE + IF(IMPX.GT.0) THEN + WRITE(IOS,1004) FMAX,IDMX,IGMX + CALL KDRCPU(TK2) + WRITE(IOS,1005)TK2-TK1 + ENDIF + CALL LCMPUT(KEN(1),'CTRL-FLUX',1,2,FMAX) + CALL LCMPUT(KEN(1),'CTRL-PREC',NDG*NBFIS,2,PMAX) + CALL LCMPUT(KEN(1),'CTRL-IDL',1,1,IDMX) + CALL LCMPUT(KEN(1),'CTRL-IGR',1,1,IGMX) +*---- +* COMPUTE REACTOR POWER +*---- + IF(INORM.EQ.3) THEN + CALL KINPOW(KEN(2),NGR,NBM,NUN,NEL,MAT,VOL,IDL,EVECT,POWTOT) + CALL LCMPUT(KEN(1),'E-POW',1,2,POWTOT) + IF(IMPX.GT.0) WRITE(6,*) 'REACTOR POWER (MW) =',POWTOT + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(PHO,SGO,SGF,CHD,CHI,OVR) + DEALLOCATE(OMEGA,SGD,PC,EVECT) + RETURN +* + 1001 FORMAT(/1X,'=> ASSEMBLY OF THE SYSTEM MATRICES'/) + 1002 FORMAT(/1X,'TOTAL CPU TIME USED FOR THE ASSEMBLING', + 1 1X,'OF ALL SYSTEM MATRICES =',F6.3/) + 1003 FORMAT(/1X,'=> COMPUTING THE KINETICS SOLUTION'/) + 1004 FORMAT(/1X,'CONTROLLING PARAMETERS:',2X,'MAX-VA', + 1 'L',1X,1PE12.5,3X,'IDL #',I5.5,3X,'IGR #',I2.2/) + 1005 FORMAT(/1X,'TOTAL CPU TIME USED FOR KINETICS CALC', + 1 'ULATIONS =',F10.3//1X,'=> SPACE-TIME',1X, + 2 'KINETICS CALCULATION IS DONE.') + 1006 FORMAT(39H KINDRV: MIXTURE-ORDERED OMEGA FACTORS:/(1P,10E14.6)) + END diff --git a/Trivac/src/KININI.f b/Trivac/src/KININI.f new file mode 100755 index 0000000..36964a5 --- /dev/null +++ b/Trivac/src/KININI.f @@ -0,0 +1,147 @@ +*DECK KININI + SUBROUTINE KININI(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Initialize the space-time kinetics parameters. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal. +* +*Author(s): D. Sekki +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1): create type(L_KINET); +* HENTRY(2): read-only type(L_MACROLIB); +* HENTRY(3): read-only type(L_TRACK); +* HENTRY(4): read-only type(L_SYSTEM); +* HENTRY(5): read-only type(L_FLUX). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 + TYPE(C_PTR) KENTRY(NENTRY) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + INTEGER ISTATE(NSTATE) + CHARACTER TEXT12*12,HSIGN*12,CMODUL*12,HSMG*131 +*---- +* PARAMETER VALIDATION +*---- + IF(NENTRY.NE.5)CALL XABORT('@KININI: INVALID NUMBER OF MODULE PA' + 1 //'RAMETERS.') + DO IEN=2,NENTRY + IF((IENTRY(IEN).NE.1).AND.(IENTRY(IEN).NE.2)) + 1 CALL XABORT('@KININI: LCM OBJECTS EXPECTED AT RHS') + IF(JENTRY(IEN).NE.2)CALL XABORT('@KININI: LCM OBJEC' + 1 //'TS IN READ-ONLY MODE EXPECTED AT RHS.') + ENDDO +* L_KINET + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) + 1 CALL XABORT('@KININI: LCM OBJECT EXPECTED AT LHS.') + IF(JENTRY(1).NE.0)CALL XABORT('@KININI: L_KINET IN' + 1 //' CREATE MODE EXPECTED.') + HSIGN='L_KINET' + CALL LCMPTC(KENTRY(1),'SIGNATURE',12,HSIGN) +* L_MACROLIB + CALL LCMGTC(KENTRY(2),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_MACROLIB')THEN + TEXT12=HENTRY(2) + CALL XABORT('@KININI: SIGNATURE OF '//TEXT12//' IS ' + 1 //HSIGN//'. L_MACROLIB EXPECTED.') + ENDIF +* L_TRACK + CALL LCMGTC(KENTRY(3),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_TRACK')THEN + TEXT12=HENTRY(3) + CALL XABORT('@KININI: SIGNATURE OF '//TEXT12//' IS ' + 1 //HSIGN//'. L_TRACK EXPECTED.') + ENDIF +* L_SYSTEM + CALL LCMGTC(KENTRY(4),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_SYSTEM')THEN + TEXT12=HENTRY(4) + CALL XABORT('@KININI: SIGNATURE OF '//TEXT12//' IS ' + 1 //HSIGN//'. L_SYSTEM EXPECTED.') + ENDIF + CALL LCMGTC(KENTRY(4),'LINK.MACRO',12,TEXT12) + IF(HENTRY(2).NE.TEXT12) THEN + WRITE(HSMG,'(40H@KININI: INVALID MACROLIB OBJECT NAME ='',A12, + 1 18H'', EXPECTED NAME='',A12,2H''.)') HENTRY(2),TEXT12 + CALL XABORT(HSMG) + ENDIF + CALL LCMGTC(KENTRY(4),'LINK.TRACK',12,TEXT12) + IF(HENTRY(3).NE.TEXT12) THEN + WRITE(HSMG,'(40H@KININI: INVALID TRACKING OBJECT NAME ='',A12, + 1 18H'', EXPECTED NAME='',A12,2H''.)') HENTRY(3),TEXT12 + CALL XABORT(HSMG) + ENDIF +* L_FLUX + CALL LCMGTC(KENTRY(5),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_FLUX')THEN + TEXT12=HENTRY(5) + CALL XABORT('@KININI: SIGNATURE OF '//TEXT12//' IS ' + 1 //HSIGN//'. L_FLUX EXPECTED.') + ENDIF +*---- +* OBJECTS VALIDATION +*---- + ISTATE(:NSTATE)=0 + CALL LCMGET(KENTRY(5),'STATE-VECTOR',ISTATE) + NGR=ISTATE(1) + NUN=ISTATE(2) + ISTATE(:NSTATE)=0 + CALL LCMGET(KENTRY(2),'STATE-VECTOR',ISTATE) + IF(ISTATE(1).NE.NGR)CALL XABORT('@KININI: INVALID NU' + 1 //'MBER OF ENERGY GROUPS IN L_MACROLIB OR IN L_FLUX.') + NBM=ISTATE(2) + NBFIS=ISTATE(4) + NDG=ISTATE(7) + ISTATE(:NSTATE)=0 + CALL LCMGET(KENTRY(3),'STATE-VECTOR',ISTATE) + IF(ISTATE(2).NE.NUN)CALL XABORT('@KININI: INVALID TOTAL' + 1 //' NUMBER OF UNKNOWNS IN L_FLUX OR IN L_TRACK.') + IF(ISTATE(4).GT.NBM) THEN + WRITE(HSMG,'(46H@KININI: THE NUMBER OF MIXTURES IN THE TRACKIN, + 1 3HG (,I5,50H) IS GREATER THAN THE NUMBER OF MIXTURES IN THE MA, + 2 8HCROLIB (,I5,2H).)') ISTATE(4),NBM + CALL XABORT(HSMG) + ENDIF + ITYPE=ISTATE(6) + CALL LCMGTC(KENTRY(3),'TRACK-TYPE',12,CMODUL) +* + IF(CMODUL.EQ.'BIVAC')THEN + IF((ITYPE.NE.1).AND.(ITYPE.NE.2).AND.(ITYPE.NE.3).AND. + 1 (ITYPE.NE.4).AND.(ITYPE.NE.5).AND.(ITYPE.NE.6).AND. + 2 (ITYPE.NE.8))CALL XABORT('@KININI: TYPE OF GEOMETR' + 3 //'Y NOT COMPATIBLE WITH BIVAC TRACKING-TYPE.') + ELSEIF(CMODUL.EQ.'TRIVAC')THEN + IF((ITYPE.NE.1).AND.(ITYPE.NE.2).AND.(ITYPE.NE.3).AND. + 1 (ITYPE.NE.5).AND.(ITYPE.NE.6).AND.(ITYPE.NE.7).AND. + 2 (ITYPE.NE.8).AND.(ITYPE.NE.9))CALL XABORT('@KININI' + 3 //': TYPE OF GEOMETRY NOT COMPATIBLE WITH TRIVAC T' + 4 //'RACKING-TYPE.') + ENDIF + NEL=ISTATE(1) + CALL LCMPTC(KENTRY(1),'TRACK-TYPE',12,CMODUL) + CALL KINRD1(NENTRY,KENTRY,CMODUL,NGR,NBM,NBFIS,NEL,NUN,NDG) + RETURN + END diff --git a/Trivac/src/KINPOW.f b/Trivac/src/KINPOW.f new file mode 100755 index 0000000..1ca88ca --- /dev/null +++ b/Trivac/src/KINPOW.f @@ -0,0 +1,80 @@ +*DECK KINPOW + SUBROUTINE KINPOW(IPMAC,NGR,NBM,NUN,NEL,MAT,VOL,IDL,EVECT,POWTOT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute reactor power. +* +*Copyright: +* Copyright (C) 2011 Ecole Polytechnique de Montreal. +* +*Author(s): R. Chambon +* +*Parameters: input +* IPMAC addresses of L_MACROLIB object. +* NGR number of energy groups. +* NBM number of material mixtures. +* NUN total number of unknowns per energy group. +* NEL total number of finite elements. +* MAT mixture index assigned to each finite element. +* VOL volume of each element. +* IDL position of the average flux component associated with each +* finite element. +* EVECT neutron flux. +* IMPX print parameter (equal to zero for no print). +* +*Parameters: output +* POWTOT power in MW. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NGR,NBM,NUN,NEL,MAT(NEL),IDL(NEL) + TYPE(C_PTR) IPMAC + REAL EVECT(NUN,NGR),VOL(NEL),POWTOT +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION POWD,XDRCST,EVJ + INTEGER IGR,IEL,ITYLCM,LENGT + TYPE(C_PTR) JPMAC,KPMAC + REAL, DIMENSION(:), ALLOCATABLE :: HF +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(HF(NBM)) +* + POWTOT=0.0 + JPMAC=LCMGID(IPMAC,'GROUP') + KPMAC=LCMGIL(JPMAC,1) + CALL LCMLEN(KPMAC,'H-FACTOR',LENGT,ITYLCM) + IF(LENGT.EQ.0) RETURN + IF(LENGT.NE.NBM) CALL XABORT('@KINPOW: INVALID LENGTH FO' + 1 //'R H-FACTOR INFORMATION.') +*---- +* Compute power as H*Phi*Vol. +*---- + EVJ=XDRCST('eV','J') + HF(:NBM)=0.0 + POWD=0.0D0 + DO 20 IGR=1,NGR + KPMAC=LCMGIL(JPMAC,IGR) + CALL LCMGET(KPMAC,'H-FACTOR',HF) + DO 10 IEL=1,NEL + IF(MAT(IEL).GT.0) THEN + POWD=POWD+VOL(IEL)*HF(MAT(IEL))*EVECT(IDL(IEL),IGR)*EVJ + ENDIF + 10 CONTINUE + 20 CONTINUE + POWTOT=REAL(POWD)/1.0E6 +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(HF) + RETURN + END diff --git a/Trivac/src/KINPRC.f b/Trivac/src/KINPRC.f new file mode 100755 index 0000000..cb008a4 --- /dev/null +++ b/Trivac/src/KINPRC.f @@ -0,0 +1,249 @@ +*DECK KINPRC + SUBROUTINE KINPRC(IPTRK,IPSYS,CMOD,NGR,NBM,NBFIS,NDG,NEL,LL4,NUN, + 1 NUP,MAT,VOL,IDLPC,FLN,FLO,CHD,CHO,SGD,SGO,PDC,DT,ADJ,TTP,PC,IPR, + 2 IEXP,OMEGA,IMPX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the precursors unknowns for the current time step according +* to the pre-defined temporal integration scheme. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal. +* +*Author(s): D. Sekki +* +*Parameters: input/output +* IPTRK pointer to L_TRACK object. +* IPSYS pointer to L_SYSTEM object. +* CMOD name of the assembly door (BIVAC or TRIVAC). +* NGR number of energy groups. +* NBM number of material mixtures. +* NBFIS number of fissile isotopes. +* NDG number of delayed-neutron groups. +* NEL total number of finite elements. +* LL4 number of flux unknowns per energy group. +* NUN total number of unknowns per energy group. +* NUP number of precursor unknowns per delayed group. +* MAT mixture index assigned to each volume. +* VOL volume of each element. +* IDLPC position of averaged precursor values in unknown vector. +* FLN unknown flux vector at current time step. +* FLO unknown flux vector at previous time step. +* CHD current delayed fission spectrum. +* CHO previous delayed fission spectrum. +* SGD current delayed nu*fission macroscopic x-sections/keff. +* SGO previous delayed nu*fission macroscopic x-sections/keff. +* PDC precursor decay constants. +* DT current time increment. +* ADJ flag for adjoint space-time kinetics calculation. +* TTP value of theta-parameter for precursors. +* PC unknown vector for precursors. +* IPR integration scheme for precursors: =1 implicit; +* =2 Crank-Nicholson; =3 theta; =4 exponential. +* IEXP exponential transformation flag (=1 to activate). +* OMEGA exponential transformation parameter. +* IMPX printing parameter (=0 for no print). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPSYS + INTEGER NGR,NBM,NBFIS,NDG,NEL,LL4,NUN,NUP,MAT(NEL),IDLPC(NEL), + 1 IPR,IEXP,IMPX + REAL VOL(NEL),PDC(NDG),DT,TTP,PC(NUP,NDG,NBFIS),FLN(NUN,NGR), + 1 FLO(NUN,NGR),CHD(NBM,NBFIS,NGR,NDG),CHO(NBM,NBFIS,NGR,NDG), + 2 SGD(NBM,NBFIS,NGR,NDG),SGO(NBM,NBFIS,NGR,NDG),OMEGA(NBM,NGR) + CHARACTER CMOD*12 + LOGICAL ADJ +*---- +* LOCAL VARIABLES +*---- + PARAMETER(IOS=6) + DOUBLE PRECISION DK,DTP,TK1(NDG),TK2(NDG),TK3(NDG) + REAL, DIMENSION(:), ALLOCATABLE :: GAR1,GAR2 + REAL, DIMENSION(:,:), ALLOCATABLE :: XSEXP + REAL, DIMENSION(:), POINTER :: RM + TYPE(C_PTR) RM_PTR +*---- +* COMPUTE THE KINETICS FACTORS +*---- + TK1(:NDG)=0.0D0 + TK2(:NDG)=0.0D0 + TK3(:NDG)=0.0D0 + DTP=9999.0D0 + IF(IPR.EQ.2)THEN +* CRANK-NICHOLSON + DTP=0.5D0 + ELSEIF(IPR.EQ.3)THEN +* THETA + DTP=DBLE(TTP) + ENDIF + DO 10 L=1,NDG + DK=PDC(L)*DT + IF(IPR.EQ.1)THEN +* IMPLICIT + TK1(L)=1.0D0/(1.0D0+DK) + TK2(L)=DT/(1.0D0+DK) + ELSEIF(IPR.EQ.4)THEN +* EXPONENTIAL + TK1(L)=DEXP(-DK) + TK2(L)=(1.0D0-(1.0D0-TK1(L))/DK)/PDC(L) + TK3(L)=((1.0D0-TK1(L))/DK-TK1(L))/PDC(L) + ELSE +* GENERAL + TK1(L)=(1.0D0-(1.0D0-DTP)*DK)/(1.0D0+DTP*DK) + TK2(L)=DTP*DT/(1.0D0+DTP*DK) + TK3(L)=(1.0D0-DTP)*DT/(1.0D0+DTP*DK) + ENDIF + 10 CONTINUE +*---- +* COMPUTE THE PRECURSOR UNKNOWN VECTOR +*---- + IF(IMPX.GT.0)WRITE(IOS,1001)CMOD + ALLOCATE(GAR1(NUP),GAR2(NUP),XSEXP(NBM,NGR)) + DO 220 IFIS=1,NBFIS + DO 210 IDG=1,NDG + DO 20 I=1,NUP + PC(I,IDG,IFIS)=REAL(TK1(IDG))*PC(I,IDG,IFIS) + 20 CONTINUE + GAR2(:NUP)=0.0 + IF(.NOT.ADJ) THEN + DO 40 IGR=1,NGR + DO 30 IBM=1,NBM + IF(IEXP.EQ.0) THEN + XSEXP(IBM,IGR)=SGD(IBM,IFIS,IGR,IDG) + ELSE +* exponential transformation + XSEXP(IBM,IGR)=SGD(IBM,IFIS,IGR,IDG)*EXP(OMEGA(IBM,IGR)*DT) + ENDIF + 30 CONTINUE + 40 CONTINUE + ELSE + DO 60 IGR=1,NGR + DO 50 IBM=1,NBM + IF(IEXP.EQ.0) THEN + XSEXP(IBM,IGR)=PDC(IDG)*CHD(IBM,IFIS,IGR,IDG) + ELSE +* exponential transformation + XSEXP(IBM,IGR)=PDC(IDG)*CHD(IBM,IFIS,IGR,IDG)* + 1 EXP(OMEGA(IBM,IGR)*DT) + ENDIF + 50 CONTINUE + 60 CONTINUE + ENDIF + IF(CMOD.EQ.'BIVAC')THEN + ITY=1 + DO 80 IGR=1,NGR + CALL KINBLM(IPTRK,NBM,NUP,XSEXP(1,IGR),FLN(1,IGR),GAR1) + DO 70 IND=1,NUP + GAR2(IND)=GAR2(IND)+GAR1(IND) + 70 CONTINUE + 80 CONTINUE + CALL MTLDLS('RM',IPTRK,IPSYS,LL4,1,GAR2) + ELSEIF(CMOD.EQ.'TRIVAC')THEN + DO 100 IGR=1,NGR + CALL KINTLM(IPTRK,NBM,NUP,XSEXP(1,IGR),FLN(1,IGR),GAR1) + DO 90 IND=1,NUP + GAR2(IND)=GAR2(IND)+GAR1(IND) + 90 CONTINUE + 100 CONTINUE + CALL LCMLEN(IPSYS,'RM',ILONG,ITYLCM) + CALL LCMGPD(IPSYS,'RM',RM_PTR) + CALL C_F_POINTER(RM_PTR,RM,(/ ILONG /)) + DO 110 IND=1,ILONG + GAR2(IND)=GAR2(IND)/RM(IND) + 110 CONTINUE + ENDIF + DO 120 IND=1,NUP + PC(IND,IDG,IFIS)=PC(IND,IDG,IFIS)+REAL(TK2(IDG))*GAR2(IND) + 120 CONTINUE + IF(IPR.GT.1) THEN + GAR2(:NUP)=0.0 + IF(CMOD.EQ.'BIVAC')THEN + IF(ADJ) CALL XABORT('KINPRC: ADJOINT CALCULATION NOT IMPLEME' + 1 //'NTED WITH BIVAC.') + ITY=1 + DO 140 IGR=1,NGR + CALL KINBLM(IPTRK,NBM,NUP,SGO(1,IFIS,IGR,IDG),FLO(1,IGR), + 1 GAR1) + DO 130 IND=1,NUP + GAR2(IND)=GAR2(IND)+GAR1(IND) + 130 CONTINUE + 140 CONTINUE + CALL MTLDLS('RM',IPTRK,IPSYS,LL4,1,GAR2) + CALL FLDBIV(IPTRK,NEL,NUP,GAR2(1),MAT,VOL,IDLPC) + ELSEIF(CMOD.EQ.'TRIVAC')THEN + IF(.NOT.ADJ) THEN + DO 160 IGR=1,NGR + CALL KINTLM(IPTRK,NBM,NUP,SGO(1,IFIS,IGR,IDG),FLO(1,IGR), + 1 GAR1) + DO 150 IND=1,NUP + GAR2(IND)=GAR2(IND)+GAR1(IND) + 150 CONTINUE + 160 CONTINUE + ELSE + DO 180 IGR=1,NGR + CALL KINTLM(IPTRK,NBM,NUP,CHO(1,IFIS,IGR,IDG),FLO(1,IGR), + 1 GAR1) + DO 170 IND=1,NUP + GAR2(IND)=GAR2(IND)+PDC(IDG)*GAR1(IND) + 170 CONTINUE + 180 CONTINUE + ENDIF + CALL LCMLEN(IPSYS,'RM',ILONG,ITYLCM) + CALL LCMGPD(IPSYS,'RM',RM_PTR) + CALL C_F_POINTER(RM_PTR,RM,(/ ILONG /)) + DO 190 IND=1,ILONG + GAR2(IND)=GAR2(IND)/RM(IND) + 190 CONTINUE + ENDIF + DO 200 IND=1,NUP + PC(IND,IDG,IFIS)=PC(IND,IDG,IFIS)+REAL(TK3(IDG))*GAR2(IND) + 200 CONTINUE + ENDIF + IF(CMOD.EQ.'BIVAC')THEN + CALL FLDBIV(IPTRK,NEL,NUP,PC(1,IDG,IFIS),MAT,VOL,IDLPC) + ELSEIF(CMOD.EQ.'TRIVAC')THEN + CALL FLDTRI(IPTRK,NEL,NUP,PC(1,IDG,IFIS),MAT,VOL,IDLPC) + ENDIF + 210 CONTINUE + 220 CONTINUE + DEALLOCATE(XSEXP,GAR1,GAR2) +*---- +* EDITION +*---- + IF(IMPX.GT.5) THEN + WRITE(IOS,1002) + DO 240 IFIS=1,NBFIS + DO 230 IDG=1,NDG + WRITE(IOS,1003) IDG,IFIS,(PC(IND,IDG,IFIS),IND=1,LL4) + 230 CONTINUE + 240 CONTINUE + ENDIF + IF(IMPX.GT.2) THEN + DO 260 IFIS=1,NBFIS + WRITE(IOS,1004) IFIS,(IDG,IDG=1,NDG) + DO 250 IEL=1,NEL + IND=IDLPC(IEL) + IF(IND.EQ.0) GO TO 250 + WRITE(IOS,1005) IEL,(PC(IND,IDG,IFIS),IDG=1,NDG) + 250 CONTINUE + WRITE(IOS,'(/)') + 260 CONTINUE + ENDIF + RETURN +* + 1001 FORMAT(/1X,'COMPUTING THE PRECURSOR UNKNOWN VECTOR', + 1 1X,'ACCORDING TO THE TRACKING TYPE: ',A6/) + 1002 FORMAT(/1X,'=> COMPUTED PRECURSOR UNKNOWN VECTOR') + 1003 FORMAT(/17H PRECURSOR GROUP=,I5,18H FISSILE ISOTOPE=,I5/ + 1 (1P,8E14.5)) + 1004 FORMAT(/51H KINPRC: PRECURSOR UNKNOWN VECTOR (FISSILE ISOTOPE=, + 1 I5,1H)/(9X,6I13,:)) + 1005 FORMAT(1X,I6,2X,1P,6E13.5,:/(9X,6E13.5,:)) + END diff --git a/Trivac/src/KINRD1.f b/Trivac/src/KINRD1.f new file mode 100755 index 0000000..4251959 --- /dev/null +++ b/Trivac/src/KINRD1.f @@ -0,0 +1,190 @@ +*DECK KINRD1 + SUBROUTINE KINRD1(NEN,KEN,CMOD,NGR,NBM,NBFIS,NEL,NUN,NDG) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read and validate the module options from the input file. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal. +* +*Author(s): D. Sekki +* +*Parameters: input/output +* NEN number of LCM objects used in the module. +* KEN addresses of LCM objects: (1) L_KINET; (2) L_MACROLIB; +* (3) L_TRACK; (4) L_SYSTEM; (6) L_FLUX. +* CMOD name of the assembly door (BIVAC or TRIVAC). +* NGR number of energy groups. +* NBM number of material mixtures. +* NBFIS number of fissile isotopes. +* NEL total number of finite elements. +* NUN total number of unknowns per energy group. +* NDG number of delayed-neutron groups (=0 if not in macrolib). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NEN,NGR,NBM,NBFIS,NEL,NUN,NDG + TYPE(C_PTR) KEN(NEN) + CHARACTER CMOD*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40,IOS=6) + INTEGER ISTATE(NSTATE),MAT(NEL),IDLPC(NEL) + DOUBLE PRECISION DFLOT + CHARACTER TEXT*12 + LOGICAL LNUD,LCHD,LLAD,LPRIMA + REAL, DIMENSION(:), ALLOCATABLE :: DNF,PD + REAL, DIMENSION(:,:), ALLOCATABLE :: DNS +*---- +* READ THE INPUT DATA +*---- + IMPX=1 + LNUD=.FALSE. + LCHD=.FALSE. + LLAD=.FALSE. + INORM=0 + FNORM=1.0 + POWER=0.0 + IELEM=-1 + NLF=-1 + LPRIMA=.FALSE. + 10 CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT) + IF(ITYP.NE.3)CALL XABORT('@KINRD1: CHARACTER DATA EXPECTED(1).') + IF(TEXT.EQ.';')THEN + GOTO 60 + ELSEIF(TEXT.EQ.'EDIT') THEN + CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT) + IF(ITYP.NE.1)CALL XABORT('@KINRD1: INTEGER FOR EDIT EXPECTED.') + IMPX=MAX(0,NITMA) + IF(IMPX.GT.9)WRITE(IOS,1001) + ELSEIF(TEXT.EQ.'NGRP') THEN + CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT) + IF(ITYP.NE.1)CALL XABORT('@KINRD1: INTEGER FOR NGRP EXPECTED.') + IF(NGR.NE.NITMA)CALL XABORT('@KINRD1: INVALID INPUT FOR NGRP.') + ELSEIF(TEXT.EQ.'NDEL') THEN + CALL REDGET(ITYP,NDG,FLOT,TEXT,DFLOT) + IF(ITYP.NE.1)CALL XABORT('@KINRD1: INTEGER FOR NDEL EXPECTED.') + ELSEIF(TEXT.EQ.'BETA')THEN + LNUD=.TRUE. + ALLOCATE(DNF(NDG)) + DO 20 IDG=1,NDG + CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT) + IF(ITYP.NE.2)CALL XABORT('@KINRD1: REAL DATA EXPECTED(1).') + IF(FLOT.LE.0.)CALL XABORT('@KINRD1: INVALID BETA VALUE.') + DNF(IDG)=FLOT + 20 CONTINUE + ELSEIF(TEXT.EQ.'LAMBDA')THEN + LLAD=.TRUE. + ALLOCATE(PD(NDG)) + DO 30 IDG=1,NDG + CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT) + IF(ITYP.NE.2)CALL XABORT('@KINRD1: REAL DATA EXPECTED(2).') + IF(FLOT.LE.0.)CALL XABORT('@KINRD1: INVALID LAMBDA VALUE.') + PD(IDG)=FLOT + 30 CONTINUE + ELSEIF(TEXT.EQ.'CHID')THEN + LCHD=.TRUE. + ALLOCATE(DNS(NDG,NGR)) + DO 55 JGR=1,NGR + DO 50 IDG=1,NDG + CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT) + IF(ITYP.NE.2)CALL XABORT('@KINRD1: REAL DATA EXPECTED(3).') + DNS(IDG,JGR)=FLOT + 50 CONTINUE + 55 CONTINUE + ELSEIF(TEXT.EQ.'NORM')THEN + CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT) + IF(ITYP.EQ.2) THEN + INORM=1 + FNORM=FLOT + ELSE IF((ITYP.EQ.3).AND.(TEXT.EQ.'MAX')) THEN + INORM=2 + FNORM=0.0 + ELSE IF((ITYP.EQ.3).AND.(TEXT.EQ.'POWER-INI')) THEN + INORM=3 + FNORM=0.0 + CALL REDGET(ITYP,NITMA,POWER,TEXT,DFLOT) + IF(ITYP.NE.2)CALL XABORT('@KINRD1: REAL FOR POWER EXPECTED.') + IF(POWER.LT.0.)CALL XABORT('@KINRD1: INVALID POWER VALUE.') + ELSE + CALL XABORT('@KINRD1: ''MAX'', ''POWER-INI'' OR REAL DATA EX' + 1 //'PECTED') + ENDIF + ELSE + CALL XABORT('@KINRD1: INVALID KEYWORD '//TEXT//'.') + ENDIF + GO TO 10 + 60 IF(NEN.NE.5)CALL XABORT('@KINRD1: INVALID NUMBER' + 1 //' OF MODULE PARAMETERS.') + IF(IMPX.GT.9)WRITE(IOS,1002) +*---- +* RECOVER DELAYED NEUTRON DATA FROM MICROLIB +*---- + IF(.NOT.LNUD) THEN + ALLOCATE(DNF(NDG)) + CALL LCMLEN(KEN(2),'BETA-D',LEN,ITLCM) + IF(LEN.GT.0) CALL LCMGET(KEN(2),'BETA-D',DNF) + ENDIF + IF(.NOT.LLAD) THEN + ALLOCATE(PD(NDG)) + CALL LCMLEN(KEN(2),'LAMBDA-D',LEN,ITLCM) + IF(LEN.EQ.0)CALL XABORT('@KINRD1: MISSING DATA FOR THE PRECURS' + 1 //'OR DECAY CONSTANTS.') + CALL LCMGET(KEN(2),'LAMBDA-D',PD) + ENDIF + IF(.NOT.LCHD) ALLOCATE(DNS(NDG,NGR)) +*---- +* RECOVER THE INITIAL STATE +*---- + IF(IMPX.GT.0)WRITE(IOS,1003) + ISTATE(:NSTATE)=0 + CALL LCMGET(KEN(3),'STATE-VECTOR',ISTATE) + LL4=ISTATE(11) + NUP=LL4 + IF(CMOD.EQ.'BIVAC')THEN + IELEM=ISTATE(8) + NLF=ISTATE(14) + LPRIMA=(IELEM.LT.0) + ELSEIF(CMOD.EQ.'TRIVAC')THEN + IELEM=ISTATE(9) + ICHX=ISTATE(12) + NLF=ISTATE(30) + LPRIMA=(ICHX.EQ.1) + IF(ICHX.EQ.2) NUP=ISTATE(25) + ENDIF + IF(LPRIMA) THEN + CALL LCMGET(KEN(3),'MATCOD',MAT) + DO 70 K=1,NEL + IF(MAT(K).EQ.0) THEN + IDLPC(K)=0 + ELSE + NUP=NUP+1 + IDLPC(K)=NUP + ENDIF + 70 CONTINUE + ELSE + CALL LCMGET(KEN(3),'KEYFLX',IDLPC) + ENDIF + IF(IMPX.GT.0) WRITE(IOS,1004) NEL,NUN,NUP,CMOD + IF(LL4*NLF/2.GT.NUN) + 1 CALL XABORT('@KINRD1: INVALID NUMBER OF UNKNOWNS.') + CALL KINST1(NEN,KEN,CMOD,NGR,NBM,NBFIS,NDG,NEL,NUN,LL4,NUP,IDLPC, + 1 INORM,POWER,FNORM,DNF,DNS,PD,LNUD,LCHD,IMPX) + DEALLOCATE(DNS,PD,DNF) + RETURN +* + 1001 FORMAT(/1X,'KINRD1: READING DATA FROM INPUT FILE') + 1002 FORMAT(1X,'KINRD1: THE INPUT DATA HAVE BEEN READ.') + 1003 FORMAT(/1X,'RECOVERING THE INITIAL STEADY-STATE'/) + 1004 FORMAT(1X,'TOTAL NUMBER OF ELEMENTS',1X,I6/1X,'NU', + 1 'MBER OF FLUX UNKNOWNS PER ENERGY GROUP',1X,I6/1X, + 2 'NUMBER OF PRECURSOR UNKNOWNS PER DELAYED GROUP', + 3 1X,I6/1X,'USING TRACKING TYPE:',1X,A6) + END diff --git a/Trivac/src/KINRD2.f b/Trivac/src/KINRD2.f new file mode 100755 index 0000000..bff9fe0 --- /dev/null +++ b/Trivac/src/KINRD2.f @@ -0,0 +1,210 @@ +*DECK KINRD2 + SUBROUTINE KINRD2(NEN,KEN,CMODUL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read and validate the module options from the input file. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal. +* +*Author(s): D. Sekki +* +*Parameters: input/output +* NEN number of LCM objects used in the module. +* KEN addresses of LCM objects: (1) L_KINET; (2) L_MACROLIB; +* (3) L_TRACK; (4) L_SYSTEM; (5) L_MACROLIB. +* CMODUL name of the assembly door ('BIVAC' or 'TRIVAC'). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NEN + TYPE(C_PTR) KEN(NEN) + CHARACTER CMODUL*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40,IOS=6) + INTEGER ISTATE(NSTATE) + REAL EPSCON(5),POWTOT + CHARACTER TEXT*12,FNAM*40,PNAM*40 + DOUBLE PRECISION DFLOT + LOGICAL ADJ +*---- +* READ THE INPUT DATA +*---- + CALL LCMGET(KEN(1),'STATE-VECTOR',ISTATE) + ITR=ISTATE(1) + IMPX=1 + IMPH=0 + DELT=0.0 + IPICK=0 + IEXP=0 + ADJ=.FALSE. + IF(ITR.EQ.0) THEN + ICL1=3 + ICL2=3 + MAXINR=0 + MAXOUT=200 + NADI=2 + IFL=0 + IPR=0 + EPSINR=1.0E-2 + EPSOUT=1.0E-4 + TTF=9999.0 + TTP=9999.0 + IF(CMODUL.EQ.'TRIVAC') THEN + CALL LCMGET(KEN(3),'STATE-VECTOR',ISTATE) + NADI=ISTATE(33) + ELSE + NADI=2 + ENDIF + ELSE + ICL1=ISTATE(11) + ICL2=ISTATE(12) + MAXINR=ISTATE(14) + MAXOUT=ISTATE(15) + NADI=ISTATE(16) + IFL=ISTATE(17) + IPR=ISTATE(18) + IEXP=ISTATE(19) + ADJ=ISTATE(20).EQ.1 + CALL LCMGET(KEN(1),'EPS-CONVERGE',EPSCON) + EPSINR=EPSCON(1) + EPSOUT=EPSCON(2) + TTF=EPSCON(3) + TTP=EPSCON(4) + ENDIF + 40 CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT) + 50 IF(ITYP.NE.3)CALL XABORT('@KINRD2: CHARACTER DATA EXPECTED(1).') + IF(TEXT.EQ.';')THEN + GOTO 80 + ELSE IF(TEXT.EQ.'PICK') THEN + IPICK=1 + GOTO 80 + ELSEIF(TEXT.EQ.'EDIT') THEN + CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT) + IF(ITYP.NE.1)CALL XABORT('@KINRD2: INTEGER FOR EDIT EXPECTED.') + IMPX=MAX(0,NITMA) + IF(IMPX.GT.4) WRITE(IOS,1001) + ELSEIF(TEXT.EQ.'DELTA') THEN + CALL REDGET(ITYP,NITMA,DELT,TEXT,DFLOT) + IF(ITYP.NE.2)CALL XABORT('@KINRD2: REAL FOR DELTA EXPECTED.') + IF(DELT.LT.0.)CALL XABORT('@KINRD2: INVALID VALUE FOR DELTA.') + ELSEIF(TEXT.EQ.'SCHEME') THEN + CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT) + IF(ITYP.NE.3)CALL XABORT('@KINRD2: CHARACTER DATA EXPECTED(2).') + IF(TEXT.NE.'FLUX')CALL XABORT('@KINRD2: READ KEYWORD '//TEXT// + 1 '. KEYWORD FLUX EXPECTED.') + 55 CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT) + IF(ITYP.NE.3)CALL XABORT('@KINRD2: CHARACTER DATA EXPECTED(3).') + IF(TEXT.EQ.'IMPLIC')THEN + FNAM='IMPLICIT EULER METHOD' + IFL=1 + ELSEIF(TEXT.EQ.'CRANK')THEN + FNAM='CRANK-NICHOLSON METHOD' + IFL=2 + ELSEIF(TEXT.EQ.'THETA')THEN + CALL REDGET(ITYP,NITMA,TTF,TEXT,DFLOT) + IF(ITYP.NE.2)CALL XABORT('@KINRD2: REAL THETA EXPECTED(1).') + IF(TTF.LE.0.5)CALL XABORT('@KINRD2: INVALID THETA VALUE(1).') + IF(TTF.GE.1.0)CALL XABORT('@KINRD2: INVALID THETA VALUE(2).') + FNAM='GENERAL THETA METHOD' + IFL=3 + ELSEIF(TEXT.EQ.'TEXP')THEN + IEXP=1 + GO TO 55 + ELSE + CALL XABORT('@KINRD2: INVALID KEYWORD '//TEXT) + ENDIF + ELSEIF(TEXT.EQ.'PREC') THEN + CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT) + IF(ITYP.NE.3)CALL XABORT('@KINRD2: CHARACTER DATA EXPECTED(4).') + IF(TEXT.EQ.'IMPLIC')THEN + PNAM='IMPLICIT EULER METHOD' + IPR=1 + ELSEIF(TEXT.EQ.'CRANK')THEN + PNAM='CRANK-NICHOLSON METHOD' + IPR=2 + ELSEIF(TEXT.EQ.'THETA')THEN + CALL REDGET(ITYP,NITMA,TTP,TEXT,DFLOT) + IF(ITYP.NE.2)CALL XABORT('@KINRD2: REAL THETA EXPECTED(2).') + IF(TTP.LE.0.5)CALL XABORT('@KINRD2: INVALID THETA VALUE(3).') + IF(TTP.GE.1.0)CALL XABORT('@KINRD2: INVALID THETA VALUE(4).') + PNAM='GENERAL THETA METHOD' + IPR=3 + ELSEIF(TEXT.EQ.'EXPON')THEN + PNAM='ANALYTICAL INTEGRATION METHOD' + IPR=4 + ELSE + CALL XABORT('@KINRD2: INVALID KEYWORD '//TEXT) + ENDIF + ELSEIF((TEXT.EQ.'VAR1').OR.(TEXT.EQ.'ACCE')) THEN + CALL REDGET(ITYP,ICL1,FLOT,TEXT,DFLOT) + IF(ITYP.NE.1) + 1 CALL XABORT('@KINRD2: INTEGER DATA EXPECTED FOR ICL1.') + CALL REDGET(ITYP,ICL2,FLOT,TEXT,DFLOT) + IF(ITYP.NE.1) + 1 CALL XABORT('@KINRD2: INTEGER DATA EXPECTED FOR ICL2.') + ELSEIF(TEXT.EQ.'ADI') THEN + CALL REDGET(ITYP,NADI,FLOTT,TEXT,DFLOT) + IF(ITYP.NE.1) CALL XABORT('@KINRD2: INTEGER DATA EXPECTED(1).') + GO TO 40 + ELSE IF(TEXT.EQ.'ADJ') THEN + ADJ=.TRUE. + ELSEIF(TEXT.EQ.'EXTE') THEN + 60 CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT) + IF(ITYP.EQ.1) THEN + MAXOUT=NITMA + ELSE IF(ITYP.EQ.2) THEN + EPSOUT=FLOT + ELSE + GO TO 50 + ENDIF + GO TO 60 + ELSEIF(TEXT.EQ.'THER') THEN + 70 CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT) + IF(ITYP.EQ.1) THEN + MAXINR=NITMA + ELSE IF(ITYP.EQ.2) THEN + EPSINR=FLOT + ELSE + GO TO 50 + ENDIF + GO TO 70 + ELSEIF(TEXT.EQ.'HIST') THEN + CALL REDGET(ITYP,IMPH,FLOT,TEXT,DFLOT) + IF(ITYP.NE.1) CALL XABORT('@KINRD2: INTEGER DATA EXPECTED(2).') + ELSE + CALL XABORT('@KINRD2: INVALID KEYWORD '//TEXT) + ENDIF + GOTO 40 + 80 IF(IFL.EQ.0) CALL XABORT('@KINRD2: SCHEME DATA MISSING.') + IF(IPR.EQ.0) CALL XABORT('@KINRD2: PREC DATA MISSING.') + IF(IMPX.GT.0) WRITE(IOS,1002) ITR+1 + CALL KINST2(NEN,KEN,CMODUL,TTF,TTP,IFL,IPR,IEXP,DELT,IMPH,ICL1, + 1 ICL2,NADI,ADJ,MAXOUT,EPSOUT,MAXINR,EPSINR,FNAM,PNAM,IMPX,POWTOT) +*---- +* RECOVER THE FINAL POWER AND SAVE IT IN A CLE-2000 VARIABLE +*---- + IF(IPICK.EQ.1) THEN + CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT) + IF(ITYP.NE.-2) CALL XABORT('KINRD2: OUTPUT REAL EXPECTED.') + ITYP=2 + FLOT=POWTOT + CALL REDPUT(ITYP,NITMA,FLOT,TEXT,DFLOT) + CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT) + IF((ITYP.NE.3).OR.(TEXT.NE.';')) THEN + CALL XABORT('KINRD2: ; CHARACTER EXPECTED.') + ENDIF + ENDIF + RETURN +* + 1001 FORMAT(/1X,'KINRD2: READING DATA FROM INPUT FILE'/) + 1002 FORMAT(1X,'KINRD2: THE INPUT DATA HAVE BEEN READ AT STEP',I5,'.') + END diff --git a/Trivac/src/KINSLB.f b/Trivac/src/KINSLB.f new file mode 100755 index 0000000..6bb1b20 --- /dev/null +++ b/Trivac/src/KINSLB.f @@ -0,0 +1,454 @@ +*DECK KINSLB + SUBROUTINE KINSLB (IPTRK,IPSYS,IPKIN,LL4,ITY,NUN,NGR,IFL,IPR,IEXP, + 1 NBM,NBFIS,NDG,ICL1,ICL2,IMPX,IMPH,TITR,EPS2,MAXINR,EPSINR,MAXX0, + 2 PDC,TTF,TTP,DT,OVR,CHI,CHD,SGF,SGD,OMEGA,EVECT,SRC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solution of the kinetics multigroup linear systems for the transient +* neutron fluxes in Bivac. Use the inverse power method with a +* two-parameter SVAT acceleration technique. +* +*Copyright: +* Copyright (C) 2010 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK L_TRACK pointer to the tracking information. +* IPSYS L_SYSTEM pointer to system matrices. +* IPKIN L_KINET pointer to the KINET object. +* LL4 order of the system matrices. +* ITY type of solution (1: classical Bivac/diffusion; +* 11: Bivac/SPN). +* NUN number of unknowns in each energy group. +* NGR number of energy groups. +* IFL integration scheme for fluxes: =1 implicit; +* =2 Crank-Nicholson; =3 theta. +* IPR integration scheme for precursors: =1 implicit; +* =2 Crank-Nicholson; =3 theta; =4 exponential. +* IEXP exponential transformation flag (=1 to activate). +* NBM number of material mixtures. +* NBFIS number of fissile isotopes. +* NDG number of delayed-neutron groups. +* ICL1 number of free iterations in one cycle of the inverse power +* method +* ICL2 number of accelerated iterations in one cycle +* IMPX print parameter. =0: no print ; =1: minimum printing ; +* =2: iteration history is printed. =3: solution is printed +* IMPH =0: no action is taken +* =1: the flux is compared to a reference flux stored on lcm +* =2: the convergence histogram is printed +* =3: the convergence histogram is printed with axis and +* titles. The plotting file is completed +* =4: the convergence histogram is printed with axis, acce- +* leration factors and titles. The plotting file is +* completed +* TITR character*72 title +* EPS2 convergence criteria for the flux +* MAXINR maximum number of thermal iterations. +* EPSINR thermal iteration epsilon. +* MAXX0 maximum number of outer iterations +* PDC precursor decay constants. +* TTF value of theta-parameter for fluxes. +* TTP value of theta-parameter for precursors. +* DT current time increment. +* OVR reciprocal neutron velocities/DT. +* CHI steady-state fission spectrum. +* CHD delayed fission spectrum +* SGF nu*fission macroscopic x-sections/keff. +* SGD delayed nu*fission macroscopic x-sections/keff. +* OMEGA exponential transformation parameter. +* SRC fixed source +* +*Parameters: output +* EVECT converged solution +* +*References: +* A. H\'ebert, 'Preconditioning the power method for reactor +* calculations', Nucl. Sci. Eng., 94, 1 (1986). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER TITR*72 + TYPE(C_PTR) IPTRK,IPSYS,IPKIN + INTEGER LL4,ITY,NUN,NGR,IFL,IPR,IEXP,NBM,NBFIS,NDG,ICL1,ICL2,IMPX, + 1 IMPH,MAXINR,MAXX0 + REAL EPS2,EPSINR,PDC(NDG),TTF,TTP,DT,OVR(NBM,NGR), + 1 CHI(NBM,NBFIS,NGR),CHD(NBM,NBFIS,NGR,NDG),SGF(NBM,NBFIS,NGR), + 2 SGD(NBM,NBFIS,NGR,NDG),OMEGA(NBM,NGR),EVECT(NUN,NGR) + DOUBLE PRECISION SRC(NUN,NGR) +*---- +* LOCAL VARIABLES +*---- + CHARACTER*12 TEXT12 + LOGICAL LOGTES,LMPH + DOUBLE PRECISION D2F(2,3),ALP,BET,DTF,DTP,DARG,DK + REAL ERR(250),ALPH(250),BETA(250),TKT,TKB + INTEGER ITITR(18) + REAL, DIMENSION(:,:), ALLOCATABLE :: GRAD1,GRAD2 + DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: GAR1,GAR2,GAR3 + REAL, DIMENSION(:), ALLOCATABLE :: WORK1,WORK2,WORK3,WORK4 + DATA EPS1,MMAXX/1.0E-4,250/ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(GRAD1(NUN,NGR),GRAD2(NUN,NGR),GAR1(NUN,NGR), + 1 GAR2(NUN,NGR),GAR3(NUN,NGR),WORK1(LL4),WORK2(LL4),WORK3(NBM)) +* + CALL MTOPEN(IMPX,IPTRK,LL4) + IF(LL4.GT.NUN) CALL XABORT('KINSLB: INVALID NUMBER OF UNKNOWNS.') +*---- +* INVERSE POWER METHOD. +*---- + DTF=9999.0D0 + DTP=9999.0D0 + TEST=0.0 + IF(IFL.EQ.1)THEN + DTF=1.0D0 + ELSEIF(IFL.EQ.2)THEN + DTF=0.5D0 + ELSEIF(IFL.EQ.3)THEN + DTF=DBLE(TTF) + ENDIF + IF(IPR.EQ.2)THEN + DTP=0.5D0 + ELSEIF(IPR.EQ.3)THEN + DTP=DBLE(TTP) + ENDIF + DCRIT=MINVAL(DT*PDC(:)) +* + ISTART=1 + IF(IMPX.GE.1) WRITE (6,600) + IF(IMPX.GE.2) WRITE (6,610) + M=0 + 10 M=M+1 +* + DO 84 IGR=1,NGR + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,EVECT(1,IGR),WORK1) + DO 15 IND=1,LL4 + GAR1(IND,IGR)=DTF*WORK1(IND) + 15 CONTINUE + IF(IEXP.EQ.0) THEN + DO 16 IBM=1,NBM + WORK3(IBM)=OVR(IBM,IGR) + 16 CONTINUE + ELSE + DO 17 IBM=1,NBM + WORK3(IBM)=OVR(IBM,IGR)*(1.0+OMEGA(IBM,IGR)*DT) + 17 CONTINUE + ENDIF + CALL KINBLM(IPTRK,NBM,LL4,WORK3,EVECT(1,IGR),WORK1) + DO 20 IND=1,LL4 + GAR1(IND,IGR)=GAR1(IND,IGR)+WORK1(IND) + 20 CONTINUE + DO 83 JGR=1,NGR + IF(JGR.EQ.IGR) GO TO 40 + WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 40 + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,EVECT(1,JGR),WORK1) + DO 30 IND=1,LL4 + GAR1(IND,IGR)=GAR1(IND,IGR)-DTF*WORK1(IND) + 30 CONTINUE + 40 DO 82 IFIS=1,NBFIS + DO 50 IBM=1,NBM + WORK3(IBM)=CHI(IBM,IFIS,IGR)*SGF(IBM,IFIS,JGR) + 50 CONTINUE + CALL KINBLM(IPTRK,NBM,LL4,WORK3,EVECT(1,JGR),WORK1) + DO 60 IND=1,LL4 + GAR1(IND,IGR)=GAR1(IND,IGR)-DTF*WORK1(IND) + 60 CONTINUE + DO 81 IDG=1,NDG + DARG=PDC(IDG)*DT + IF(IPR.EQ.1)THEN + DK=1.0D0/(1.0D0+DARG) + ELSEIF(IPR.EQ.4)THEN + DK=(1.0D0-DEXP(-DARG))/DARG + ELSE + DK=1.0D0/(1.0D0+DTP*DARG) + ENDIF + DO 70 IBM=1,NBM + WORK3(IBM)=CHD(IBM,IFIS,IGR,IDG)*SGD(IBM,IFIS,JGR,IDG) + 70 CONTINUE + CALL KINBLM(IPTRK,NBM,LL4,WORK3,EVECT(1,JGR),WORK1) + DO 80 IND=1,LL4 + GAR1(IND,IGR)=GAR1(IND,IGR)+DTF*DK*WORK1(IND) + 80 CONTINUE + 81 CONTINUE + 82 CONTINUE + 83 CONTINUE + 84 CONTINUE +*---- +* DIRECTION EVALUATION. +*---- + DO 120 IGR=1,NGR + DO 90 IND=1,LL4 + GRAD1(IND,IGR)=REAL(SRC(IND,IGR)-GAR1(IND,IGR)) + 90 CONTINUE + DO 110 JGR=1,IGR-1 + WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 110 + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD1(1,JGR),WORK1) + DO 100 IND=1,LL4 + GRAD1(IND,IGR)=GRAD1(IND,IGR)+REAL(DTF)*WORK1(IND) + 100 CONTINUE + 110 CONTINUE + CALL KDRCPU(TK2) + TKB=TKB+(TK2-TK1) +* + CALL KDRCPU(TK1) + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL MTLDLS(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD1(1,IGR)) + CALL KDRCPU(TK2) + DO 115 IND=1,LL4 + GRAD1(IND,IGR)=GRAD1(IND,IGR)/REAL(DTF) + 115 CONTINUE + TKT=TKT+(TK2-TK1) + 120 CONTINUE +*---- +* PERFORM THERMAL (UP-SCATTERING) ITERATIONS +*---- + KTER=0 + NADI=5 ! used with SPN approximations + IF(MAXINR.GT.1) THEN + CALL FLDBHR(IPTRK,IPSYS,.FALSE.,LL4,ITY,NUN,NGR,ICL1,ICL2,IMPX, + 1 NADI,MAXINR,EPSINR,KTER,TKT,TKB,GRAD1) + ENDIF +*---- +* EVALUATION OF THE DISPLACEMENT AND OF THE TWO ACCELERATION PARAMETERS +* ALP AND BET. +*---- + DO 204 IGR=1,NGR + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD1(1,IGR),WORK1) + DO 130 IND=1,LL4 + GAR2(IND,IGR)=DTF*WORK1(IND) + 130 CONTINUE + IF(IEXP.EQ.0) THEN + DO 135 IBM=1,NBM + WORK3(IBM)=OVR(IBM,IGR) + 135 CONTINUE + ELSE + DO 136 IBM=1,NBM + WORK3(IBM)=OVR(IBM,IGR)*(1.0+OMEGA(IBM,IGR)*DT) + 136 CONTINUE + ENDIF + CALL KINBLM(IPTRK,NBM,LL4,WORK3,GRAD1(1,IGR),WORK1) + DO 140 IND=1,LL4 + GAR2(IND,IGR)=GAR2(IND,IGR)+WORK1(IND) + 140 CONTINUE + DO 203 JGR=1,NGR + IF(JGR.EQ.IGR) GO TO 160 + WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 160 + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD1(1,JGR),WORK1) + DO 150 IND=1,LL4 + GAR2(IND,IGR)=GAR2(IND,IGR)-DTF*WORK1(IND) + 150 CONTINUE + 160 DO 202 IFIS=1,NBFIS + DO 170 IBM=1,NBM + WORK3(IBM)=CHI(IBM,IFIS,IGR)*SGF(IBM,IFIS,JGR) + 170 CONTINUE + CALL KINBLM(IPTRK,NBM,LL4,WORK3,GRAD1(1,JGR),WORK1) + DO 180 IND=1,LL4 + GAR2(IND,IGR)=GAR2(IND,IGR)-DTF*WORK1(IND) + 180 CONTINUE + DO 201 IDG=1,NDG + DARG=PDC(IDG)*DT + IF(IPR.EQ.1)THEN + DK=1.0D0/(1.0D0+DARG) + ELSEIF(IPR.EQ.4)THEN + DK=(1.0D0-DEXP(-DARG))/DARG + ELSE + DK=1.0D0/(1.0D0+DTP*DARG) + ENDIF + DO 190 IBM=1,NBM + WORK3(IBM)=CHD(IBM,IFIS,IGR,IDG)*SGD(IBM,IFIS,JGR,IDG) + 190 CONTINUE + CALL KINBLM(IPTRK,NBM,LL4,WORK3,GRAD1(1,JGR),WORK1) + DO 200 IND=1,LL4 + GAR2(IND,IGR)=GAR2(IND,IGR)+DTF*DK*WORK1(IND) + 200 CONTINUE + 201 CONTINUE + 202 CONTINUE + 203 CONTINUE + 204 CONTINUE +* + 270 ALP=1.0D0 + BET=0.0D0 + D2F(:2,:3)=0.0D0 + IF(1+MOD(M-ISTART,ICL1+ICL2).GT.ICL1) THEN + IF(DCRIT.GT.1.0E-6) THEN +* TWO-PARAMETER ACCELERATION. SOLUTION OF A LINEAR SYSTEM. + DO 285 IGR=1,NGR + DO 280 I=1,LL4 + D2F(1,1)=D2F(1,1)+GAR2(I,IGR)**2 + D2F(1,2)=D2F(1,2)+GAR2(I,IGR)*GAR3(I,IGR) + D2F(2,2)=D2F(2,2)+GAR3(I,IGR)**2 + D2F(1,3)=D2F(1,3)-(GAR1(I,IGR)-SRC(I,IGR))*GAR2(I,IGR) + D2F(2,3)=D2F(2,3)-(GAR1(I,IGR)-SRC(I,IGR))*GAR3(I,IGR) + 280 CONTINUE + 285 CONTINUE + D2F(2,1)=D2F(1,2) + CALL ALSBD(2,1,D2F,IER,2) + IF(IER.NE.0) THEN + DCRIT=1.0E-6 + GO TO 270 + ENDIF + ALP=D2F(1,3) + BET=D2F(2,3)/ALP + IF((ALP.LT.1.0D0).AND.(ALP.GT.0.0D0)) THEN + ALP=1.0D0 + BET=0.0D0 + ELSE IF(ALP.LE.0.0D0) THEN + ISTART=M+1 + ALP=1.0D0 + BET=0.0D0 + ENDIF + ELSE +* ONE-PARAMETER ACCELERATION. + DO 295 IGR=1,NGR + DO 290 I=1,LL4 + D2F(1,1)=D2F(1,1)+GAR2(I,IGR)**2 + D2F(1,3)=D2F(1,3)-(GAR1(I,IGR)-SRC(I,IGR))*GAR2(I,IGR) + 290 CONTINUE + 295 CONTINUE + IF(D2F(1,1).NE.0.0D0) THEN + ALP=D2F(1,3)/D2F(1,1) + ELSE + ISTART=M+1 + ENDIF + ENDIF + DO 305 IGR=1,NGR + DO 300 I=1,LL4 + GRAD1(I,IGR)=REAL(ALP)*(GRAD1(I,IGR)+REAL(BET)*GRAD2(I,IGR)) + GAR2(I,IGR)=ALP*(GAR2(I,IGR)+BET*GAR3(I,IGR)) + 300 CONTINUE + 305 CONTINUE + ENDIF +* + LOGTES=(M.LT.ICL1).OR.(MOD(M-ISTART,ICL1+ICL2).EQ.ICL1-1) + IF(LOGTES) THEN + ALLOCATE(WORK4(LL4)) + DELT=0.0 + DO 350 IGR=1,NGR + WORK1(:LL4)=0.0 + WORK2(:LL4)=0.0 + DO 320 JGR=1,NGR + WRITE(TEXT12,'(1HB,2I3.3)') IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 320 + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,EVECT(1,JGR),WORK4) + DO 310 I=1,LL4 + WORK1(I)=WORK1(I)+WORK4(I) + 310 CONTINUE + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD1(1,JGR),WORK4) + DO 315 I=1,LL4 + WORK2(I)=WORK2(I)+WORK4(I) + 315 CONTINUE + 320 CONTINUE + DELN=0.0 + DELD=0.0 + DO 340 I=1,LL4 + EVECT(I,IGR)=EVECT(I,IGR)+GRAD1(I,IGR) + GAR1(I,IGR)=GAR1(I,IGR)+GAR2(I,IGR) + GRAD2(I,IGR)=GRAD1(I,IGR) + GAR3(I,IGR)=GAR2(I,IGR) + DELN=MAX(DELN,ABS(WORK2(I))) + DELD=MAX(DELD,ABS(WORK1(I))) + 340 CONTINUE + IF(DELD.NE.0.0) DELT=MAX(DELT,DELN/DELD) + 350 CONTINUE + DEALLOCATE(WORK4) + IF(IMPX.GE.2) WRITE (6,620) M,ALP,BET,DELT +* COMPUTE THE CONVERGENCE HISTOGRAM. + IF((IMPH.GE.1).AND.(M.LE.250)) THEN + LMPH=IMPH.GE.1 + CALL FLDXCO(IPKIN,LL4,NUN,EVECT(1,NGR),LMPH,ERR(M)) + ALPH(M)=REAL(ALP) + BETA(M)=REAL(BET) + ENDIF + IF(DELT.LT.EPS2) GO TO 370 + ELSE + DO 365 IGR=1,NGR + DO 360 I=1,LL4 + EVECT(I,IGR)=EVECT(I,IGR)+GRAD1(I,IGR) + GAR1(I,IGR)=GAR1(I,IGR)+GAR2(I,IGR) + GRAD2(I,IGR)=GRAD1(I,IGR) + GAR3(I,IGR)=GAR2(I,IGR) + 360 CONTINUE + 365 CONTINUE + IF(IMPX.GE.2) WRITE (6,620) M,ALP,BET +* COMPUTE THE CONVERGENCE HISTOGRAM. + IF((IMPH.GE.1).AND.(M.LE.250)) THEN + LMPH=IMPH.GE.1 + CALL FLDXCO(IPKIN,LL4,NUN,EVECT(1,NGR),LMPH,ERR(M)) + ALPH(M)=REAL(ALP) + BETA(M)=REAL(BET) + ENDIF + ENDIF + IF(M.EQ.1) TEST=DELT + IF((M.GT.30).AND.(DELT.GT.TEST)) CALL XABORT('KINSLB: CONVERGENC' + 1 //'E FAILURE.') + IF(M.GE.MIN(MAXX0,MMAXX)) THEN + WRITE (6,710) + GO TO 370 + ENDIF + GO TO 10 +*---- +* SOLUTION EDITION. +*---- + 370 IF(IMPX.EQ.1) WRITE (6,640) M + IF(IMPX.GE.3) THEN + DO 380 IGR=1,NGR + WRITE (6,690) IGR,(EVECT(I,IGR),I=1,LL4) + 380 CONTINUE + ENDIF + IF(IMPH.GE.2) THEN + IGRAPH=0 + 390 IGRAPH=IGRAPH+1 + WRITE (TEXT12,'(5HHISTO,I3)') IGRAPH + CALL LCMLEN (IPKIN,TEXT12,ILENG,ITYLCM) + IF(ILENG.EQ.0) THEN + MDIM=MIN(250,M) + READ (TITR,'(18A4)') ITITR + CALL LCMSIX (IPKIN,TEXT12,1) + CALL LCMPUT (IPKIN,'HTITLE',18,3,ITITR) + CALL LCMPUT (IPKIN,'ALPHA',MDIM,2,ALPH) + CALL LCMPUT (IPKIN,'BETA',MDIM,2,BETA) + CALL LCMPUT (IPKIN,'ERROR',MDIM,2,ERR) + CALL LCMPUT (IPKIN,'IMPH',1,1,IMPH) + CALL LCMSIX (IPKIN,' ',2) + ELSE + GO TO 390 + ENDIF + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(GRAD1,GRAD2,GAR1,GAR2,GAR3,WORK1,WORK2,WORK3) + RETURN +* + 600 FORMAT(1H1/50H KINSLB: ITERATIVE PROCEDURE BASED ON INVERSE POWE, + 1 8HR METHOD/9X,30HSPACE-TIME KINETICS EQUATIONS.) + 610 FORMAT(/11X,5HALPHA,3X,4HBETA,6X,8HACCURACY,12(1H.)) + 620 FORMAT(1X,I3,4X,2F8.3,1PE13.2) + 640 FORMAT(/23H KINSLB: CONVERGENCE IN,I4,12H ITERATIONS.) + 690 FORMAT(//52H KINSLB: SPACE-TIME KINETICS SOLUTION CORRESPONDING , + 1 12HTO THE GROUP,I4//(5X,1P,8E14.5)) + 710 FORMAT(/53H KINSLB: ***WARNING*** THE MAXIMUM NUMBER OF OUTER IT, + 1 20HERATIONS IS REACHED.) + END diff --git a/Trivac/src/KINSLT.f b/Trivac/src/KINSLT.f new file mode 100755 index 0000000..acde90b --- /dev/null +++ b/Trivac/src/KINSLT.f @@ -0,0 +1,521 @@ +*DECK KINSLT + SUBROUTINE KINSLT (IPTRK,IPSYS,IPKIN,LL4,ITY,NUN,NGR,IFL,IPR,IEXP, + 1 NBM,NBFIS,NDG,ICL1,ICL2,IMPX,IMPH,TITR,EPS2,MAXINR,EPSINR,NADI, + 2 ADJ,MAXX0,PDC,TTF,TTP,DT,OVR,CHI,CHD,SGF,SGD,OMEGA,EVECT,SRC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solution of the kinetics multigroup linear systems for the transient +* neutron fluxes in Trivac. Use the preconditioned power method with a +* two group SVAT acceleration technique. +* +*Copyright: +* Copyright (C) 2010 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK L_TRACK pointer to the tracking information. +* IPSYS L_SYSTEM pointer to system matrices. +* IPKIN L_KINET pointer to the KINET object. +* LL4 order of the system matrices. +* ITY type of solution (2: classical Trivac; 3: Thomas-Raviart, +* 13: Thomas-Raviart/SPN). +* NUN number of unknowns in each energy group. +* NGR number of energy groups. +* IFL integration scheme for fluxes: =1 implicit; +* =2 Crank-Nicholson; =3 theta. +* IPR integration scheme for precursors: =1 implicit; +* =2 Crank-Nicholson; =3 theta; =4 exponential. +* IEXP exponential transformation flag (=1 to activate). +* NBM number of material mixtures. +* NBFIS number of fissile isotopes. +* NDG number of delayed-neutron groups. +* ICL1 number of free iterations in one cycle of the inverse power +* method +* ICL2 number of accelerated iterations in one cycle +* IMPX print parameter. =0: no print ; =1: minimum printing ; +* =2: iteration history is printed. =3: solution is printed +* IMPH =0: no action is taken +* =1: the flux is compared to a reference flux stored on lcm +* =2: the convergence histogram is printed +* =3: the convergence histogram is printed with axis and +* titles. The plotting file is completed +* =4: the convergence histogram is printed with axis, acce- +* leration factors and titles. The plotting file is +* completed +* TITR character*72 title +* EPS2 convergence criteria for the flux +* MAXINR maximum number of thermal iterations. +* EPSINR thermal iteration epsilon. +* NADI number of inner adi iterations per outer iteration +* ADJ flag for adjoint space-time kinetics calculation +* MAXX0 maximum number of outer iterations +* PDC precursor decay constants. +* TTF value of theta-parameter for fluxes. +* TTP value of theta-parameter for precursors. +* DT current time increment. +* OVR reciprocal neutron velocities/DT. +* CHI steady-state fission spectrum. +* CHD delayed fission spectrum. +* SGF nu*fission macroscopic x-sections/keff. +* SGD delayed nu*fission macroscopic x-sections/keff. +* OMEGA exponential transformation parameter. +* SRC fixed source. +* +*Parameters: output +* EVECT converged solution +* +*References: +* A. H\'ebert, 'Preconditioning the power method for reactor +* calculations', Nucl. Sci. Eng., 94, 1 (1986). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER TITR*72 + TYPE(C_PTR) IPTRK,IPSYS,IPKIN + INTEGER LL4,ITY,NUN,NGR,IFL,IPR,IEXP,NBM,NBFIS,NDG,ICL1,ICL2,IMPX, + 1 IMPH,MAXINR,NADI,MAXX0 + REAL EPS2,EPSINR,PDC(NDG),TTF,TTP,DT,OVR(NBM,NGR), + 1 CHI(NBM,NBFIS,NGR),CHD(NBM,NBFIS,NGR,NDG),SGF(NBM,NBFIS,NGR), + 2 SGD(NBM,NBFIS,NGR,NDG),OMEGA(NBM,NGR),EVECT(NUN,NGR) + DOUBLE PRECISION SRC(NUN,NGR) + LOGICAL ADJ +*---- +* LOCAL VARIABLES +*---- + CHARACTER*12 TEXT12 + LOGICAL LOGTES,LMPH + DOUBLE PRECISION D2F(2,3),ALP,BET,DTF,DTP,DARG,DK + REAL ERR(250),ALPH(250),BETA(250),TKT,TKB + INTEGER ITITR(18) + REAL, DIMENSION(:,:), ALLOCATABLE :: GRAD1,GRAD2 + DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: GAR1,GAR2,GAR3 + REAL, DIMENSION(:), ALLOCATABLE :: WORK1,WORK2,WORK3 + REAL, DIMENSION(:), POINTER :: AGAR + TYPE(C_PTR) AGAR_PTR + DATA EPS1,MMAXX/1.0E-4,250/ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(GRAD1(NUN,NGR),GRAD2(NUN,NGR),GAR1(NUN,NGR), + 1 GAR2(NUN,NGR),GAR3(NUN,NGR),WORK1(LL4),WORK2(LL4),WORK3(NBM)) +* + CALL MTOPEN(IMPX,IPTRK,LL4) + IF(LL4.GT.NUN) CALL XABORT('KINSLT: INVALID NUMBER OF UNKNOWNS.') +*---- +* PRECONDITIONED POWER METHOD. +*---- + DTF=9999.0D0 + DTP=9999.0D0 + TEST=0.0 + IF(IFL.EQ.1)THEN + DTF=1.0D0 + ELSEIF(IFL.EQ.2)THEN + DTF=0.5D0 + ELSEIF(IFL.EQ.3)THEN + DTF=DBLE(TTF) + ENDIF + IF(IPR.EQ.2)THEN + DTP=0.5D0 + ELSEIF(IPR.EQ.3)THEN + DTP=DBLE(TTP) + ENDIF + DCRIT=MINVAL(DT*PDC(:)) +* + ISTART=1 + NNADI=NADI + IF(IMPX.GE.1) WRITE (6,600) NADI + IF(IMPX.GE.2) WRITE (6,610) + M=0 + 10 M=M+1 +* + DO 84 IGR=1,NGR + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,EVECT(1,IGR),WORK1) + DO 15 IND=1,LL4 + GAR1(IND,IGR)=DTF*WORK1(IND) + 15 CONTINUE + IF(IEXP.EQ.0) THEN + DO 16 IBM=1,NBM + WORK3(IBM)=OVR(IBM,IGR) + 16 CONTINUE + ELSE + DO 17 IBM=1,NBM + WORK3(IBM)=OVR(IBM,IGR)*(1.0+OMEGA(IBM,IGR)*DT) + 17 CONTINUE + ENDIF + CALL KINTLM(IPTRK,NBM,LL4,WORK3,EVECT(1,IGR),WORK1) + DO 20 IND=1,LL4 + GAR1(IND,IGR)=GAR1(IND,IGR)+WORK1(IND) + 20 CONTINUE + DO 83 JGR=1,NGR + IF(JGR.EQ.IGR) GO TO 40 + IF(.NOT.ADJ) THEN + WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR + ELSE + WRITE(TEXT12,'(1HA,2I3.3)') JGR,IGR + ENDIF + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 40 + IF(ITY.EQ.13) THEN + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,EVECT(1,JGR),WORK1) + DO 25 IND=1,LL4 + GAR1(IND,IGR)=GAR1(IND,IGR)-DTF*WORK1(IND) + 25 CONTINUE + ELSE + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ ILONG /)) + DO 30 IND=1,ILONG + GAR1(IND,IGR)=GAR1(IND,IGR)-DTF*AGAR(IND)*EVECT(IND,JGR) + 30 CONTINUE + ENDIF + 40 DO 82 IFIS=1,NBFIS + IF(.NOT.ADJ) THEN + DO 50 IBM=1,NBM + WORK3(IBM)=CHI(IBM,IFIS,IGR)*SGF(IBM,IFIS,JGR) + 50 CONTINUE + ELSE + DO 55 IBM=1,NBM + WORK3(IBM)=CHI(IBM,IFIS,JGR)*SGF(IBM,IFIS,IGR) + 55 CONTINUE + ENDIF + CALL KINTLM(IPTRK,NBM,LL4,WORK3,EVECT(1,JGR),WORK1) + DO 60 IND=1,LL4 + GAR1(IND,IGR)=GAR1(IND,IGR)-DTF*WORK1(IND) + 60 CONTINUE + DO 81 IDG=1,NDG + DARG=PDC(IDG)*DT + IF(IPR.EQ.1)THEN + DK=1.0D0/(1.0D0+DARG) + ELSEIF(IPR.EQ.4)THEN + DK=(1.0D0-DEXP(-DARG))/DARG + ELSE + DK=1.0D0/(1.0D0+DTP*DARG) + ENDIF + IF(.NOT.ADJ) THEN + DO 70 IBM=1,NBM + WORK3(IBM)=CHD(IBM,IFIS,IGR,IDG)*SGD(IBM,IFIS,JGR,IDG) + 70 CONTINUE + ELSE + DO 75 IBM=1,NBM + WORK3(IBM)=CHD(IBM,IFIS,JGR,IDG)*SGD(IBM,IFIS,IGR,IDG) + 75 CONTINUE + ENDIF + CALL KINTLM(IPTRK,NBM,LL4,WORK3,EVECT(1,JGR),WORK1) + DO 80 IND=1,LL4 + GAR1(IND,IGR)=GAR1(IND,IGR)+DTF*DK*WORK1(IND) + 80 CONTINUE + 81 CONTINUE + 82 CONTINUE + 83 CONTINUE + 84 CONTINUE +*---- +* DIRECTION EVALUATION. +*---- + DO 120 IGR=1,NGR + DO 90 IND=1,LL4 + GRAD1(IND,IGR)=REAL(SRC(IND,IGR)-GAR1(IND,IGR)) + 90 CONTINUE + DO 110 JGR=1,IGR-1 + IF(.NOT.ADJ) THEN + WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR + ELSE + WRITE(TEXT12,'(1HA,2I3.3)') JGR,IGR + ENDIF + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 110 + IF(ITY.EQ.13) THEN + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD1(1,JGR),WORK1) + DO 95 IND=1,LL4 + GRAD1(IND,IGR)=GRAD1(IND,IGR)+REAL(DTF)*WORK1(IND) + 95 CONTINUE + ELSE + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ ILONG /)) + DO 100 IND=1,ILONG + GRAD1(IND,IGR)=GRAD1(IND,IGR)+REAL(DTF)*AGAR(IND)*GRAD1(IND,JGR) + 100 CONTINUE + ENDIF + 110 CONTINUE +* + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL FLDADI(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD1(1,IGR),NNADI) + DO 115 IND=1,LL4 + GRAD1(IND,IGR)=GRAD1(IND,IGR)/REAL(DTF) + 115 CONTINUE + 120 CONTINUE +*---- +* PERFORM THERMAL (UP-SCATTERING) ITERATIONS +*---- + IF(MAXINR.GT.1) THEN + CALL FLDTHR(IPTRK,IPSYS,IPKIN,.FALSE.,LL4,ITY,NUN,NGR,ICL1, + 1 ICL2,IMPX,NNADI,0,MAXINR,EPSINR,ITER,TKT,TKB,GRAD1) + ENDIF +*---- +* EVALUATION OF THE DISPLACEMENT AND OF THE TWO ACCELERATION PARAMETERS +* ALP AND BET. +*---- + DO 204 IGR=1,NGR + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD1(1,IGR),WORK1) + DO 130 IND=1,LL4 + GAR2(IND,IGR)=DTF*WORK1(IND) + 130 CONTINUE + IF(IEXP.EQ.0) THEN + DO 135 IBM=1,NBM + WORK3(IBM)=OVR(IBM,IGR) + 135 CONTINUE + ELSE + DO 136 IBM=1,NBM + WORK3(IBM)=OVR(IBM,IGR)*(1.0+OMEGA(IBM,IGR)*DT) + 136 CONTINUE + ENDIF + CALL KINTLM(IPTRK,NBM,LL4,WORK3,GRAD1(1,IGR),WORK1) + DO 140 IND=1,LL4 + GAR2(IND,IGR)=GAR2(IND,IGR)+WORK1(IND) + 140 CONTINUE + DO 203 JGR=1,NGR + IF(JGR.EQ.IGR) GO TO 160 + IF(.NOT.ADJ) THEN + WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR + ELSE + WRITE(TEXT12,'(1HA,2I3.3)') JGR,IGR + ENDIF + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 160 + IF(ITY.EQ.13) THEN + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,GRAD1(1,JGR),WORK1) + DO 145 IND=1,LL4 + GAR2(IND,IGR)=GAR2(IND,IGR)-DTF*WORK1(IND) + 145 CONTINUE + ELSE + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ ILONG /)) + DO 150 IND=1,ILONG + GAR2(IND,IGR)=GAR2(IND,IGR)-DTF*AGAR(IND)*GRAD1(IND,JGR) + 150 CONTINUE + ENDIF + 160 DO 202 IFIS=1,NBFIS + IF(.NOT.ADJ) THEN + DO 170 IBM=1,NBM + WORK3(IBM)=CHI(IBM,IFIS,IGR)*SGF(IBM,IFIS,JGR) + 170 CONTINUE + ELSE + DO 175 IBM=1,NBM + WORK3(IBM)=CHI(IBM,IFIS,JGR)*SGF(IBM,IFIS,IGR) + 175 CONTINUE + ENDIF + CALL KINTLM(IPTRK,NBM,LL4,WORK3,GRAD1(1,JGR),WORK1) + DO 180 IND=1,LL4 + GAR2(IND,IGR)=GAR2(IND,IGR)-DTF*WORK1(IND) + 180 CONTINUE + DO 201 IDG=1,NDG + DARG=PDC(IDG)*DT + IF(IPR.EQ.1)THEN + DK=1.0D0/(1.0D0+DARG) + ELSEIF(IPR.EQ.4)THEN + DK=(1.0D0-DEXP(-DARG))/DARG + ELSE + DK=1.0D0/(1.0D0+DTP*DARG) + ENDIF + IF(.NOT.ADJ) THEN + DO 190 IBM=1,NBM + WORK3(IBM)=CHD(IBM,IFIS,IGR,IDG)*SGD(IBM,IFIS,JGR,IDG) + 190 CONTINUE + ELSE + DO 195 IBM=1,NBM + WORK3(IBM)=CHD(IBM,IFIS,JGR,IDG)*SGD(IBM,IFIS,IGR,IDG) + 195 CONTINUE + ENDIF + CALL KINTLM(IPTRK,NBM,LL4,WORK3,GRAD1(1,JGR),WORK1) + DO 200 IND=1,LL4 + GAR2(IND,IGR)=GAR2(IND,IGR)+DTF*DK*WORK1(IND) + 200 CONTINUE + 201 CONTINUE + 202 CONTINUE + 203 CONTINUE + 204 CONTINUE +* + 270 ALP=1.0D0 + BET=0.0D0 + D2F(:2,:3)=0.0D0 + IF(1+MOD(M-ISTART,ICL1+ICL2).GT.ICL1) THEN + IF(DCRIT.GT.1.0E-6) THEN +* TWO-PARAMETER ACCELERATION. SOLUTION OF A LINEAR SYSTEM. + DO 285 IGR=1,NGR + DO 280 I=1,LL4 + D2F(1,1)=D2F(1,1)+GAR2(I,IGR)**2 + D2F(1,2)=D2F(1,2)+GAR2(I,IGR)*GAR3(I,IGR) + D2F(2,2)=D2F(2,2)+GAR3(I,IGR)**2 + D2F(1,3)=D2F(1,3)-(GAR1(I,IGR)-SRC(I,IGR))*GAR2(I,IGR) + D2F(2,3)=D2F(2,3)-(GAR1(I,IGR)-SRC(I,IGR))*GAR3(I,IGR) + 280 CONTINUE + 285 CONTINUE + D2F(2,1)=D2F(1,2) + CALL ALSBD(2,1,D2F,IER,2) + IF(IER.NE.0) THEN + DCRIT=1.0E-6 + GO TO 270 + ENDIF + ALP=D2F(1,3) + BET=D2F(2,3)/ALP + IF((ALP.LT.1.0D0).AND.(ALP.GT.0.0D0)) THEN + ALP=1.0D0 + BET=0.0D0 + ELSE IF(ALP.LE.0.0D0) THEN + ISTART=M+1 + ALP=1.0D0 + BET=0.0D0 + ENDIF + ELSE +* ONE-PARAMETER ACCELERATION. + DO 295 IGR=1,NGR + DO 290 I=1,LL4 + D2F(1,1)=D2F(1,1)+GAR2(I,IGR)**2 + D2F(1,3)=D2F(1,3)-(GAR1(I,IGR)-SRC(I,IGR))*GAR2(I,IGR) + 290 CONTINUE + 295 CONTINUE + IF(D2F(1,1).NE.0.0D0) THEN + ALP=D2F(1,3)/D2F(1,1) + ELSE + ISTART=M+1 + ENDIF + ENDIF + DO 305 IGR=1,NGR + DO 300 I=1,LL4 + GRAD1(I,IGR)=REAL(ALP)*(GRAD1(I,IGR)+REAL(BET)*GRAD2(I,IGR)) + GAR2(I,IGR)=ALP*(GAR2(I,IGR)+BET*GAR3(I,IGR)) + 300 CONTINUE + 305 CONTINUE + ENDIF +* + LOGTES=(M.LT.ICL1).OR.(MOD(M-ISTART,ICL1+ICL2).EQ.ICL1-1) + IF(LOGTES) THEN + DELT=0.0 + DO 350 IGR=1,NGR + WORK1(:LL4)=0.0 + WORK2(:LL4)=0.0 + DO 320 JGR=1,NGR + IF(.NOT.ADJ) THEN + WRITE(TEXT12,'(1HB,2I3.3)') IGR,JGR + ELSE + WRITE(TEXT12,'(1HB,2I3.3)') JGR,IGR + ENDIF + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 320 + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ ILONG /)) + DO 310 I=1,ILONG + WORK1(I)=WORK1(I)+AGAR(I)*EVECT(I,JGR) + WORK2(I)=WORK2(I)+AGAR(I)*GRAD1(I,JGR) + 310 CONTINUE + 320 CONTINUE + DELN=0.0 + DELD=0.0 + DO 340 I=1,LL4 + EVECT(I,IGR)=EVECT(I,IGR)+GRAD1(I,IGR) + GAR1(I,IGR)=GAR1(I,IGR)+GAR2(I,IGR) + GRAD2(I,IGR)=GRAD1(I,IGR) + GAR3(I,IGR)=GAR2(I,IGR) + DELN=MAX(DELN,ABS(WORK2(I))) + DELD=MAX(DELD,ABS(WORK1(I))) + 340 CONTINUE + IF(DELD.NE.0.0) DELT=MAX(DELT,DELN/DELD) + 350 CONTINUE + IF(IMPX.GE.2) WRITE (6,620) M,ALP,BET,DELT +* COMPUTE THE CONVERGENCE HISTOGRAM. + IF((IMPH.GE.1).AND.(M.LE.250)) THEN + LMPH=IMPH.GE.1 + CALL FLDXCO(IPKIN,LL4,NUN,EVECT(1,NGR),LMPH,ERR(M)) + ALPH(M)=REAL(ALP) + BETA(M)=REAL(BET) + ENDIF + IF(DELT.LT.EPS2) GO TO 370 + ELSE + DO 365 IGR=1,NGR + DO 360 I=1,LL4 + EVECT(I,IGR)=EVECT(I,IGR)+GRAD1(I,IGR) + GAR1(I,IGR)=GAR1(I,IGR)+GAR2(I,IGR) + GRAD2(I,IGR)=GRAD1(I,IGR) + GAR3(I,IGR)=GAR2(I,IGR) + 360 CONTINUE + 365 CONTINUE + IF(IMPX.GE.2) WRITE (6,620) M,ALP,BET +* COMPUTE THE CONVERGENCE HISTOGRAM. + IF((IMPH.GE.1).AND.(M.LE.250)) THEN + LMPH=IMPH.GE.1 + CALL FLDXCO(IPKIN,LL4,NUN,EVECT(1,NGR),LMPH,ERR(M)) + ALPH(M)=REAL(ALP) + BETA(M)=REAL(BET) + ENDIF + ENDIF + IF(M.EQ.1) TEST=DELT + IF((M.GT.30).AND.(DELT.GT.TEST)) CALL XABORT('KINSLT: CONVERGENC' + 1 //'E FAILURE.') + IF(M.GE.MIN(MAXX0,MMAXX)) THEN + WRITE (6,710) + GO TO 370 + ENDIF + IF(MOD(M,36).EQ.0) THEN + ISTART=M+1 + NNADI=NNADI+1 + IF (IMPX.NE.0) WRITE (6,720) NNADI + ENDIF + GO TO 10 +*---- +* SOLUTION EDITION. +*---- + 370 IF(IMPX.EQ.1) WRITE (6,640) M + IF(IMPX.GE.3) THEN + DO 380 IGR=1,NGR + WRITE (6,690) IGR,(EVECT(I,IGR),I=1,LL4) + 380 CONTINUE + ENDIF + IF(IMPH.GE.2) THEN + IGRAPH=0 + 390 IGRAPH=IGRAPH+1 + WRITE (TEXT12,'(5HHISTO,I3)') IGRAPH + CALL LCMLEN (IPKIN,TEXT12,ILENG,ITYLCM) + IF(ILENG.EQ.0) THEN + MDIM=MIN(250,M) + READ (TITR,'(18A4)') ITITR + CALL LCMSIX (IPKIN,TEXT12,1) + CALL LCMPUT (IPKIN,'HTITLE',18,3,ITITR) + CALL LCMPUT (IPKIN,'ALPHA',MDIM,2,ALPH) + CALL LCMPUT (IPKIN,'BETA',MDIM,2,BETA) + CALL LCMPUT (IPKIN,'ERROR',MDIM,2,ERR) + CALL LCMPUT (IPKIN,'IMPH',1,1,IMPH) + CALL LCMSIX (IPKIN,' ',2) + ELSE + GO TO 390 + ENDIF + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(GRAD1,GRAD2,GAR1,GAR2,GAR3,WORK1,WORK2,WORK3) + RETURN +* + 600 FORMAT(1H1/50H KINSLT: ITERATIVE PROCEDURE BASED ON PRECONDITION, + 1 17HED POWER METHOD (,I2,37H ADI ITERATIONS PER OUTER ITERATION)./ + 2 9X,30HSPACE-TIME KINETICS EQUATIONS.) + 610 FORMAT(/11X,5HALPHA,3X,4HBETA,6X,8HACCURACY,12(1H.)) + 620 FORMAT(1X,I3,4X,2F8.3,1PE13.2) + 640 FORMAT(/23H KINSLT: CONVERGENCE IN,I4,12H ITERATIONS.) + 690 FORMAT(//52H KINSLT: SPACE-TIME KINETICS SOLUTION CORRESPONDING , + 1 12HTO THE GROUP,I4//(5X,1P,8E14.5)) + 710 FORMAT(/53H KINSLT: ***WARNING*** THE MAXIMUM NUMBER OF OUTER IT, + 1 20HERATIONS IS REACHED.) + 720 FORMAT(/53H KINSLT: INCREASING THE NUMBER OF INNER ITERATIONS TO, + 1 I3,36H ADI ITERATIONS PER OUTER ITERATION./) + END diff --git a/Trivac/src/KINSOL.f b/Trivac/src/KINSOL.f new file mode 100755 index 0000000..50b8b53 --- /dev/null +++ b/Trivac/src/KINSOL.f @@ -0,0 +1,162 @@ +*DECK KINSOL + SUBROUTINE KINSOL(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* solve the space-time neutron kinetics equations. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal. +* +*Author(s): D. Sekki +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1): modification type(L_KINET); +* HENTRY(2): read-only type(L_MACROLIB); +* HENTRY(3): read-only type(L_TRACK); +* HENTRY(4): read-only type(L_SYSTEM) made with HENTRY(2); +* HENTRY(5): optional read-only type(L_MACROLIB); +* HENTRY(6): optional read-only type(L_SYSTEM) made with +* HENTRY(5). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*Comments: +* The KINSOL: calling specifications are: +* KINET := KINSOL: KINET MACRO TRACK SYST [ MACRO\_0 SYST\_0 ] :: +* (kinsol\_data) ; +* where +* KINET : name of the \emph{lcm} object (type L\_KINET) in modification mode. +* MACRO : name of the \emph{lcm} object (type L\_MACROLIB) containing the +* \emph{macrolib} information corresponding to the current time step of a +* transient. +* TRACK : name of the \emph{lcm} object (type L\_TRACK) containing the +* \emph{tracking} information. +* SYST : name of the \emph{lcm} object (type L\_SYSTEM) corresponding to +* \emph{macrolib} MACRO and \emph{tracking} TRACK. +* MACRO\_0 : name of the \emph{lcm} object (type L\_MACROLIB) containing the +* \emph{macrolib} information corresponding to the beginning of step +* conditions in case a ramp variation of the cross sections in set. +* Beginning of step conditions should not be confused with beginning of +* transient or initial conditions.} By default, a step variation is set +* where cross sections are assumed constant and given by MACRO. +* SYST\_0 : name of the \emph{lcm} object (type L\_SYSTEM) corresponding to +* \emph{macrolib} MACRO\_0 and \emph{tracking} TRACK. +* kinsol\_data : structure containing the data to module KINSOL: +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 + TYPE(C_PTR) KENTRY(NENTRY) +*---- +* LOCAL VARIABLES +*---- + CHARACTER TEXT12*12,HSIGN*12,CMODUL*12,HSMG*131 +*---- +* PARAMETER VALIDATION +*---- + IF((NENTRY.NE.4).AND.(NENTRY.NE.6))CALL XABORT('@KINSOL:' + 1 //' INVALID NUMBER OF MODULE PARAMETERS.') + DO 10 IEN=1,NENTRY + IF((IENTRY(IEN).NE.1).AND.(IENTRY(IEN).NE.2)) + 1 CALL XABORT('@KINSOL: LCM OBJECTS EXPECTED.') + 10 CONTINUE +* L_KINET + CALL LCMGTC(KENTRY(1),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_KINET')THEN + TEXT12=HENTRY(1) + CALL XABORT('@KINSOL: SIGNATURE OF '//TEXT12//' IS ' + 1 //HSIGN//'. L_KINET EXPECTED.') + ENDIF + IF(JENTRY(1).NE.1)CALL XABORT('@KINSOL: L_KINET IN MODI' + 1 //'FICATION MODE EXPECTED.') + CALL LCMGTC(KENTRY(1),'TRACK-TYPE',12,CMODUL) +* L_MACROLIB(1) + CALL LCMGTC(KENTRY(2),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_MACROLIB')THEN + TEXT12=HENTRY(2) + CALL XABORT('@KINSOL: SIGNATURE OF '//TEXT12//' IS ' + 1 //HSIGN//'. L_MACROLIB EXPECTED(1).') + ENDIF + IF(JENTRY(2).NE.2)CALL XABORT('@KINSOL: L_MACROLIB IN R' + 1 //'EAD-ONLY MODE EXPECTED AT RHS(1).') +* L_TRACK + CALL LCMGTC(KENTRY(3),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_TRACK')THEN + TEXT12=HENTRY(3) + CALL XABORT('@KINSOL: SIGNATURE OF '//TEXT12//' IS ' + 1 //HSIGN//'. L_TRACK EXPECTED.') + ENDIF + IF(JENTRY(3).NE.2)CALL XABORT('@KINSOL: L_TRACK IN READ' + 1 //'-ONLY MODE EXPECTED AT RHS.') + CALL LCMGTC(KENTRY(3),'TRACK-TYPE',12,HSIGN) + IF(HSIGN.NE.CMODUL)CALL XABORT('@KINSOL: INVALID TRACKI' + 1 //'NG TYPE IN L_TRACK.') +* L_SYSTEM(1) + CALL LCMGTC(KENTRY(4),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_SYSTEM')THEN + TEXT12=HENTRY(4) + CALL XABORT('@KINSOL: SIGNATURE OF '//TEXT12//' IS ' + 1 //HSIGN//'. L_SYSTEM EXPECTED.') + ENDIF + IF(JENTRY(4).NE.2)CALL XABORT('@KINSOL: L_SYSTEM IN READ' + 1 //'-ONLY MODE EXPECTED AT RHS.') + CALL LCMGTC(KENTRY(4),'LINK.MACRO',12,TEXT12) + IF(HENTRY(2).NE.TEXT12) THEN + WRITE(HSMG,'(40H@KINSOL: INVALID MACROLIB OBJECT NAME ='', + 1 A12,18H'', EXPECTED NAME='',A12,2H''.)') HENTRY(2),TEXT12 + CALL XABORT(HSMG) + ENDIF + CALL LCMGTC(KENTRY(4),'LINK.TRACK',12,TEXT12) + IF(HENTRY(3).NE.TEXT12) THEN + WRITE(HSMG,'(40H@KINSOL: INVALID TRACKING OBJECT NAME ='',A12, + 1 18H'', EXPECTED NAME='',A12,2H''.)') HENTRY(3),TEXT12 + CALL XABORT(HSMG) + ENDIF + CALL LCMPTC(KENTRY(1),'LINK.TRACK',12,TEXT12) +* L_MACROLIB(2) + IF(NENTRY.EQ.6)THEN + CALL LCMGTC(KENTRY(5),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_MACROLIB')THEN + TEXT12=HENTRY(5) + CALL XABORT('@KINSOL: SIGNATURE OF '//TEXT12//' IS ' + 1 //HSIGN//'. L_MACROLIB EXPECTED(2).') + ENDIF + IF(JENTRY(5).NE.2)CALL XABORT('@KINSOL: L_MACROLIB IN' + 1 //' READ-ONLY MODE EXPECTED AT RHS(2).') +* L_SYSTEM(2) + CALL LCMGTC(KENTRY(6),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_SYSTEM')THEN + TEXT12=HENTRY(6) + CALL XABORT('@KINSOL: SIGNATURE OF '//TEXT12//' IS ' + 1 //HSIGN//'. L_SYSTEM EXPECTED.') + ENDIF + IF(JENTRY(6).NE.2)CALL XABORT('@KINSOL: L_SYSTEM IN READ' + 1 //'-ONLY MODE EXPECTED AT RHS.') + CALL LCMGTC(KENTRY(6),'LINK.TRACK',12,TEXT12) + IF(HENTRY(3).NE.TEXT12) THEN + WRITE(HSMG,'(40H@KINSOL: INVALID TRACKING OBJECT NAME ='', + 1 A12,18H'', EXPECTED NAME='',A12,2H''.)') HENTRY(3),TEXT12 + CALL XABORT(HSMG) + ENDIF + ENDIF +*---- +* READ THE INPUT DATA +*---- + CALL KINRD2(NENTRY,KENTRY,CMODUL) + RETURN + END diff --git a/Trivac/src/KINSRC.f b/Trivac/src/KINSRC.f new file mode 100755 index 0000000..1af7f00 --- /dev/null +++ b/Trivac/src/KINSRC.f @@ -0,0 +1,257 @@ +*DECK KINSRC + SUBROUTINE KINSRC(IPTRK,IPSYS,CMOD,IMPX,IFL,IPR,IEXP,NGR,NBM, + 1 NBFIS,NDG,ITY,LL4,NUN,NUP,PDC,TTF,TTP,DT,ADJ,OVR,CHI,CHD,SGF, + 2 SGD,OMEGA,EVECT,PC,SRC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the space-time kinetics source for a known neutron flux. +* +*Copyright: +* Copyright (C) 2010 Ecole Polytechnique de Montreal. +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK pointer to L_TRACK object. +* IPSYS pointer to L_SYSTEM object. +* CMOD name of the assembly door (BIVAC or TRIVAC). +* IMPX print parameter (equal to zero for no print). +* IFL integration scheme for fluxes: =1 implicit; +* =2 Crank-Nicholson; =3 theta. +* IPR integration scheme for precursors: =1 implicit; +* =2 Crank-Nicholson; =3 theta; =4 exponential. +* IEXP exponential transformation flag (=1 to activate). +* NGR number of energy groups. +* NBM number of material mixtures. +* NBFIS number of fissile isotopes. +* NDG number of delayed-neutron groups. +* ITY type of solution: =1: classical Bivac/diffusion; +* =2: classical Trivac/diffusion; =3 Raviart-Thomas in +* Trivac/diffusion; =11: Bivac/SPN; =13 Trivac/SPN. +* LL4 order of the system matrices. +* NUN total number of unknowns per energy group. +* NUP total number of precursor unknowns per precursor group. +* PDC precursor decay constants. +* TTF value of theta-parameter for fluxes. +* TTP value of theta-parameter for precursors. +* DT current time increment. +* ADJ flag for adjoint space-time kinetics calculation +* OVR reciprocal neutron velocities/DT. +* CHI steady-state fission spectrum. +* CHD delayed fission spectrum +* SGF nu*fission macroscopic x-sections/keff. +* SGD delayed nu*fission macroscopic x-sections/keff. +* OMEGA exponential transformation parameter. +* EVECT neutron flux. +* PC precursor concentrations. +* +*Parameters: output +* SRC space-time kinetics source. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPSYS + INTEGER IMPX,IFL,IPR,IEXP,NGR,NBM,NBFIS,NDG,ITY,LL4,NUN,NUP + REAL PDC(NDG),TTF,TTP,DT,OVR(NBM,NGR),CHI(NBM,NBFIS,NGR), + 1 CHD(NBM,NBFIS,NGR,NDG),SGF(NBM,NBFIS,NGR),SGD(NBM,NBFIS,NGR,NDG), + 2 OMEGA(NBM,NGR),EVECT(NUN,NGR),PC(NUP,NDG,NBFIS) + DOUBLE PRECISION SRC(NUN,NGR) + CHARACTER CMOD*12 + LOGICAL ADJ +*---- +* LOCAL VARIABLES +*---- + PARAMETER(IOS=6) + DOUBLE PRECISION DTF,DTP,DARG,DK,DSM + LOGICAL LFIS + CHARACTER TEXT12*12 + REAL, DIMENSION(:), ALLOCATABLE :: WORK1,WORK2,CHEXP + REAL, DIMENSION(:), POINTER :: AGAR + TYPE(C_PTR) AGAR_PTR +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(WORK1(LL4),WORK2(NBM),CHEXP(NBM)) +* + DTF=9999.0D0 + DTP=9999.0D0 + IF(IFL.EQ.1)THEN + DTF=1.0D0 + ELSEIF(IFL.EQ.2)THEN + DTF=0.5D0 + ELSEIF(IFL.EQ.3)THEN + DTF=DBLE(TTF) + ENDIF + IF(IPR.EQ.2)THEN + DTP=0.5D0 + ELSEIF(IPR.EQ.3)THEN + DTP=DBLE(TTP) + ENDIF +* + IF(IMPX.GT.0) WRITE(IOS,1001) CMOD + SRC(:NUN,:NGR)=0.0D0 + DO 200 IGR=1,NGR + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,EVECT(1,IGR),WORK1) + DO 10 IND=1,LL4 + SRC(IND,IGR)=-(1.0D0-DTF)*WORK1(IND) + 10 CONTINUE + DO 40 JGR=1,NGR + IF(JGR.EQ.IGR) GO TO 40 + IF(.NOT.ADJ) THEN + WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR + ELSE + WRITE(TEXT12,'(1HA,2I3.3)') JGR,IGR + ENDIF + CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM) + IF(ILONG.EQ.0) GO TO 40 + IF((CMOD.EQ.'BIVAC').OR.(ITY.EQ.13))THEN + CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,EVECT(1,JGR),WORK1) + DO 20 IND=1,LL4 + SRC(IND,IGR)=SRC(IND,IGR)+(1.0D0-DTF)*WORK1(IND) + 20 CONTINUE + ELSEIF(CMOD.EQ.'TRIVAC')THEN + CALL LCMGPD(IPSYS,TEXT12,AGAR_PTR) + CALL C_F_POINTER(AGAR_PTR,AGAR,(/ ILONG /)) + DO 30 IND=1,ILONG + SRC(IND,IGR)=SRC(IND,IGR)+(1.0D0-DTF)*AGAR(IND)*EVECT(IND,JGR) + 30 CONTINUE + ENDIF + 40 CONTINUE +*---- +* PRECURSOR CONTRIBUTION +*---- + DO 180 IFIS=1,NBFIS + DO 90 IDG=1,NDG + DARG=PDC(IDG)*DT + IF(IPR.EQ.1)THEN + DK=1.0D0/(1.0D0+DARG) + ELSEIF(IPR.EQ.4)THEN + DK=DEXP(-DARG) + ELSE + DK=(1.0D0-(1.0D0-DTP)*DARG)/(1.0D0+DTP*DARG) + ENDIF + DSM=1.0D0-DTF+DTF*DK + LFIS=.FALSE. + DO 50 IBM=1,NBM + LFIS=LFIS.OR.(CHD(IBM,IFIS,IGR,IDG).NE.0.0) + 50 CONTINUE + IF(LFIS) THEN + IF(.NOT.ADJ) THEN + DO 60 IBM=1,NBM + IF(IEXP.EQ.0) THEN + CHEXP(IBM)=CHD(IBM,IFIS,IGR,IDG) + ELSE +* exponential transformation + CHEXP(IBM)=CHD(IBM,IFIS,IGR,IDG)*EXP(-OMEGA(IBM,IGR)*DT) + ENDIF + 60 CONTINUE + ELSE + DO 70 IBM=1,NBM + IF(IEXP.EQ.0) THEN + CHEXP(IBM)=SGD(IBM,IFIS,IGR,IDG) + ELSE +* exponential transformation + CHEXP(IBM)=SGD(IBM,IFIS,IGR,IDG)*EXP(-OMEGA(IBM,IGR)*DT) + ENDIF + 70 CONTINUE + ENDIF + IF(CMOD.EQ.'BIVAC')THEN + CALL KINBLM(IPTRK,NBM,LL4,CHEXP(1),PC(1,IDG,IFIS),WORK1) + ELSEIF(CMOD.EQ.'TRIVAC')THEN + CALL KINTLM(IPTRK,NBM,LL4,CHEXP(1),PC(1,IDG,IFIS),WORK1) + ENDIF + DO 80 IND=1,LL4 + SRC(IND,IGR)=SRC(IND,IGR)+PDC(IDG)*DSM*WORK1(IND) + 80 CONTINUE + ENDIF + 90 CONTINUE +*---- +* FISSION CONTRIBUTION +*---- + DO 170 JGR=1,NGR + IF(.NOT.ADJ) THEN + DO 100 IBM=1,NBM + WORK2(IBM)=CHI(IBM,IFIS,IGR)*SGF(IBM,IFIS,JGR) + 100 CONTINUE + ELSE + DO 110 IBM=1,NBM + WORK2(IBM)=CHI(IBM,IFIS,JGR)*SGF(IBM,IFIS,IGR) + 110 CONTINUE + ENDIF + IF(CMOD.EQ.'BIVAC')THEN + CALL KINBLM(IPTRK,NBM,LL4,WORK2(1),EVECT(1,JGR),WORK1) + ELSEIF(CMOD.EQ.'TRIVAC')THEN + CALL KINTLM(IPTRK,NBM,LL4,WORK2(1),EVECT(1,JGR),WORK1) + ENDIF + DO 120 IND=1,LL4 + SRC(IND,IGR)=SRC(IND,IGR)+(1.0D0-DTF)*WORK1(IND) + 120 CONTINUE + DO 160 IDG=1,NDG + DARG=PDC(IDG)*DT + IF(IPR.EQ.1)THEN + DK=0.0D0 + ELSEIF(IPR.EQ.4)THEN + DK=(1.0D0-DEXP(-DARG))/DARG-DEXP(-DARG) + ELSE + DK=(1.0D0-DTP)*DARG/(1.0D0+DTP*DARG) + ENDIF + DSM=1.0D0-DTF-DTF*DK + IF(.NOT.ADJ) THEN + DO 130 IBM=1,NBM + WORK2(IBM)=CHD(IBM,IFIS,IGR,IDG)*SGD(IBM,IFIS,JGR,IDG) + 130 CONTINUE + ELSE + DO 140 IBM=1,NBM + WORK2(IBM)=CHD(IBM,IFIS,JGR,IDG)*SGD(IBM,IFIS,IGR,IDG) + 140 CONTINUE + ENDIF + IF(CMOD.EQ.'BIVAC')THEN + CALL KINBLM(IPTRK,NBM,LL4,WORK2(1),EVECT(1,JGR),WORK1) + ELSEIF(CMOD.EQ.'TRIVAC')THEN + CALL KINTLM(IPTRK,NBM,LL4,WORK2(1),EVECT(1,JGR),WORK1) + ENDIF + DO 150 IND=1,LL4 + SRC(IND,IGR)=SRC(IND,IGR)-DSM*WORK1(IND) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +*---- +* 1/V CONTRIBUTION +*---- + IF(CMOD.EQ.'BIVAC')THEN + CALL KINBLM(IPTRK,NBM,LL4,OVR(1,IGR),EVECT(1,IGR),WORK1) + ELSEIF(CMOD.EQ.'TRIVAC')THEN + CALL KINTLM(IPTRK,NBM,LL4,OVR(1,IGR),EVECT(1,IGR),WORK1) + ENDIF + DO 190 IND=1,LL4 + SRC(IND,IGR)=SRC(IND,IGR)+WORK1(IND) + 190 CONTINUE + 200 CONTINUE +*---- +* EDITION +*---- + IF(IMPX.GT.5) THEN + WRITE(IOS,1002) + DO 210 IGR=1,NGR + WRITE(IOS,1003) IGR,(SRC(IND,IGR),IND=1,LL4) + 210 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(CHEXP,WORK2,WORK1) + RETURN +* + 1001 FORMAT(/1X,'COMPUTING THE SPACE-TIME KINETICS SOURCE VECTOR', + 1 1X,'ACCORDING TO THE TRACKING TYPE: ',A6/) + 1002 FORMAT(/1X,'=> COMPUTED SPACE-TIME KINETICS SOURCE VECTOR') + 1003 FORMAT(/15H NEUTRON GROUP=,I5/(1P,8D14.5)) + END diff --git a/Trivac/src/KINST1.f b/Trivac/src/KINST1.f new file mode 100755 index 0000000..fb3f68e --- /dev/null +++ b/Trivac/src/KINST1.f @@ -0,0 +1,283 @@ +*DECK KINST1 + SUBROUTINE KINST1(NEN,KEN,CMOD,NGR,NBM,NBFIS,NDG,NEL,NUN,LL4,NUP, + 1 IDLPC,INORM,POWER,FNORM,DNF,DNS,PDC,LNUD,LCHD,IMPX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover the initial steady-state solution. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal. +* +*Author(s): D. Sekki +* +*Parameters: input/output +* NEN number of LCM objects used in the module. +* KEN addresses of LCM objects: (1) L_KINET; (2) L_MACROLIB; +* (3) L_TRACK; (4) L_SYSTEM; (5) L_FLUX. +* CMOD name of the assembly door (BIVAC or TRIVAC). +* NGR number of energy groups. +* NBM number of material mixtures. +* NBFIS number of fissile isotopes. +* NDG number of delayed-neutron groups. +* NEL total number of finite elements. +* NUN total number of unknowns per energy group. +* LL4 order of system matrices. +* NUP total number of precursor unknowns per precursor group. +* IDLPC position of averaged precursor values in unknown vector. +* INORM type of flux normalization (=0: no normalization; =1: imposed +* factor; =2: maximum flux; =3 initial power). +* POWER initial power (MW). +* FNORM normalization factor for the flux. +* DNF delayed neutron fractions. +* DNS delayed neutron spectrum (from input). +* PDC precursor decay constants. +* LNUD flag: =.true. if DNF provided from module input. +* LCHD flag: =.true. if DNS provided from module input. +* IMPX printing parameter (=0 for no print). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) KEN(NEN) + INTEGER NEN,NGR,NBM,NBFIS,NDG,NEL,NUN,LL4,NUP,IDLPC(NEL),INORM + CHARACTER CMOD*12 + REAL POWER,FNORM,DNS(NDG,NGR),PDC(NDG),DNF(NDG) + LOGICAL LNUD,LCHD +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40,IOS=6,ITR=0) + INTEGER ISTATE(NSTATE),MAT(NEL),IDL(NEL) + REAL VOL(NEL),PMAX(NDG,NBFIS) + TYPE(C_PTR) JPFLX + REAL, DIMENSION(:), ALLOCATABLE :: GAR,RM + REAL, DIMENSION(:,:), ALLOCATABLE :: EVECT,OVR + REAL, DIMENSION(:,:,:), ALLOCATABLE :: PC,CHI,SGF + REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: SGD,CHD +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(EVECT(NUN,NGR),PC(NUP,NDG,NBFIS),SGD(NBM,NBFIS,NGR,NDG)) +*---- +* RECOVER THE TYPE OF ASSEMBLY +*---- + ISTATE(:NSTATE)=0 + CALL LCMGET(KEN(4),'STATE-VECTOR',ISTATE) + ITY=ISTATE(4) +*---- +* RECOVER THE INITIAL FLUX UNKNOWN VECTOR +*---- + CALL LCMGET(KEN(3),'MATCOD',MAT) + CALL LCMGET(KEN(3),'VOLUME',VOL) + CALL LCMGET(KEN(3),'KEYFLX',IDL) + ISTATE(:NSTATE)=0 + CALL LCMGET(KEN(3),'STATE-VECTOR',ISTATE) + IGM=ISTATE(6) + IF(IMPX.GT.1) WRITE(IOS,1001) NUN + EVECT(:NUN,:NGR)=0.0 + CALL LCMGET(KEN(5),'K-EFFECTIVE',FKEFF) + JPFLX=LCMGID(KEN(5),'FLUX') + DO 10 IGR=1,NGR + CALL LCMGDL(JPFLX,IGR,EVECT(1,IGR)) + 10 CONTINUE +*---- +* FIND THE MAXIMUM FLUX VALUE +*---- + FMAX=0.0 + IDMX=0 + DO 25 IGR=1,NGR + DO 20 IEL=1,NEL + IND=IDL(IEL) + IF(IND.EQ.0) GO TO 20 + IF(ABS(EVECT(IND,IGR)).GT.FMAX) THEN + FMAX=EVECT(IND,IGR) + IDMX=IEL + IGMX=IGR + ENDIF + 20 CONTINUE + 25 CONTINUE + IF(IDMX.EQ.0) CALL XABORT('KINST1: UNABLE TO SET FMAX.') +*---- +* NORMALIZE THE FLUX +*---- + IF(INORM.EQ.2) THEN + FNORM=1.0/FMAX + ELSE IF(INORM.EQ.3) THEN + CALL KINPOW(KEN(2),NGR,NBM,NUN,NEL,MAT,VOL,IDL,EVECT,POWTOT) + IF(POWTOT.EQ.0.0) CALL XABORT('KINST1: H-FACTOR NOT DEFINED IN' + 1 //' MACROLIB.') + FNORM=POWER/POWTOT + CALL LCMPUT(KEN(1),'POWER-INI',1,2,POWER) + CALL LCMPUT(KEN(1),'E-POW',1,2,POWER) + IF(IMPX.GT.0) WRITE(6,*) 'INITIAL REACTOR POWER (MW) =',POWER + ENDIF + DO 35 IGR=1,NGR + DO 30 IND=1,NUN + EVECT(IND,IGR)=EVECT(IND,IGR)*FNORM + 30 CONTINUE + 35 CONTINUE + FMAX=FMAX*FNORM + IF(IMPX.GE.5)THEN + DO 40 IGR=1,NGR + WRITE(IOS,1003) IGR,(EVECT(I,IGR),I=1,NUN) + 40 CONTINUE + ENDIF +*---- +* RECOVER CROSS SECTIONS +*---- + ALLOCATE(OVR(NBM,NGR),CHI(NBM,NBFIS,NGR),CHD(NBM,NBFIS,NGR,NDG), + 1 SGF(NBM,NBFIS,NGR)) + DT=1.0 + CALL KINXSD(KEN(2),NGR,NBM,NBFIS,NDG,FKEFF,DT,DNF,DNS,LNUD,LCHD, + 1 OVR,CHI,CHD,SGF,SGD) + DEALLOCATE(SGF,CHD,CHI,OVR) +*---- +* INITIAL PRECURSOR UNKNOWN VECTOR +*---- + PC(:NUP,:NDG,:NBFIS)=0.0 + IF(IMPX.GT.1)WRITE(IOS,1005) + ALLOCATE(GAR(NUN)) + DO 95 IFIS=1,NBFIS + DO 90 IDG=1,NDG + IF(CMOD.EQ.'BIVAC')THEN + DO 55 IGR=1,NGR + CALL KINBLM(KEN(3),NBM,NUP,SGD(1,IFIS,IGR,IDG),EVECT(1,IGR), + 1 GAR) + DO 50 IND=1,NUP + PC(IND,IDG,IFIS)=PC(IND,IDG,IFIS)+GAR(IND) + 50 CONTINUE + 55 CONTINUE + CALL MTLDLS('RM',KEN(3),KEN(4),LL4,1,PC(1,IDG,IFIS)) + ELSEIF(CMOD.EQ.'TRIVAC')THEN + DO 65 IGR=1,NGR + CALL KINTLM(KEN(3),NBM,NUP,SGD(1,IFIS,IGR,IDG),EVECT(1,IGR), + 1 GAR) + DO 60 IND=1,NUP + PC(IND,IDG,IFIS)=PC(IND,IDG,IFIS)+GAR(IND) + 60 CONTINUE + 65 CONTINUE + CALL LCMLEN(KEN(4),'RM',ILONG,ITYLCM) + IF(IMPX.GT.2) CALL LCMLIB(KEN(4)) + ALLOCATE(RM(ILONG)) + CALL LCMGET(KEN(4),'RM',RM) + DO 70 IND=1,ILONG + FACT=RM(IND) + IF(FACT.EQ.0.0) CALL XABORT('KINST1: SINGULAR RM.') + PC(IND,IDG,IFIS)=PC(IND,IDG,IFIS)/FACT + 70 CONTINUE + DEALLOCATE(RM) + ENDIF + DO 80 IND=1,NUP + PC(IND,IDG,IFIS)=PC(IND,IDG,IFIS)/PDC(IDG) + 80 CONTINUE + IF(CMOD.EQ.'BIVAC')THEN + CALL FLDBIV(KEN(3),NEL,NUP,PC(1,IDG,IFIS),MAT,VOL,IDLPC) + ELSEIF(CMOD.EQ.'TRIVAC')THEN + CALL FLDTRI(KEN(3),NEL,NUP,PC(1,IDG,IFIS),MAT,VOL,IDLPC) + ENDIF + 90 CONTINUE + 95 CONTINUE + DEALLOCATE(GAR) + IF(IMPX.GT.5) THEN + WRITE(IOS,1006) + DO 105 IFIS=1,NBFIS + DO 100 IDG=1,NDG + WRITE(IOS,1007) IDG,IFIS,(PC(IND,IDG,IFIS),IND=1,LL4) + 100 CONTINUE + 105 CONTINUE + ENDIF +*---- +* FIND THE PRECURSOR CORRESPONDING TO MAXIMUM FLUX +*---- + IND=IDLPC(IDMX) + IF(IND.EQ.0) CALL XABORT('KINST1: UNABLE TO SET PMAX.') + DO 115 IFIS=1,NBFIS + DO 110 IDG=1,NDG + PMAX(IDG,IFIS)=PC(IND,IDG,IFIS) + 110 CONTINUE + 115 CONTINUE + IF(IMPX.GT.0) WRITE(IOS,1002) FMAX,IDMX,IGMX +*---- +* PRINT AVERAGED PRECURSOR VALUES +*---- + IF(IMPX.GT.1) THEN + DO 130 IFIS=1,NBFIS + WRITE(IOS,1008) IFIS,(IDG,IDG=1,NDG) + DO 120 IEL=1,NEL + IND=IDLPC(IEL) + WRITE(IOS,1009) IEL,(PC(IND,IDG,IFIS),IDG=1,NDG) + 120 CONTINUE + WRITE(IOS,'(/)') + 130 CONTINUE + ENDIF +*---- +* L_KINET STATE-VECTOR +*---- + ISTATE(:NSTATE)=0 + ISTATE(1)=ITR + ISTATE(2)=NDG + ISTATE(3)=NGR + ISTATE(4)=IGM + ISTATE(5)=NEL + ISTATE(6)=NUN + ISTATE(7)=LL4 + ISTATE(8)=NUP + ISTATE(9)=NBFIS + ISTATE(10)=ITY + ISTATE(13)=INORM + CALL LCMPUT(KEN(1),'STATE-VECTOR',NSTATE,1,ISTATE) + CALL LCMPUT(KEN(1),'E-IDLPC',NEL,1,IDLPC) + CALL LCMPUT(KEN(1),'E-VECTOR',NUN*NGR,2,EVECT) + CALL LCMPUT(KEN(1),'E-PREC',NUP*NDG*NBFIS,2,PC) + CALL LCMPUT(KEN(1),'E-KEFF',1,2,FKEFF) + CALL LCMPUT(KEN(1),'LAMBDA-D',NDG,2,PDC) + IF(LNUD) CALL LCMPUT(KEN(1),'BETA-D',NDG,2,DNF) + IF(LCHD) CALL LCMPUT(KEN(1),'CHI-D',NDG*NGR,2,DNS) + CALL LCMPUT(KEN(1),'CTRL-FLUX',1,2,FMAX) + CALL LCMPUT(KEN(1),'CTRL-PREC',NDG*NBFIS,2,PMAX) + CALL LCMPUT(KEN(1),'CTRL-IDL',1,1,IDMX) + CALL LCMPUT(KEN(1),'CTRL-IGR',1,1,IGMX) + IF(IMPX.GT.2) CALL LCMLIB(KEN(1)) + IF(IMPX.GE.1) WRITE (IOS,1010) IMPX,(ISTATE(I),I=1,10),ISTATE(13) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SGD,PC,EVECT) + RETURN +* + 1001 FORMAT(1X,'RECOVERING THE INITIAL UNKNOWN VECTOR', + 1 1X,'FOR FLUXES'/1X,'TOTAL NUMBER OF UNKNOWNS PE', + 2 'R',1X,'ENERGY GROUP',1X,I6/) + 1002 FORMAT(/1X,'CONTROLLING PARAMETERS:',2X,'MAX-VA', + 1 'L',1X,1PE12.5,3X,'IDL #',I5.5,3X,'IGR #',I2.2/) + 1003 FORMAT(/1X,'=> INITIAL UNKNOWN FLUX VECTOR CORR', + 1 'ESPONDING TO THE GROUP #',I2.2//(1P,8E14.5,5X)) + 1005 FORMAT(/1X,'COMPUTING THE INITIAL UNKNOWN VECTOR', + 1 1X,'FOR PRECURSORS'/) + 1006 FORMAT(/1X,'=> INITIAL PRECURSOR UNKNOWN VECTOR') + 1007 FORMAT(/17H PRECURSOR GROUP=,I5,18H FISSILE ISOTOPE=,I5/ + 1 (1P,8E14.5)) + 1008 FORMAT(/52H KINST1: AVERAGED PRECURSOR VALUES (FISSILE ISOTOPE=, + 1 I5,1H)/(9X,6I13,:)) + 1009 FORMAT(1X,I6,2X,1P,6E13.5,:/(9X,6E13.5,:)) + 1010 FORMAT(/8H OPTIONS/8H -------/ + 1 7H IMPX ,I6,30H (0=NO PRINT/1=SHORT/2=MORE)/ + 2 7H ITR ,I6,28H (CURRENT TIME SPEP INDEX)/ + 3 7H NDG ,I6,39H (NUMBER OF PRECURSOR DELAYED GROUPS)/ + 4 7H NGR ,I6,28H (NUMBER OF ENERGY GROUPS)/ + 5 7H IGM ,I6,21H (TYPE OF GEOMETRY)/ + 6 7H NEL ,I6,30H (NUMBER OF FINITE ELEMENTS)/ + 7 7H NUN ,I6,46H (TOTAL NUMBER OF UNKNOWNS PER ENERGY GROUP)/ + 8 7H LL4 ,I6,45H (NUMBER OF FLUX UNKNOWNS PER ENERGY GROUP)/ + 9 7H NUP ,I6,47H (NUMBER OF PRECURSORS UNKNOWNS PER DELAYED G, + 1 5HROUP)/ + 2 7H NBFIS ,I6,31H (NUMBER OF FISSILE ISOTOPES)/ + 3 7H ITY ,I6,28H (TYPE OF SYSTEM MATRICES)/ + 4 7H INORM ,I6,47H (0=NO FLUX NORMALIZATION/1=FIXED/2=MAXIMUM/3, + 5 7H=POWER)) + END diff --git a/Trivac/src/KINST2.f b/Trivac/src/KINST2.f new file mode 100755 index 0000000..2c43376 --- /dev/null +++ b/Trivac/src/KINST2.f @@ -0,0 +1,209 @@ +*DECK KINST2 + SUBROUTINE KINST2(NEN,KEN,CMOD,TTF,TTP,IFL,IPR,IEXP,DT,IMPH,ICL1, + 1 ICL2,NADI,ADJ,MAXOUT,EPSOUT,MAXINR,EPSINR,FNAM,PNAM,IMPX,POWTOT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover and validate the necessary information from the LCM objects. +* +*Copyright: +* Copyright (C) 2008 Ecole Polytechnique de Montreal. +* +*Author(s): D. Sekki +* +*Parameters: input +* NEN number of LCM objects used in the module. +* KEN addresses of LCM objects: (1) L_KINET; (2) L_MACROLIB; +* (3) L_TRACK; (4) L_SYSTEM; (5) L_MACROLIB. +* CMOD name of the assembly door (BIVAC or TRIVAC). +* TTF value of theta-parameter for fluxes. +* TTP value of theta-parameter for precursors. +* IFL temporal integration scheme for fluxes. +* IPR temporal integration scheme for precursors. +* IEXP exponential transformation flag (=1 to activate). +* DT current time increment. +* IMPH management of convergence histogram. +* ICL1 number of free iterations in one cycle of the inverse power +* method +* ICL2 number of accelerated iterations in one cycle +* NADI number of inner adi iterations per outer iteration +* ADJ flag for adjoint space-time kinetics calculation +* MAXOUT maximum number of outer iterations +* EPSOUT convergence criteria for the flux +* MAXINR maximum number of thermal iterations. +* EPSINR thermal iteration epsilon. +* FNAM name of temporal scheme for fluxes. +* PNAM name of temporal scheme for precursors. +* IMPX printing parameter (=0 for no print). +* +*Parameter: output +* POWTOT power. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NEN,IFL,IPR,IEXP,IMPH,ICL1,ICL2,NADI,MAXOUT,MAXINR,IMPX + TYPE(C_PTR) KEN(NEN) + REAL TTF,TTP,DT,EPSOUT,EPSINR,POWTOT + CHARACTER CMOD*12,FNAM*30,PNAM*30 + LOGICAL ADJ +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40,IOS=6) + INTEGER ISTATE(NSTATE) + REAL EPSCON(5) + CHARACTER TEXT*12,HSMG*131 +*---- +* L_MACROLIB STATE-VECTOR +*---- + ISTATE(:NSTATE)=0 + CALL LCMGET(KEN(2),'STATE-VECTOR',ISTATE) + NGR=ISTATE(1) + NBM=ISTATE(2) + NLS=ISTATE(3) + NBFIS=ISTATE(4) + IF(IMPX.GT.9)CALL LCMLIB(KEN(2)) + IF(NEN.EQ.6)THEN +* SECOND L_MACROLIB + ISTATE(:NSTATE)=0 + CALL LCMGET(KEN(5),'STATE-VECTOR',ISTATE) + IF(ISTATE(1).NE.NGR)CALL XABORT('@KINST2: FOUND DIFFERENT NUMB' + 1 //'ER OF ENERGY GROUPS IN MACROLIBS 1 AND 2.') + IF(ISTATE(2).NE.NBM)CALL XABORT('@KINST2: FOUND DIFFERENT NUMB' + 1 //'ER OF MATERIAL MIXTURES IN MACROLIBS 1 AND 2.') + IF(ISTATE(3).NE.NLS)CALL XABORT('@KINST2: FOUND DIFFERENT NUMB' + 1 //'ER OF LEGENDRE ORDERS IN MACROLIBS 1 AND 2.') + IF(ISTATE(4).NE.NBFIS)CALL XABORT('@KINST2: FOUND DIFFERENT NU' + 1 //'MBER OF FISSILE ISOTOPES IN MACROLIBS 1 AND 2.') + IF(IMPX.GT.9)CALL LCMLIB(KEN(5)) + ENDIF +*---- +* L_TRACK STATE-VECTOR +*---- + ISTATE(:NSTATE)=0 + CALL LCMGET(KEN(3),'STATE-VECTOR',ISTATE) + IF(ISTATE(4).GT.NBM) THEN + WRITE(HSMG,'(46H@KINST2: THE NUMBER OF MIXTURES IN THE TRACKIN, + 1 3HG (,I5,50H) IS GREATER THAN THE NUMBER OF MIXTURES IN THE MA, + 2 8HCROLIB (,I5,2H).)') ISTATE(4),NBM + CALL XABORT(HSMG) + ENDIF + NEL=ISTATE(1) + NUN=ISTATE(2) + IGM=ISTATE(6) + LL4=ISTATE(11) + NLF=-1 + ISPN=-1 + ISCAT=-1 + IF(CMOD.EQ.'TRIVAC') THEN + NLF=ISTATE(30) + ISPN=ISTATE(31) + ISCAT=ISTATE(32) + ELSE IF(CMOD.EQ.'BIVAC') THEN + NLF=ISTATE(14) + ISPN=ISTATE(15) + ISCAT=ISTATE(16) + ENDIF + IF((NLF.NE.0).AND.(ISPN.NE.1))CALL XABORT('@KINST2: ONLY SPN' + 1 //' DISCRETIZATIONS ARE ALLOWED.') + IF(IMPX.GT.9)CALL LCMLIB(KEN(3)) +*---- +* L_SYSTEM STATE-VECTOR +*---- + ISTATE(:NSTATE)=0 + CALL LCMGET(KEN(4),'STATE-VECTOR',ISTATE) + IF(ISTATE(1).NE.NGR)CALL XABORT('@KINST2: FOUND DIFFERENT NUMBER' + 1 //' OF ENERGY GROUPS IN L_MACROLIB AND L_SYSTEM OBJECTS.') + IF(ISTATE(2).NE.LL4)CALL XABORT('@KINST2: FOUND DIFFERENT NUMBER' + 1 //' OF UNKNOWNS PER GROUP IN L_MACROLIB AND L_SYSTEM OBJECTS.') + IF(ISTATE(7).NE.NBM)CALL XABORT('@KINST2: FOUND DIFFERENT NUMBER' + 1 //' OF MATERIAL MIXTURES IN L_MACROLIB AND L_SYSTEM OBJECTS.') + ITY=ISTATE(4) + IF(NEN.EQ.6)THEN +* SECOND L_SYSTEM + ISTATE(:NSTATE)=0 + CALL LCMGET(KEN(6),'STATE-VECTOR',ISTATE) + IF(ISTATE(1).NE.NGR)CALL XABORT('@KINST2: FOUND DIFFERENT NUMB' + 1 //'ER OF ENERGY GROUPS IN L_SYSTEM OBJECTS 1 AND 2.') + IF(ISTATE(2).NE.LL4)CALL XABORT('@KINST2: FOUND DIFFERENT NUMB' + 1 //'ER OF UNKNOWNS PER GROUP IN L_SYSTEM OBJECTS 1 AND 2.') + IF(ISTATE(4).NE.ITY)CALL XABORT('@KINST2: FOUND DIFFERENT DISC' + 1 //'RETIZATION TYPES IN L_SYSTEM OBJECTS 1 AND 2.') + IF(ISTATE(7).NE.NBM)CALL XABORT('@KINST2: FOUND DIFFERENT NUMB' + 1 //'ER OF MATERIAL MIXTURES IN L_SYSTEM OBJECTS 1 AND 2.') + IF(IMPX.GT.9)CALL LCMLIB(KEN(6)) + ENDIF +*---- +* L_KINET STATE-VECTOR +*---- + ISTATE(:NSTATE)=0 + CALL LCMGET(KEN(1),'STATE-VECTOR',ISTATE) + ITR=ISTATE(1) + NDG=ISTATE(2) + NUP=ISTATE(8) + INORM=ISTATE(13) + IF(ISTATE(3).NE.NGR)CALL XABORT('@KINST2: FOUND DIFFERENT NUM' + 1 //'BER OF ENERGY GROUPS IN L_MACROLIB AND IN L_KINET.') + IF(ISTATE(4).NE.IGM)CALL XABORT('@KINST2: INVALID L_TRACK(1).') + IF(ISTATE(5).NE.NEL)CALL XABORT('@KINST2: INVALID L_TRACK(2).') + IF(ISTATE(6).NE.NUN)CALL XABORT('@KINST2: INVALID L_TRACK(3).') + IF(ISTATE(7).NE.LL4)CALL XABORT('@KINST2: INVALID L_TRACK(4).') + IF(ISTATE(9).NE.NBFIS)CALL XABORT('@KINST2: INVALID L_TRACK(5).') + IF(ISTATE(10).NE.ITY)CALL XABORT('@KINST2: INVALID L_SYSTEM.') + ITR=ITR+1 + ISTATE(1)=ITR + ISTATE(11)=ICL1 + ISTATE(12)=ICL2 + ISTATE(14)=MAXINR + ISTATE(15)=MAXOUT + ISTATE(16)=NADI + ISTATE(17)=IFL + ISTATE(18)=IPR + ISTATE(19)=IEXP + IF(ADJ) ISTATE(20)=1 + CALL LCMPUT(KEN(1),'STATE-VECTOR',NSTATE,1,ISTATE) + EPSCON(1)=EPSINR + EPSCON(2)=EPSOUT + EPSCON(3)=TTF + EPSCON(4)=TTP + CALL LCMPUT(KEN(1),'EPS-CONVERGE',4,2,EPSCON) + IF(IMPX.GT.9)CALL LCMLIB(KEN(1)) +*---- +* PERFORM KINETICS CALCULATION +*---- + DTIM=0.0 + CALL LCMLEN(KEN(1),'TOTAL-TIME',LEN,ITLCM) + IF(LEN.NE.0) CALL LCMGET(KEN(1),'TOTAL-TIME',DTIM) + IF(.NOT.ADJ) THEN + DTIM=DTIM+DT + ELSE + DTIM=DTIM-DT + ENDIF + CALL LCMPUT(KEN(1),'TOTAL-TIME',1,2,DTIM) + CALL LCMPUT(KEN(1),'DELTA-T',1,2,DT) + IF(IMPX.GT.0) THEN + WRITE(IOS,1001)DT,DTIM + IF(ADJ) WRITE(IOS,'(28H ADJOINT SPACE-TIME KINETICS)') + TEXT=' TIME-STEP #' + WRITE(IOS,*)' CURRENT',TEXT,ITR + WRITE(IOS,1002) FNAM,PNAM + ENDIF + CALL KINDRV(NEN,KEN,CMOD,NGR,NBM,NBFIS,NDG,NLF,ITY,NEL,LL4,NUN, + 1 NUP,TTF,TTP,DT,IMPH,ICL1,ICL2,NADI,ADJ,MAXOUT,EPSOUT,MAXINR, + 2 EPSINR,IFL,IPR,IEXP,INORM,IMPX,POWTOT) + IF(IMPX.GT.3) CALL LCMLIB(KEN(1)) + RETURN +* + 1001 FORMAT(/1X,5('--o--',5X)//8X,'PERFORMING KINETICS', + 1 1X,'CALCULATION'/8X,31('-')//8X,'TIME',1X,'INCRE', + 2 'MENT',1X,'=',1X,1P,E11.4,1X,'SEC'/8X,'ELAPSED TI', + 3 'ME',3X,'=',1X,1P,E11.4,1X,'SEC') + 1002 FORMAT(/1X,5('--o--',5X)//1X,'TEMPORAL SCHEME FOR', + 1 1X,'FLUX',2X,'=>',2X,A30/1X,'TEMPORAL SCHEME FOR', + 2 1X,'PRECURSORS',2X,'=>',2X,A30/) + END diff --git a/Trivac/src/KINT01.f b/Trivac/src/KINT01.f new file mode 100755 index 0000000..59ae9b2 --- /dev/null +++ b/Trivac/src/KINT01.f @@ -0,0 +1,91 @@ +*DECK KINT01 + SUBROUTINE KINT01(MAXKN,SGD,CYLIND,NREG,LL4,NBMIX,XX,DD,MAT,KN, + 1 VOL,LC,T,TS,F2,F3) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Multiplication of a matrix by a vector in primal finite element +* diffusion approximation (Cartesian geometry). Special version for +* Trivac. +* +*Copyright: +* Copyright (C) 2010 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXKN dimension of array KN. +* SGD mixture-ordered cross sections. +* CYLIND cylinderization flag (=.true. for cylindrical geometry). +* NREG number of elements in TRIVAC. +* LL4 order of matrix SYS. +* NBMIX number of macro-mixtures. +* XX X-directed mesh spacings. +* DD value used with a cylindrical geometry. +* MAT mixture index per region. +* KN element-ordered unknown list. +* VOL volume of regions. +* LC number of polynomials in a complete 1-D basis. +* T Cartesian linear product vector. +* TS cylindrical linear product vector. +* F2 vector to multiply. +* +*Parameters: output +* F3 result of the multiplication. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MAXKN,NREG,LL4,NBMIX,MAT(NREG),KN(MAXKN),LC + REAL SGD(NBMIX),XX(NREG),DD(NREG),VOL(NREG),T(LC),TS(LC),F2(LL4), + 1 F3(LL4) + LOGICAL CYLIND +*---- +* LOCAL VARIABLES +*---- + REAL R3DP(125),R3DC(125) +*---- +* CALCULATION OF 3-D MASS MATRICES FROM TENSORIAL PRODUCT OF 1-D +* MATRICES +*---- + LL=LC*LC*LC + DO 20 L=1,LL + L1=1+MOD(L-1,LC) + L2=1+(L-L1)/LC + L3=1+MOD(L2-1,LC) + I1=L1 + I2=L3 + I3=1+(L2-L3)/LC + R3DP(L)=T(I1)*T(I2)*T(I3) + R3DC(L)=TS(I1)*T(I2)*T(I3) + 20 CONTINUE +*---- +* MULTIPLICATION. +*---- + NUM1=0 + DO 90 K=1,NREG + L=MAT(K) + IF(L.EQ.0) GO TO 90 + IF(VOL(K).EQ.0.0) GO TO 80 + DX=XX(K) + DO 50 I=1,LL + IND1=KN(NUM1+I) + IF(IND1.EQ.0) GO TO 50 + IF(CYLIND) THEN + RR=(R3DP(I)+R3DC(I)*DX/DD(K)) + ELSE + RR=R3DP(I) + ENDIF + F3(IND1)=F3(IND1)+RR*SGD(L)*VOL(K)*F2(IND1) + 50 CONTINUE + 80 NUM1=NUM1+LL + 90 CONTINUE + RETURN + END diff --git a/Trivac/src/KINT02.f b/Trivac/src/KINT02.f new file mode 100755 index 0000000..ffdc1c4 --- /dev/null +++ b/Trivac/src/KINT02.f @@ -0,0 +1,138 @@ +*DECK KINT02 + SUBROUTINE KINT02(MAXKN,SGD,IELEM,ICHX,IDIM,NREG,LL4,NBMIX,MAT, + 1 KN,VOL,F2,F3) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Multiplication of a matrix by a vector in mixed-dual finite element +* diffusion approximation (Cartesian geometry). Special version for +* Trivac. +* +*Copyright: +* Copyright (C) 2010 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXKN dimension of array KN. +* SGD mixture-ordered cross sections. +* IELEM degree of the Lagrangian finite elements: =1 (linear); +* =2 (parabolic); =3 (cubic); =4 (quartic). +* ICHX type of discretization method: +* =2: dual finite element approximations; +* =3: nodal collocation method with full tensorial products; +* =4: nodal collocation method with serendipity approximation. +* IDIM number of dimensions. +* NREG number of elements in Trivac. +* LL4 number of unknowns per group in Trivac. +* NBMIX number of macro-mixtures. +* MAT mixture index per region. +* KN element-ordered unknown list. +* VOL volume of regions. +* F2 vector to multiply. +* +*Parameters: output +* F3 result of the multiplication. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MAXKN,IELEM,ICHX,IDIM,NREG,LL4,NBMIX,MAT(NREG),KN(MAXKN) + REAL SGD(NBMIX),VOL(NREG),F2(LL4),F3(LL4) +*---- +* LOCAL VARIABLES +*---- + INTEGER, DIMENSION(:), ALLOCATABLE :: IGAR +* + IORD(J,K,L,LL,IEL,IW)=(IEL*L+K)*LL*IEL+(1+IEL*(IW-1))+J +* + IORL(J,K,L,LL,IEL,IW)= + 1 1+LL*(L*(IEL*(IEL+1))/2-(L*(L-1)*(3*IEL-L+2))/6 + 2 +K*(IEL-L)-(K*(K-1))/2)+(IEL-K-L)*(IW-1)+J +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IGAR(NREG)) +* + IF(ICHX.EQ.2) THEN +* DUAL FINITE ELEMENT METHOD. + NUM1=0 + DO 30 K=1,NREG + L=MAT(K) + IF(L.EQ.0) GO TO 30 + VOL0=VOL(K) + IF(VOL0.EQ.0.0) GO TO 20 + DO 12 K3=0,IELEM-1 + DO 11 K2=0,IELEM-1 + DO 10 K1=0,IELEM-1 + IND1=KN(NUM1+1)+(K3*IELEM+K2)*IELEM+K1 + F3(IND1)=F3(IND1)+VOL0*SGD(L)*F2(IND1) + 10 CONTINUE + 11 CONTINUE + 12 CONTINUE + 20 NUM1=NUM1+1+6*IELEM**2 + 30 CONTINUE + ELSE IF(ICHX.EQ.3) THEN +* NODAL COLLOCATION METHOD WITH FULL TENSORIAL PRODUCTS. + LNUN=0 + DO 40 K=1,NREG + IF(MAT(K).EQ.0) GO TO 40 + LNUN=LNUN+1 + IGAR(K)=LNUN + 40 CONTINUE +* + DO 70 K=1,NREG + L=MAT(K) + IF(L.EQ.0) GO TO 70 + VOL0=VOL(K) + IF(VOL0.EQ.0.0) GO TO 70 + DO 65 I3=0,IELEM-1 + DO 60 I2=0,IELEM-1 + DO 50 I1=0,IELEM-1 + INX1=IORD(I1,I2,I3,LNUN,IELEM,IGAR(K)) + F3(INX1)=F3(INX1)+VOL0*SGD(L)*F2(INX1) + 50 CONTINUE + IF((IDIM.EQ.1).AND.(I2.EQ.0)) GO TO 70 + IF((IDIM.EQ.2).AND.(I2.EQ.IELEM-1)) GO TO 70 + 60 CONTINUE + 65 CONTINUE + 70 CONTINUE + ELSE IF(ICHX.EQ.4) THEN +* NODAL COLLOCATION METHOD WITH SERENDIPITY APPROXIMATION. + LNUN=0 + DO 80 K=1,NREG + IF(MAT(K).EQ.0) GO TO 80 + LNUN=LNUN+1 + IGAR(K)=LNUN + 80 CONTINUE +* + DO 110 K=1,NREG + L=MAT(K) + IF(L.EQ.0) GO TO 110 + VOL0=VOL(K) + IF(VOL0.EQ.0.0) GO TO 110 + DO 105 I3=0,IELEM-1 + DO 100 I2=0,IELEM-1-I3 + DO 90 I1=0,IELEM-1-I2-I3 + INX1=IORL(I1,I2,I3,LNUN,IELEM,IGAR(K)) + F3(INX1)=F3(INX1)+VOL0*SGD(L)*F2(INX1) + 90 CONTINUE + IF((IDIM.EQ.1).AND.(I2.EQ.0)) GO TO 110 + IF((IDIM.EQ.2).AND.(I2.EQ.IELEM-1)) GO TO 110 + 100 CONTINUE + 105 CONTINUE + 110 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IGAR) + RETURN + END diff --git a/Trivac/src/KINT03.f b/Trivac/src/KINT03.f new file mode 100755 index 0000000..6229ce4 --- /dev/null +++ b/Trivac/src/KINT03.f @@ -0,0 +1,124 @@ +*DECK KINT03 + SUBROUTINE KINT03(MAXKN,ISPLH,NBMIX,NEL,LL4,SGD,SIDE,ZZ,VOL,MAT, + 1 KN,R,RH,RT,F2,F3) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Multiplication of a matrix by a vector in mesh-corner finite +* difference approximation (hexagonal geometry). Special version for +* Trivac. +* +*Copyright: +* Copyright (C) 2010 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* ISPLH type of mesh-splitting: =1 for complete hexagons; .gt.1 for +* triangle mesh-splitting. +* NBMIX number of material mixtures. +* NEL total number of finite elements. +* LL4 order of system matrices. +* SGD cross section per material mixture. +* SIDE dide of an hexagon. +* ZZ height of each hexagon. +* VOL volume of each element. +* MAT mixture index assigned to each element. +* KN element-ordered unknown list. +* R unit matrix. +* RH unit matrix. +* RT unit matrix. +* F2 vector to multiply. +* +*Parameters: output +* F3 result of the multiplication. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MAXKN,ISPLH,NBMIX,NEL,LL4,MAT(NEL),KN(MAXKN) + REAL SGD(NBMIX),SIDE,ZZ(NEL),VOL(NEL),R(2,2),RH(6,6),RT(3,3), + 1 F2(LL4),F3(LL4) +*---- +* LOCAL VARIABLES +*---- + INTEGER ILIEN(6,3),IJ17(14),IJ27(14),IJ16(12),IJ26(12),IJ1(14), + 1 IJ2(14) + REAL RH2(7,7) + DOUBLE PRECISION RR,VOL1,RTHG(14,14) + DATA ILIEN/6*4,2,1,5,6,7,3,1,5,6,7,3,2/ + DATA IJ16,IJ26 /1,2,3,4,5,6,1,2,3,4,5,6,6*1,6*2/ + DATA IJ17,IJ27 /1,2,3,4,5,6,7,1,2,3,4,5,6,7,7*1,7*2/ +*---- +* COMPUTE THE HEXAGONAL MASS (RH2). +*---- + IF(ISPLH.EQ.1) THEN + LC=6 + DO 20 I=1,2*LC + IJ1(I)=IJ16(I) + IJ2(I)=IJ26(I) + 20 CONTINUE + DO 41 I=1,LC + DO 40 J=1,LC + RH2(I,J)=RH(I,J) + 40 CONTINUE + 41 CONTINUE + ELSE + LC=7 + DO 60 I=1,2*LC + IJ1(I)=IJ17(I) + IJ2(I)=IJ27(I) + 60 CONTINUE + DO 76 I=1,LC + DO 75 J=1,LC + RH2(I,J)=0.0 + 75 CONTINUE + 76 CONTINUE + DO 82 K=1,6 + DO 81 I=1,3 + NUMI=ILIEN(K,I) + DO 80 J=1,3 + NUMJ=ILIEN(K,J) + RH2(NUMI,NUMJ)=RH2(NUMI,NUMJ)+RT(I,J) + 80 CONTINUE + 81 CONTINUE + 82 CONTINUE + ENDIF + LL=2*LC +*---- +* CALCULATION OF 3-D MASS AND STIFFNESS MATRICES FROM TENSORIAL PRODUCT +* OF 1-D AND 2-D MATRICES. +*---- + DO 91 I=1,LL + I1=IJ1(I) + I2=IJ2(I) + DO 90 J=1,LL + J1=IJ1(J) + J2=IJ2(J) + RTHG(I,J)=RH2(I1,J1)*R(I2,J2) + 90 CONTINUE + 91 CONTINUE +* + NUM1=0 + VOL1=SIDE*SIDE + DO 160 K=1,NEL + L=MAT(K) + IF(L.EQ.0) GO TO 160 + IF(VOL(K).EQ.0.0) GO TO 150 + DO 110 I=1,LL + INW1=KN(NUM1+I) + IF(INW1.EQ.0) GO TO 110 + RR=RTHG(I,I)*VOL1*ZZ(K) + F3(INW1)=F3(INW1)+REAL(RR)*SGD(L)*F2(INW1) + 110 CONTINUE + 150 NUM1=NUM1+LL + 160 CONTINUE + RETURN + END diff --git a/Trivac/src/KINT04.f b/Trivac/src/KINT04.f new file mode 100755 index 0000000..d293912 --- /dev/null +++ b/Trivac/src/KINT04.f @@ -0,0 +1,75 @@ +*DECK KINT04 + SUBROUTINE KINT04(IELEM,NBMIX,LL4F,NBLOS,MAT,SIDE,ZZ,FRZ,SGD,KN, + > IPERT,F2,F3) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Multiplication of a matrix by a vector in Thomas-Raviart-Schneider +* mixed-dual finite element approximation (hexagonal geometry). Special +* version for Trivac. +* +*Copyright: +* Copyright (C) 2010 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IELEM degree of the Lagrangian finite elements. +* NBMIX maximum number of material mixtures. +* LL4F total number of flux unknowns per group. +* NBLOS number of lozenges per direction, taking into account +* mesh-splitting. +* MAT mixture index assigned to each element. +* SIDE side of an hexagon. +* ZZ Z-directed mesh spacings. +* FRZ volume fractions for the axial SYME boundary condition. +* SGD cross section per material mixture. +* KN ADI permutation indices for the volumes. +* IPERT mixture permutation index. +* F2 vector to multiply. +* +*Parameters: output +* F3 result of the multiplication. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IELEM,NBMIX,LL4F,NBLOS,MAT(3,NBLOS),KN(NBLOS,3), + 1 IPERT(NBLOS) + REAL SIDE,ZZ(3,NBLOS),FRZ(NBLOS),SGD(NBMIX),F2(LL4F),F3(LL4F) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION TTTT,VOL0,SIG +* + TTTT=0.5D0*SQRT(3.D00)*SIDE*SIDE + NUM=0 + DO 20 KEL=1,NBLOS + IF(IPERT(KEL).EQ.0) GO TO 20 + NUM=NUM+1 + IBM=MAT(1,IPERT(KEL)) + IF(IBM.EQ.0) GO TO 20 + VOL0=TTTT*ZZ(1,IPERT(KEL))*FRZ(KEL) + SIG=SGD(IBM) + DO 12 K3=0,IELEM-1 + DO 11 K2=0,IELEM-1 + DO 10 K1=0,IELEM-1 + JND1=(NUM-1)*IELEM**3+K3*IELEM**2+K2*IELEM+K1+1 + JND2=(KN(NUM,1)-1)*IELEM**3+K3*IELEM**2+K2*IELEM+K1+1 + JND3=(KN(NUM,2)-1)*IELEM**3+K3*IELEM**2+K2*IELEM+K1+1 + F3(JND1)=F3(JND1)+REAL(VOL0*SIG)*F2(JND1) + F3(JND2)=F3(JND2)+REAL(VOL0*SIG)*F2(JND2) + F3(JND3)=F3(JND3)+REAL(VOL0*SIG)*F2(JND3) + 10 CONTINUE + 11 CONTINUE + 12 CONTINUE + 20 CONTINUE + RETURN + END diff --git a/Trivac/src/KINT05.f b/Trivac/src/KINT05.f new file mode 100755 index 0000000..775963d --- /dev/null +++ b/Trivac/src/KINT05.f @@ -0,0 +1,50 @@ +*DECK KINT05 + SUBROUTINE KINT05(NBMIX,NEL,LL4,SGD,VOL,MAT,F2,F3) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Multiplication of a matrix by a vector in mesh centered finite +* difference approximation (hexagonal geometry). Special version for +* Trivac. +* +*Copyright: +* Copyright (C) 2010 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NBMIX maximum number of material mixtures. +* NEL total number of finite elements. +* LL4 number of unknowns (order of the system matrices). +* SGD cross section per material mixture. +* VOL volumes. +* MAT index-number of the mixture type assigned to each volume. +* F2 vector to multiply. +* +*Parameters: output +* F3 result of the multiplication. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NBMIX,NEL,LL4,MAT(NEL) + REAL SGD(NBMIX),VOL(NEL),F2(LL4),F3(LL4) +* + KEL=0 + DO 10 K=1,NEL + L=MAT(K) + IF(L.EQ.0) GO TO 10 + KEL=KEL+1 + VOL0=VOL(K) + IF(VOL0.EQ.0.0) GO TO 10 + F3(KEL)=F3(KEL)+SGD(L)*VOL0*F2(KEL) + 10 CONTINUE + RETURN + END diff --git a/Trivac/src/KINT06.f b/Trivac/src/KINT06.f new file mode 100755 index 0000000..2e0377e --- /dev/null +++ b/Trivac/src/KINT06.f @@ -0,0 +1,74 @@ +*DECK KINT06 + SUBROUTINE KINT06(ISPLH,NBMIX,NEL,LL4,VOL,MAT,SGD,KN,IPW,F2,F3) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Multiplication of a matrix by a vector in mesh centered finite +* difference approximation (hexagonal geometry with triangular +* submeshes). Special version for Trivac. +* +*Copyright: +* Copyright (C) 2010 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* ISPLH related to the triangular submesh. The number of triangles is +* 6*(ISPLH-1)**2. +* NBMIX maximum number of material mixtures. +* NEL total number of finite elements. +* LL4 order of the system matrices. +* VOL volume of each element. +* MAT mixture index assigned to each hexagon. +* SGD nuclear properties per material mixtures. +* KN element-ordered unknown list. +* IPW permutation matrices. +* F2 vector to multiply. +* +*Parameters: output +* F3 result of the multiplication. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER ISPLH,NBMIX,NEL,LL4,MAT(NEL),KN(NEL*(18*(ISPLH-1)**2+8)), + 1 IPW(LL4) + REAL VOL(NEL),SGD(NBMIX),F2(LL4),F3(LL4) +*---- +* MULTIPLICATION +*---- + NUM1 = 0 + NTPH = 6 * (ISPLH-1)**2 + NTPL = 1 + 2 * (ISPLH-1) + NVT1 = NTPL + 2 * (ISPLH-2) + NTPH / 2 + NVT2 = NTPH - NTPL - (ISPLH-4) * (NTPL+2) + NVT3 = NTPH - (ISPLH-4) * NTPL + IVAL = 3*NTPH+8 + IF(ISPLH.EQ.3) NVT2 = NTPH + IF(ISPLH.LE.3) ISAU = 2*(ISPLH-2) + IF(ISPLH.GE.4) ISAU = 6*(ISPLH-3) + ICR = ISAU*(1+2*(ISPLH-2)) + DO 40 K=1,NEL + L = MAT(K) + IF(L.EQ.0) GO TO 40 + VOL0 = VOL(K)/NTPH + IF(VOL0.EQ.0.0) GO TO 30 + DO 20 I = 1,NTPH +* + CALL TRINEI (3,1,1,ISPLH,ICR,I,KK1,KK2,KK3,KEL,IQF,NUM1, + > NTPH,NTPL,NVT1,NVT2,NVT3,IVAL,KN) +* + IND1=IPW(KEL) + F3(IND1)=F3(IND1)+SGD(L)*VOL0*F2(IND1) + 20 CONTINUE + 30 NUM1=NUM1+IVAL + 40 CONTINUE + RETURN + END diff --git a/Trivac/src/KINTLM.f b/Trivac/src/KINTLM.f new file mode 100755 index 0000000..2f17b60 --- /dev/null +++ b/Trivac/src/KINTLM.f @@ -0,0 +1,138 @@ +*DECK KINTLM + SUBROUTINE KINTLM(IPTRK,NBM,LDIM,SGD,F2,F3) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Driver for the multiplication of a matrix by a vector. Special +* version for Trivac. +* +*Copyright: +* Copyright (C) 2010 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK L_TRACK pointer to the tracking information. +* NBM number of material mixtures. +* LDIM dimension of vectors F2 and F3. +* SGD mixture-ordered cross sections. +* F2 vector to multiply. +* +*Parameters: output +* F3 result of the multiplication. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK + INTEGER NBM,LDIM + REAL SGD(NBM),F2(LDIM),F3(LDIM) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + INTEGER ISTATE(NSTATE) + LOGICAL CYLIND,CHEX + INTEGER, DIMENSION(:), ALLOCATABLE :: MAT,KN,IPERT,IPW,XORZ,DD + REAL, DIMENSION(:), ALLOCATABLE :: VOL,T,TS,FRZ + REAL, DIMENSION(:,:), ALLOCATABLE :: R,RH,RT +*---- +* RECOVER TRACKING INFORMATION. +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + NREG=ISTATE(1) + NBMIX=ISTATE(4) + ITYPE=ISTATE(6) + CALL LCMLEN(IPTRK,'KN',MAXKN,ITYLCM) + ALLOCATE(MAT(NREG),VOL(NREG),KN(MAXKN)) + CALL LCMGET(IPTRK,'MATCOD',MAT) + CALL LCMGET(IPTRK,'VOLUME',VOL) + CALL LCMGET(IPTRK,'KN',KN) +*---- +* ALGORITHM-DEPENDENT MULTIPLICATION +*---- + F3(:LDIM)=0.0 + ITYPE=ISTATE(6) + IDIM=1 + IF((ITYPE.EQ.5).OR.(ITYPE.EQ.6).OR.(ITYPE.EQ.8)) IDIM=2 + IF((ITYPE.EQ.7).OR.(ITYPE.EQ.9)) IDIM=3 + CYLIND=(ITYPE.EQ.3).OR.(ITYPE.EQ.6) + CHEX=(ITYPE.EQ.8).OR.(ITYPE.EQ.9) + IHEX=ISTATE(7) + IELEM=ISTATE(9) + ICOL=ISTATE(10) + LL4=ISTATE(11) + ICHX=ISTATE(12) + IF(ICHX.EQ.2) LL4=ISTATE(25) + ISPLH=ISTATE(13) + LX=ISTATE(14) + LY=ISTATE(15) + LZ=ISTATE(16) + NVD=ISTATE(34) + IF(LL4.GT.LDIM) CALL XABORT('KINTLM: LDIM OVERFLOW.') + ALLOCATE(XORZ(LX*LY*LZ),DD(LX*LY*LZ)) + IF(CHEX) THEN + CALL LCMGET(IPTRK,'ZZ',XORZ) + CALL LCMGET(IPTRK,'SIDE',SIDE) + ELSE + CALL LCMGET(IPTRK,'XX',XORZ) + CALL LCMGET(IPTRK,'DD',DD) + ENDIF + IF((.NOT.CHEX).AND.(ICHX.EQ.1)) THEN +* --- MIXED-PRIMAL FINITE ELEMENTS (CARTESIAN) + CALL LCMSIX(IPTRK,'BIVCOL',1) + CALL LCMLEN(IPTRK,'T',LC,ITYLCM) + ALLOCATE(T(LC),TS(LC)) + CALL LCMGET(IPTRK,'T',T) + CALL LCMGET(IPTRK,'TS',TS) + CALL LCMSIX(IPTRK,' ',2) + CALL KINT01(MAXKN,SGD,CYLIND,NREG,LL4,NBMIX,XORZ,DD,MAT,KN,VOL, + 1 LC,T,TS,F2,F3) + DEALLOCATE(TS,T) + ELSEIF((.NOT.CHEX).AND.(ICHX.GE.2)) THEN +* --- DUAL FINITE ELEMENTS (CARTESIAN) + CALL KINT02(MAXKN,SGD,IELEM,ICHX,IDIM,NREG,LL4,NBMIX,MAT,KN, + 1 VOL,F2,F3) + ELSEIF(CHEX.AND.(ICHX.EQ.1)) THEN +* --- MESH CORNER FINITE DIFFERENCES (HEXAGONAL) + ALLOCATE(R(2,2),RH(6,6),RT(3,3)) + CALL LCMSIX(IPTRK,'BIVCOL',1) + CALL LCMGET(IPTRK,'R',R) + CALL LCMGET(IPTRK,'RH',RH) + CALL LCMGET(IPTRK,'RT',RT) + CALL LCMSIX(IPTRK,' ',2) + CALL KINT03(MAXKN,ISPLH,NBMIX,NREG,LL4,SGD,SIDE,XORZ,VOL,MAT, + 1 KN,R,RH,RT,F2,F3) + DEALLOCATE(RT,RH,R) + ELSEIF(CHEX.AND.(ICHX.EQ.2)) THEN +* --- DUAL (THOMAS-RAVIART-SCHNEIDER) FINITE ELEMENT METHOD. + NBLOS=LX*LZ/3 + ALLOCATE(IPERT(NBLOS),FRZ(NBLOS)) + CALL LCMGET(IPTRK,'IPERT',IPERT) + CALL LCMGET(IPTRK,'FRZ',FRZ) + CALL KINT04(IELEM,NBMIX,LL4,NBLOS,MAT,SIDE,XORZ,FRZ,SGD,KN, + 1 IPERT,F2,F3) + DEALLOCATE(FRZ,IPERT) + ELSE IF(CHEX.AND.(ICHX.EQ.3).AND.(ISPLH.EQ.1)) THEN +* --- MESH CENTERED FINITE DIFFERENCES (HEXAGONAL) + CALL KINT05(NBMIX,NREG,LL4,SGD,VOL,MAT,F2,F3) + ELSE IF(CHEX.AND.(ICHX.EQ.3).AND.(ISPLH.GT.1)) THEN +* --- MESH CENTERED FINITE DIFFERENCES (HEXAGONAL) + ALLOCATE(IPW(LL4)) + CALL LCMGET(IPTRK,'IPW',IPW) + CALL KINT06(ISPLH,NBMIX,NREG,LL4,VOL,MAT,SGD,KN,IPW,F2,F3) + DEALLOCATE(IPW) + ELSE + CALL XABORT('KINTLM: TRACKING NOT AVAILABLE.') + ENDIF + DEALLOCATE(DD,XORZ,KN,VOL,MAT) + RETURN + END diff --git a/Trivac/src/KINXSD.f b/Trivac/src/KINXSD.f new file mode 100755 index 0000000..a84f39a --- /dev/null +++ b/Trivac/src/KINXSD.f @@ -0,0 +1,172 @@ +*DECK KINXSD + SUBROUTINE KINXSD(IPMAC,NGR,NBM,NBFIS,NDG,EVL,DT,DNF,DNS,LNUD, + 1 LCHD,OVR,CHI,CHD,SGF,SGD) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover the 1/v and fission properties from L_MACROLIB which will be +* used for assembling source and kinetics matrix systems. +* +*Copyright: +* Copyright (C) 2010 Ecole Polytechnique de Montreal. +* +*Author(s): A. Hebert +* +*Parameters: input +* IPMAC pointer to L_MACROLIB object. +* NGR number of energy groups. +* NBM number of material mixtures. +* NBFIS number of fissile isotopes. +* NDG number of delayed-neutron groups. +* EVL steady-state eigenvalue. +* DNF delayed neutron fractions (from module input). +* DNS delayed neutron spectrum (from module input). +* LNUD flag: =.true. if DNF provided from module input. +* LCHD flag: =.true. if DNS provided from module input. +* +*Parameters: output +* OVR reciprocal neutron velocities/DT. +* CHI steady-state fission spectrum. +* CHD delayed fission spectrum +* SGF nu*fission macroscopic x-sections/keff. +* SGD delayed nu*fission macroscopic x-sections/keff. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMAC + INTEGER NGR,NBM,NBFIS,NDG + REAL EVL,DT,DNF(NDG),DNS(NDG,NGR),OVR(NBM,NGR),CHI(NBM,NBFIS,NGR), + 1 CHD(NBM,NBFIS,NGR,NDG),SGF(NBM,NBFIS,NGR),SGD(NBM,NBFIS,NGR,NDG) + LOGICAL LNUD,LCHD +*---- +* LOCAL VARIABLES (AUTOMATIC ALLOCATION) +*---- + LOGICAL LFIS,LFISD + CHARACTER TEXT12*12 + TYPE(C_PTR) JPMAC,KPMAC +*---- +* PROCESS FISSION SPECTRUM TERMS. +*---- + CHI(:NBM,:NBFIS,:NGR)=0.0 + CHD(:NBM,:NBFIS,:NGR,:NDG)=0.0 + SGF(:NBM,:NBFIS,:NGR)=0.0 + SGD(:NBM,:NBFIS,:NGR,:NDG)=0.0 + JPMAC=LCMGID(IPMAC,'GROUP') + KPMAC=LCMGIL(JPMAC,1) + CALL LCMLEN(KPMAC,'CHI',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + IF(LENGT.NE.NBM*NBFIS) CALL XABORT('@KINXSD: INVALID LENGTH FO' + 1 //'R CHI INFORMATION.') + DO 10 IGR=1,NGR + KPMAC=LCMGIL(JPMAC,IGR) + CALL LCMGET(KPMAC,'CHI',CHI(1,1,IGR)) + 10 CONTINUE + ELSE + DO 22 IBM=1,NBM + DO 21 IFIS=1,NBFIS + CHI(IBM,IFIS,1)=1.0 + DO 20 IGR=2,NGR + CHI(IBM,IFIS,IGR)=0.0 + 20 CONTINUE + 21 CONTINUE + 22 CONTINUE + ENDIF + IF(LCHD) THEN + DO 33 IDEL=1,NDG + DO 32 IGR=1,NGR + DO 31 IFIS=1,NBFIS + DO 30 IBM=1,NBM + CHD(IBM,IFIS,IGR,IDEL)=DNS(IDEL,IGR) + 30 CONTINUE + 31 CONTINUE + 32 CONTINUE + 33 CONTINUE + ELSE + KPMAC=LCMGIL(JPMAC,1) + CALL LCMLEN(KPMAC,'CHI01',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + IF(LENGT.NE.NBM*NBFIS) CALL XABORT('@KINXSD: INVALID LENGTH ' + 1 //'FOR DELAYED CHI INFORMATION.') + DO 42 IDEL=1,NDG + WRITE(TEXT12,'(3HCHI,I2.2)') IDEL + DO 40 IGR=1,NGR + KPMAC=LCMGIL(JPMAC,IGR) + CALL LCMGET(KPMAC,TEXT12,CHD(1,1,IGR,IDEL)) + 40 CONTINUE + 42 CONTINUE + ELSE + CHD(:NBM,:NBFIS,:NGR,:NDG)=0.0 + ENDIF + ENDIF + LFIS=.FALSE. + LFISD=.FALSE. + DO 52 IGR=1,NGR + DO 51 IFIS=1,NBFIS + DO 50 IBM=1,NBM + LFIS=LFIS.OR.(CHI(IBM,IFIS,IGR).NE.0.0) + LFISD=LFISD.OR.(CHD(IBM,IFIS,IGR,1).NE.0.0) + 50 CONTINUE + 51 CONTINUE + 52 CONTINUE +* + DO 85 IGR=1,NGR + KPMAC=LCMGIL(JPMAC,IGR) +*---- +* PROCESS FISSION NUSIGF TERMS. +*---- + IF(LFIS) THEN + CALL LCMLEN(KPMAC,'NUSIGF',LENGT,ITYLCM) + IF(LENGT.NE.NBM*NBFIS) CALL XABORT('@KINXSD: INVALID LENGTH FO' + 1 //'R NUSIGF INFORMATION.') + IF(LENGT.GT.0) CALL LCMGET(KPMAC,'NUSIGF',SGF(1,1,IGR)) + ENDIF + IF(LNUD) THEN + DO 62 IDEL=1,NDG + DO 61 IFIS=1,NBFIS + DO 60 IBM=1,NBM + SGD(IBM,IFIS,IGR,IDEL)=SGF(IBM,IFIS,IGR)*DNF(IDEL) + 60 CONTINUE + 61 CONTINUE + 62 CONTINUE + ELSE IF(LFISD) THEN + DO 70 IDEL=1,NDG + WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL + CALL LCMLEN(KPMAC,TEXT12,LENGT,ITYLCM) + IF(LENGT.NE.NBM*NBFIS) CALL XABORT('@KINXSD: INVALID LENGTH FO' + 1 //'R DELAYED NUSIGF INFORMATION.') + IF(LENGT.GT.0) CALL LCMGET(KPMAC,TEXT12,SGD(1,1,IGR,IDEL)) + 70 CONTINUE + ENDIF +*---- +* PROCESS 1/V TERMS. +*---- + CALL LCMLEN(KPMAC,'OVERV',LENGT,ITYLCM) + IF(LENGT.EQ.NBM)THEN + CALL LCMGET(KPMAC,'OVERV',OVR(1,IGR)) + ELSEIF(LENGT.EQ.0)THEN + CALL XABORT('@KINXSD: MISSING OVERV DATA.') + ELSE + CALL XABORT('@KINXSD: INVALID OVERV DATA.') + ENDIF + DO 80 IBM=1,NBM + OVR(IBM,IGR)=OVR(IBM,IGR)/DT + 80 CONTINUE + 85 CONTINUE +* + DO 93 IGR=1,NGR + DO 92 IFIS=1,NBFIS + DO 91 IBM=1,NBM + SGF(IBM,IFIS,IGR)=SGF(IBM,IFIS,IGR)/EVL + DO 90 IDEL=1,NDG + SGD(IBM,IFIS,IGR,IDEL)=SGD(IBM,IFIS,IGR,IDEL)/EVL + 90 CONTINUE + 91 CONTINUE + 92 CONTINUE + 93 CONTINUE + RETURN + END diff --git a/Trivac/src/KTRDRV.f b/Trivac/src/KTRDRV.f new file mode 100755 index 0000000..f957fb1 --- /dev/null +++ b/Trivac/src/KTRDRV.f @@ -0,0 +1,116 @@ +*DECK KTRDRV + INTEGER FUNCTION KTRDRV(HMODUL,NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Code dependent operator driver for TRIVAC. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* HMODUL name of the operator. +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file. +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*Parameters: output +* KTRDRV completion flag (=0: operator HMODUL exists; =1: does not +* exists). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER HMODUL*(*),HENTRY(NENTRY)*12 + INTEGER IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) +*---- +* LOCAL VARIABLES +*---- + REAL TBEG,TEND + DOUBLE PRECISION DMEMB,DMEMD + LOGICAL :: TRIMOD +* + KTRDRV=0 + TRIMOD=.TRUE. + CALL KDRCPU(TBEG) + CALL KDRMEM(DMEMB) + IF(HMODUL.EQ.'BIVACA:') THEN + WRITE(6,'(//7H EXEC: ,A,4H BY ,A)') HMODUL,'A. HEBERT' + CALL BIVACA(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'BIVACT:') THEN + WRITE(6,'(//7H EXEC: ,A,4H BY ,A)') HMODUL,'A. HEBERT' + CALL BIVACT(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'FLUD:') THEN + WRITE(6,'(//7H EXEC: ,A,4H BY ,A)') HMODUL,'A. HEBERT' + CALL FLD(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'GEO:') THEN + WRITE(6,'(//7H EXEC: ,A,4H BY ,A)') HMODUL,'A. HEBERT' + CALL GEOD(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'MAC:') THEN + WRITE(6,'(//7H EXEC: ,A,4H BY ,A)') HMODUL,'A. HEBERT' + CALL MACD(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'TRIVAT:') THEN + WRITE(6,'(//7H EXEC: ,A,4H BY ,A)') HMODUL,'A. HEBERT' + CALL TRIVAT(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'TRIVAA:') THEN + WRITE(6,'(//7H EXEC: ,A,4H BY ,A)') HMODUL,'A. HEBERT' + CALL TRIVAA(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'OUT:') THEN + WRITE(6,'(//7H EXEC: ,A,4H BY ,A)') HMODUL,'A. HEBERT' + CALL OUT(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'ERROR:') THEN + WRITE(6,'(//7H EXEC: ,A,4H BY ,A)') HMODUL,'A. HEBERT' + CALL ERROR(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'DELTA:') THEN + WRITE(6,'(//7H EXEC: ,A,4H BY ,A)') HMODUL,'A. HEBERT' + CALL DELTA(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'GPTFLU:') THEN + WRITE(6,'(//7H EXEC: ,A,4H BY ,A)') HMODUL,'A. HEBERT' + CALL GPTFLU(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'INIKIN:') THEN + WRITE(6,'(//7H EXEC: ,A,4H BY ,A)') HMODUL,'D. SEKKI' + CALL KININI(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'KINSOL:') THEN + WRITE(6,'(//7H EXEC: ,A,4H BY ,A)') HMODUL,'D. SEKKI' + CALL KINSOL(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'VAL:') THEN + WRITE(6,'(//7H EXEC: ,A,4H BY ,A)') HMODUL,'R. CHAMBON' + CALL VAL(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'NSST:') THEN + WRITE(6,'(//7H EXEC: ,A,4H BY ,A)') HMODUL,'A. HEBERT' + CALL NSST(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE IF(HMODUL.EQ.'NSSF:') THEN + WRITE(6,'(//7H EXEC: ,A,4H BY ,A)') HMODUL,'A. HEBERT' + CALL NSSF(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ELSE + TRIMOD=.FALSE. + KTRDRV=GANDRV(HMODUL,NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) + ENDIF + IF(TRIMOD)THEN + CALL KDRCPU(TEND) + CALL KDRMEM(DMEMD) + WRITE(6,5000) HMODUL,(TEND-TBEG),REAL(DMEMD-DMEMB) + ENDIF + RETURN +* + 5000 FORMAT('-->>MODULE ',A12,': TIME SPENT=',F13.3,' MEMORY USAGE=', + 1 1P,E10.3) + END diff --git a/Trivac/src/MACD.f b/Trivac/src/MACD.f new file mode 100755 index 0000000..b9ce53b --- /dev/null +++ b/Trivac/src/MACD.f @@ -0,0 +1,216 @@ +*DECK MACD + SUBROUTINE MACD(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Macroscopic cross sections and diffusion coefficients input module. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1) : create or modification type(L_MACROLIB). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + CHARACTER TEXT4*4,TEXT12*12,HSMG*131,HSIGN*12 + DOUBLE PRECISION DFLOTT + INTEGER IPAR(NSTATE) + TYPE(C_PTR) IPLIST + REAL, DIMENSION(:,:), ALLOCATABLE :: ALBP +*---- +* PARAMETER VALIDATION. +*---- + IF(NENTRY.EQ.0) CALL XABORT('MACD: PARAMETER EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('MACD: LCM' + 1 //' OBJECT EXPECTED AT LHS.') + IF((JENTRY(1).NE.0).AND.(JENTRY(1).NE.1)) CALL XABORT('MACD: ENT' + 1 //'RY IN CREATE OR MODIFICATION MODE EXPECTED.') + ITYPE=JENTRY(1) + IPLIST=KENTRY(1) +*---- +* READ THE INPUT DATA. +*---- +* DEFAULT OPTIONS: + IND=1 + IMPX=1 + ISTEP=0 + IF(ITYPE.EQ.0) THEN + NL=1 + NGRP=0 + NMIXT=0 + NIFISS=1 + NDG=0 + NALBP=0 + NSTEP=0 + IF(NENTRY.EQ.2) THEN + IF((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2)) CALL XABORT('MACD' + 1 //': LCM OBJECT EXPECTED AT RHS.') + IF(JENTRY(2).NE.2) CALL XABORT('MACD: RHS ENTRY IN READ-ONL' + 1 //'Y MODE EXPECTED.') + CALL LCMEQU(KENTRY(2),IPLIST) + IND=2 + ENDIF + ELSE IF(ITYPE.EQ.1) THEN + IND=2 + ENDIF + IF(IND.EQ.2) THEN + CALL LCMGTC(IPLIST,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_MACROLIB') THEN + TEXT12=HENTRY(1) + CALL XABORT('MACD: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_MACROLIB EXPECTED.') + ENDIF + IND=2 + CALL LCMGET(IPLIST,'STATE-VECTOR',IPAR) + NGRP=IPAR(1) + NMIXT=IPAR(2) + NL=IPAR(3) + NIFISS=IPAR(4) + NDG=IPAR(7) + NALBP=IPAR(8) + NSTEP=IPAR(11) + ENDIF +*---- +* READ THE MAC: MODULE OPTIONS. +*---- + 10 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('MACD: CHARACTER DATA EXPECTED(1).') + 20 IF(TEXT4.EQ.'EDIT') THEN +* READ THE PRINT INDEX. + CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('MACD: INTEGER DATA EXPECTED(1).') + ELSE IF(TEXT4.EQ.'NGRO') THEN +* READ THE NUMBER OF ENERGY GROUPS. + IF(IND.EQ.2) CALL XABORT('MACD: NGRO IS ALREADY DEFINED.') + CALL REDGET(INDIC,NGRP,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('MACD: INTEGER DATA EXPECTED(2).') + ELSE IF(TEXT4.EQ.'NMIX') THEN +* READ THE MAXIMUM NUMBER OF MATERIAL MIXTURES. + IF(IND.EQ.2) CALL XABORT('MACD: NMIX IS ALREADY DEFINED.') + CALL REDGET(INDIC,NMIXT,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('MACD: INTEGER DATA EXPECTED(3).') + ELSE IF(TEXT4.EQ.'DELP') THEN +* READ THE MAXIMUM NUMBER OF PRECURSORS. + IF(IND.EQ.2) CALL XABORT('MACD: DELP IS ALREADY DEFINED.') + CALL REDGET(INDIC,NDG,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('MACD: INTEGER DATA EXPECTED(3).') + ELSE IF(TEXT4.EQ.'ANIS') THEN +* READ THE SCATTERING ANISOTROPY FOR TRANSPORT THEORY CASES. + IF(IND.EQ.2) CALL XABORT('MACD: NMIX IS ALREADY DEFINED.') + CALL REDGET(INDIC,NL,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('MACD: INTEGER DATA EXPECTED(4).') + ELSE IF(TEXT4.EQ.'NIFI') THEN +* READ THE NUMBER OF FISSILE ISOTOPES + IF(IND.EQ.2) CALL XABORT('MACD: NIFISS IS ALREADY DEFINED.') + CALL REDGET(INDIC,NIFISS,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('MACD: INTEGER DATA EXPECTED(5).') + ELSE IF(TEXT4.EQ.'ALBP') THEN +* READ GROUP-INDEPENDENT PHYSICAL ALBEDOS + CALL REDGET(INDIC,NALBP,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('MACD: INTEGER DATA EXPECTED(6).') + IF(NALBP.GT.0) THEN + ALLOCATE(ALBP(NALBP,NGRP)) + DO IAL=1,NALBP + DO IGR=1,NGRP + CALL REDGET(INDIC,NITMA,ALBP(IAL,IGR),TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('MACD: REAL DATA EXPECTED.') + ENDDO + ENDDO + CALL LCMPUT(IPLIST,'ALBEDO',NALBP*NGRP,2,ALBP) + DEALLOCATE(ALBP) + ELSE + CALL XABORT('MACD: INVALID NUMBER OF ALBEDOS.') + ENDIF + IF(ITYPE.EQ.1) THEN + CALL LCMGET(IPLIST,'STATE-VECTOR',IPAR) + IPAR(8)=NALBP + CALL LCMPUT(IPLIST,'STATE-VECTOR',NSTATE,1,IPAR) + ENDIF + ELSE IF(TEXT4.EQ.'STEP') THEN +* STEP TO A SON DIRECTORY AND WRITE PERTURBATION VALUES. + CALL REDGET(INDIC,ISTEP,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('MACD: INTEGER DATA EXPECTED(7).') + WRITE(TEXT12,'(4HSTEP,I8)') ISTEP + IF(IND.EQ.1) THEN + CALL LCMLEN(IPLIST,TEXT12,ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + WRITE(HSMG,'(30HMACD: PERTURBATION DIRECTORY '',A12, + 1 21H'' ALREADY EXISTS IN '',A12,2H''.)') TEXT12,HENTRY(1) + CALL XABORT(HSMG) + ENDIF + ENDIF + NSTEP=MAX(NSTEP,ISTEP) + CALL LCMSIX(IPLIST,TEXT12,1) + IF(IMPX.GT.0) WRITE(6,'(/34H MACD: WRITE PERTURBATION VALUES O, + 1 13HN DIRECTORY '',A12,6H'' OF '',A12,2H''.)') TEXT12,HENTRY(1) + ELSE IF(TEXT4.EQ.'READ') THEN +* INPUT NON-PERTURBED OR PERTURBED DIFFUSION COEFFICIENTS AND +* CROSS SECTIONS PER MIXTURE. + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF((INDIC.NE.3).OR.(TEXT4.NE.'INPU')) CALL XABORT('MACD: INPU' + 1 //'T KEYWORD EXPECTED.') + CALL MACXSI(IPLIST,IND,NMIXT,NGRP,NDG,NL,IMPX,NBMIX,JND) + IF(ISTEP.GT.0) THEN + IF(IMPX.GT.1) CALL LCMLIB(IPLIST) + CALL LCMSIX(IPLIST,' ',2) + ENDIF + IF(JND.EQ.1) THEN + GO TO 40 + ELSE IF(JND.EQ.2) THEN + TEXT4='STEP' + GO TO 20 + ENDIF + ELSE IF(TEXT4.EQ.';') THEN + GO TO 40 + ELSE + CALL XABORT('MACD: '//TEXT4//' IS AN INVALID KEY-WORD.') + ENDIF + GO TO 10 +* + 40 IF(ITYPE.EQ.0) THEN + HSIGN='L_MACROLIB' + CALL LCMPTC(IPLIST,'SIGNATURE',12,HSIGN) + IPAR(:NSTATE)=0 + IPAR(1)=NGRP + IPAR(2)=NMIXT + IPAR(3)=NL + IPAR(4)=NIFISS + IPAR(5)=0 + IPAR(6)=0 + IPAR(7)=NDG + IPAR(8)=NALBP + IPAR(11)=NSTEP + CALL LCMPUT(IPLIST,'STATE-VECTOR',NSTATE,1,IPAR) + ENDIF + IF(IMPX.GT.1) CALL LCMLIB(IPLIST) + RETURN + END diff --git a/Trivac/src/MACXSI.f b/Trivac/src/MACXSI.f new file mode 100755 index 0000000..6cfac6a --- /dev/null +++ b/Trivac/src/MACXSI.f @@ -0,0 +1,354 @@ +*DECK MACXSI + SUBROUTINE MACXSI (IPLIST,IND,NMIXT,NGRP,NDG,NL,IMPX,NBMIX,JND) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Input macroscopic cross sections in Trivac. +* +*Copyright: +* Copyright (C) 2007 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPLIST LCM pointer to the macrolib. +* IND =1: the macrolib is created; +* =2: an existing macrolib is modified. +* NMIXT maximum number of material mixtures. +* NGRP number of energy groups. +* NDG number of delayed precursor groups. +* NL number of Legendre orders (=1 for isotropic scattering). +* IMPX print level. +* +*Parameters: output +* NBMIX number of mixtures. +* JND REDGET flag (=1 ';' encountered; =2 'STEP' encountered). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIST + INTEGER IND,NMIXT,NGRP,NDG,NL,IMPX,NBMIX,JND +*---- +* LOCAL VARIABLES +*---- + LOGICAL LTO,LT1,LFI,LCH,LOV,LD,LDX,LDY,LDZ,LHF,LSC,LSO,LDI,LBI + DOUBLE PRECISION DFLOTT + CHARACTER CM*2,TEXT4*4,TEXT8*8,TEXT*8 + TYPE(C_PTR) JPLIST,KPLIST + REAL, DIMENSION(:), ALLOCATABLE :: WORK + REAL, DIMENSION(:,:), ALLOCATABLE :: TOTAL,TOTA1,ZNUG,CHI,OVERV, + 1 DIFFX,DIFFY,DIFFZ,H,S + REAL, DIMENSION(:,:,:), ALLOCATABLE :: NUSDL,CHDL + REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: SCAT + INTEGER, DIMENSION(:), ALLOCATABLE :: IPOS + INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: IJJ,NJJ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(TOTAL(NMIXT,NGRP),TOTA1(NMIXT,NGRP),ZNUG(NMIXT,NGRP), + 1 CHI(NMIXT,NGRP),NUSDL(NMIXT,NDG,NGRP),CHDL(NMIXT,NDG,NGRP), + 2 OVERV(NMIXT,NGRP),DIFFX(NMIXT,NGRP),DIFFY(NMIXT,NGRP), + 3 DIFFZ(NMIXT,NGRP),H(NMIXT,NGRP),S(NMIXT,NGRP), + 4 SCAT(NMIXT,NL,NGRP,NGRP),WORK(NMIXT*NGRP)) + ALLOCATE(IJJ(NMIXT,NL,NGRP),NJJ(NMIXT,NL,NGRP),IPOS(NMIXT)) +* + IF(NMIXT.EQ.0) CALL XABORT('MACXSI: ZERO NUMBER OF MIXTURES.') + IF(NGRP.EQ.0) CALL XABORT('MACXSI: ZERO NUMBER OF GROUPS.') + NBMIX=0 + LTO=.FALSE. + LT1=.FALSE. + LFI=.FALSE. + LCH=.FALSE. + LOV=.FALSE. + LD=.FALSE. + LDX=.FALSE. + LDY=.FALSE. + LDZ=.FALSE. + LHF=.FALSE. + LSC=.FALSE. + LSO=.FALSE. + LDI=.FALSE. + LBI=.FALSE. + DO 13 IGR=1,NGRP + DO 12 IBM=1,NMIXT + TOTAL(IBM,IGR)=0.0 + TOTA1(IBM,IGR)=0.0 + ZNUG(IBM,IGR)=0.0 + CHI(IBM,IGR)=0.0 + DIFFX(IBM,IGR)=0.0 + DIFFY(IBM,IGR)=0.0 + DIFFZ(IBM,IGR)=0.0 + H(IBM,IGR)=0.0 + S(IBM,IGR)=0.0 + DO 11 IL=1,NL + IJJ(IBM,IL,IGR)=IGR + NJJ(IBM,IL,IGR)=1 + DO 10 JGR=1,NGRP + SCAT(IBM,IL,JGR,IGR)=0.0 + 10 CONTINUE + 11 CONTINUE + 12 CONTINUE + 13 CONTINUE + IF(IND.EQ.2) THEN +* RECOVER THE EXISTING MACROLIB DATA. + JPLIST=LCMLID(IPLIST,'GROUP',NGRP) + DO 40 JGR=1,NGRP + KPLIST=LCMDIL(JPLIST,JGR) + CALL LCMLEN(KPLIST,'NTOT0',ILENGT,ITYLCM) + IF(ILENGT.EQ.NMIXT) THEN + CALL LCMGET(KPLIST,'NTOT0',TOTAL(1,JGR)) + ELSE IF(ILENGT.NE.0) THEN + CALL XABORT('MACXSI: INVALID INPUT MACROLIB(1).') + ENDIF + CALL LCMLEN(KPLIST,'NTOT1',ILENGT,ITYLCM) + IF(ILENGT.EQ.NMIXT) CALL LCMGET(KPLIST,'NTOT1',TOTA1(1,JGR)) + CALL LCMLEN(KPLIST,'NUSIGF',ILENGT,ITYLCM) + IF(ILENGT.EQ.NMIXT) CALL LCMGET(KPLIST,'NUSIGF',ZNUG(1,JGR)) + CALL LCMLEN(KPLIST,'CHI',ILENGT,ITYLCM) + IF(ILENGT.EQ.NMIXT) CALL LCMGET(KPLIST,'CHI',CHI(1,JGR)) + DO 900 I=1,NDG + WRITE(TEXT,'(A6,I2.2)') 'NUSIGF',I + CALL LCMLEN(KPLIST,TEXT,ILENGT,ITYLCM) + IF(ILENGT.EQ.NMIXT) CALL LCMGET(KPLIST,TEXT,NUSDL(1,I,JGR)) + WRITE(TEXT,'(A3,I2.2)') 'CHI',I + CALL LCMLEN(KPLIST,TEXT,ILENGT,ITYLCM) + IF(ILENGT.EQ.NMIXT) CALL LCMGET(KPLIST,TEXT,CHDL(1,I,JGR)) + 900 CONTINUE + CALL LCMLEN(KPLIST,'OVERV',ILENGT,ITYLCM) + IF(ILENGT.EQ.NMIXT) CALL LCMGET(KPLIST,'OVERV',OVERV(1,JGR)) + CALL LCMLEN(KPLIST,'DIFF',ILENGT,ITYLCM) + IF(ILENGT.EQ.NMIXT) CALL LCMGET(KPLIST,'DIFF',DIFFX(1,JGR)) + CALL LCMLEN(KPLIST,'DIFFX',ILENGT,ITYLCM) + IF(ILENGT.EQ.NMIXT) CALL LCMGET(KPLIST,'DIFFX',DIFFX(1,JGR)) + CALL LCMLEN(KPLIST,'DIFFY',ILENGT,ITYLCM) + IF(ILENGT.EQ.NMIXT) CALL LCMGET(KPLIST,'DIFFY',DIFFY(1,JGR)) + CALL LCMLEN(KPLIST,'DIFFZ',ILENGT,ITYLCM) + IF(ILENGT.EQ.NMIXT) CALL LCMGET(KPLIST,'DIFFZ',DIFFZ(1,JGR)) + CALL LCMLEN(KPLIST,'H-FACTOR',ILENGT,ITYLCM) + IF(ILENGT.EQ.NMIXT) CALL LCMGET(KPLIST,'H-FACTOR',H(1,JGR)) + CALL LCMLEN(KPLIST,'FIXE',ILENGT,ITYLCM) + IF(ILENGT.EQ.NMIXT) CALL LCMGET(KPLIST,'FIXE',S(1,JGR)) + DO 30 IL=1,NL + WRITE (CM,'(I2.2)') IL-1 + CALL LCMLEN(KPLIST,'SCAT'//CM,ILENGT,ITYLCM) + IF(ILENGT.GT.NMIXT*NL*NGRP*NGRP) THEN + CALL XABORT('MACXSI: INVALID INPUT MACROLIB(2).') + ELSE IF(ILENGT.GT.0) THEN + CALL LCMGET(KPLIST,'SCAT'//CM,WORK) + CALL LCMGET(KPLIST,'NJJS'//CM,NJJ(1,IL,JGR)) + CALL LCMGET(KPLIST,'IJJS'//CM,IJJ(1,IL,JGR)) + IPOSDE=0 + DO 25 IBM=1,NMIXT + IJJ0=IJJ(IBM,IL,JGR) + DO 20 IGR=IJJ0,IJJ0-NJJ(IBM,IL,JGR)+1,-1 + IPOSDE=IPOSDE+1 + SCAT(IBM,IL,IGR,JGR)=WORK(IPOSDE) + 20 CONTINUE + 25 CONTINUE + ENDIF + 30 CONTINUE + 40 CONTINUE + ENDIF +* + 50 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('MACXSI: CHARACTER DATA EXPECTED(1).') + IF(TEXT4.EQ.'MIX') THEN + 60 CALL REDGET(INDIC,IBM,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('MACXSI: INTEGER DATA EXPECTED.') + IF(IBM.GT.NMIXT) CALL XABORT('MACXSI: INVALID MIX INDEX.') + NBMIX=MAX(NBMIX,IBM) + 70 CALL REDGET(INDIC,NITMA,FLOTT,TEXT8,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('MACXSI: CHARACTER DATA EXPECTED.') + IF((TEXT8.EQ.'TOTAL').OR.(TEXT8.EQ.'NTOT0')) THEN + LTO=.TRUE. + DO 80 IGR=1,NGRP + CALL REDGET(INDIC,NITMA,TOTAL(IBM,IGR),TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('MACXSI: REAL DATA EXPECTED.') + 80 CONTINUE + ELSE IF(TEXT8.EQ.'NTOT1') THEN + LT1=.TRUE. + DO 85 IGR=1,NGRP + CALL REDGET(INDIC,NITMA,TOTA1(IBM,IGR),TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('MACXSI: REAL DATA EXPECTED.') + 85 CONTINUE + ELSE IF(TEXT8.EQ.'NUSIGF') THEN + LFI=.TRUE. + DO 90 IGR=1,NGRP + CALL REDGET(INDIC,NITMA,ZNUG(IBM,IGR),TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('MACXSI: REAL DATA EXPECTED.') + 90 CONTINUE + ELSE IF(TEXT8.EQ.'CHI') THEN + LCH=.TRUE. + DO 95 IGR=1,NGRP + CALL REDGET(INDIC,NITMA,CHI(IBM,IGR),TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('MACXSI: REAL DATA EXPECTED.') + 95 CONTINUE + ELSE IF(TEXT8.EQ.'NUSIGD') THEN + LDI=.TRUE. + DO 896 I=1,NDG + DO 895 IGR=1,NGRP + CALL REDGET(INDIC,NITMA,NUSDL(IBM,I,IGR),TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('MACXSI: REAL DATA EXPECTED.') + 895 CONTINUE + 896 CONTINUE + ELSE IF(TEXT8.EQ.'CHDL') THEN + LBI=.TRUE. + DO 996 I=1,NDG + DO 995 IGR=1,NGRP + CALL REDGET(INDIC,NITMA,CHDL(IBM,I,IGR),TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('MACXSI: REAL DATA EXPECTED.') + 995 CONTINUE + 996 CONTINUE + ELSE IF(TEXT8.EQ.'OVERV') THEN + LOV=.TRUE. + DO 96 IGR=1,NGRP + CALL REDGET(INDIC,NITMA,OVERV(IBM,IGR),TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('MACXSI: REAL DATA EXPECTED.') + IF(OVERV(IBM,IGR).EQ.0.) CALL XABORT('MACXSI: INVALID VELO' + 1 //'CITY VALUE.') + 96 CONTINUE + ELSE IF(TEXT8.EQ.'DIFF') THEN + LD=.TRUE. + DO 97 IGR=1,NGRP + CALL REDGET(INDIC,NITMA,DIFFX(IBM,IGR),TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('MACXSI: REAL DATA EXPECTED.') + 97 CONTINUE + ELSE IF(TEXT8.EQ.'DIFFX') THEN + LDX=.TRUE. + DO 100 IGR=1,NGRP + CALL REDGET(INDIC,NITMA,DIFFX(IBM,IGR),TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('MACXSI: REAL DATA EXPECTED.') + 100 CONTINUE + ELSE IF(TEXT8.EQ.'DIFFY') THEN + LDY=.TRUE. + DO 110 IGR=1,NGRP + CALL REDGET(INDIC,NITMA,DIFFY(IBM,IGR),TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('MACXSI: REAL DATA EXPECTED.') + 110 CONTINUE + ELSE IF(TEXT8.EQ.'DIFFZ') THEN + LDZ=.TRUE. + DO 120 IGR=1,NGRP + CALL REDGET(INDIC,NITMA,DIFFZ(IBM,IGR),TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('MACXSI: REAL DATA EXPECTED.') + 120 CONTINUE + ELSE IF(TEXT8.EQ.'H-FACTOR') THEN + LHF=.TRUE. + DO 130 IGR=1,NGRP + CALL REDGET(INDIC,NITMA,H(IBM,IGR),TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('MACXSI: REAL DATA EXPECTED.') + 130 CONTINUE + ELSE IF(TEXT8.EQ.'SCAT') THEN + LSC=.TRUE. + DO 142 IL=1,NL + DO 141 JGR=1,NGRP + CALL REDGET(INDIC,NJJ(IBM,IL,JGR),FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('MACXSI: INTEGER DATA EXPECTED.') + CALL REDGET(INDIC,IJJ(IBM,IL,JGR),FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('MACXSI: INTEGER DATA EXPECTED.') + IJJ0=IJJ(IBM,IL,JGR) + DO 140 IGR=IJJ0,IJJ0-NJJ(IBM,IL,JGR)+1,-1 +* SCAT(MIXTURE,LEGENDRE,PRIMARY,SECONDARY) + CALL REDGET(INDIC,NITMA,SCAT(IBM,IL,IGR,JGR),TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('MACXSI: REAL DATA EXPECTED.') + 140 CONTINUE + 141 CONTINUE + 142 CONTINUE + ELSE IF(TEXT8.EQ.'FIXE') THEN + LSO=.TRUE. + DO 150 IGR=1,NGRP + CALL REDGET(INDIC,NITMA,S(IBM,IGR),TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('MACXSI: REAL DATA EXPECTED.') + 150 CONTINUE + ELSE IF(TEXT8.EQ.'MIX') THEN + GO TO 60 + ELSE IF(TEXT8.EQ.';') THEN + JND=1 + GO TO 160 + ELSE IF(TEXT8.EQ.'STEP') THEN + JND=2 + GO TO 160 + ELSE + CALL XABORT('MACXSI: INVALID KEY-WORD(1).') + ENDIF + GO TO 70 + ELSE + CALL XABORT('MACXSI: INVALID KEY-WORD(2).') + ENDIF + GO TO 50 +* + 160 JPLIST=LCMLID(IPLIST,'GROUP',NGRP) + DO 210 JGR=1,NGRP + KPLIST=LCMDIL(JPLIST,JGR) + IF(LTO) CALL LCMPUT(KPLIST,'NTOT0',NMIXT,2,TOTAL(1,JGR)) + IF(LT1) CALL LCMPUT(KPLIST,'NTOT1',NMIXT,2,TOTA1(1,JGR)) + IF(LFI) CALL LCMPUT(KPLIST,'NUSIGF',NMIXT,2,ZNUG(1,JGR)) + IF(LCH) CALL LCMPUT(KPLIST,'CHI',NMIXT,2,CHI(1,JGR)) + IF(LOV) CALL LCMPUT(KPLIST,'OVERV',NMIXT,2,OVERV(1,JGR)) + IF(LD) THEN + CALL LCMPUT(KPLIST,'DIFF',NMIXT,2,DIFFX(1,JGR)) + ELSE + IF(LDX) CALL LCMPUT(KPLIST,'DIFFX',NMIXT,2,DIFFX(1,JGR)) + IF(LDY) CALL LCMPUT(KPLIST,'DIFFY',NMIXT,2,DIFFY(1,JGR)) + IF(LDZ) CALL LCMPUT(KPLIST,'DIFFZ',NMIXT,2,DIFFZ(1,JGR)) + ENDIF + IF(LHF) CALL LCMPUT(KPLIST,'H-FACTOR',NMIXT,2,H(1,JGR)) + IF(LSO) CALL LCMPUT(KPLIST,'FIXE',NMIXT,2,S(1,JGR)) + IF(LDI) THEN + DO 170 I=1,NDG + WRITE(TEXT,'(A6,I2.2)') 'NUSIGF',I + CALL LCMPUT(KPLIST,TEXT,NMIXT,2,NUSDL(1,I,JGR)) + 170 CONTINUE + ENDIF + IF(LBI) THEN + DO 180 I=1,NDG + WRITE(TEXT,'(A3,I2.2)') 'CHI',I + CALL LCMPUT(KPLIST,TEXT,NMIXT,2,CHDL(1,I,JGR)) + 180 CONTINUE + ENDIF + IF(LSC) THEN + DO 200 IL=1,NL + WRITE (CM,'(I2.2)') IL-1 + IPOSDE=0 + DO 195 IBM=1,NMIXT + J2=JGR + J1=JGR + DO 185 IGR=1,NGRP + IF(SCAT(IBM,IL,IGR,JGR).NE.0.0) THEN + J2=MAX(J2,IGR) + J1=MIN(J1,IGR) + ENDIF + 185 CONTINUE + NJJ(IBM,IL,JGR)=J2-J1+1 + IJJ(IBM,IL,JGR)=J2 + IPOS(IBM)=IPOSDE+1 + DO 190 IGR=IJJ(IBM,IL,JGR),IJJ(IBM,IL,JGR)-NJJ(IBM,IL,JGR)+1,-1 + IPOSDE=IPOSDE+1 + WORK(IPOSDE)=SCAT(IBM,IL,IGR,JGR) + 190 CONTINUE + 195 CONTINUE + CALL LCMPUT(KPLIST,'SCAT'//CM,IPOSDE,2,WORK) + CALL LCMPUT(KPLIST,'IPOS'//CM,NMIXT,1,IPOS) + CALL LCMPUT(KPLIST,'NJJS'//CM,NMIXT,1,NJJ(1,IL,JGR)) + CALL LCMPUT(KPLIST,'IJJS'//CM,NMIXT,1,IJJ(1,IL,JGR)) + CALL LCMPUT(KPLIST,'SIGW'//CM,NMIXT,2,SCAT(1,IL,JGR,JGR)) + 200 CONTINUE + ENDIF + IF(IMPX.GT.1) CALL LCMLIB(KPLIST) + 210 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(TOTAL,TOTA1,ZNUG,CHI,NUSDL,CHDL,OVERV,DIFFX,DIFFY, + 1 DIFFZ,H,S,SCAT,WORK) + DEALLOCATE(IJJ,NJJ,IPOS) + RETURN + END diff --git a/Trivac/src/MTBLD.f b/Trivac/src/MTBLD.f new file mode 100755 index 0000000..a247d91 --- /dev/null +++ b/Trivac/src/MTBLD.f @@ -0,0 +1,110 @@ +*DECK MTBLD + SUBROUTINE MTBLD(HNAME,IPTRK,IPSYS,ITY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* LCM driver for VECBLD. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* HNAME name of the matrix. HNAME(:1) is 'W ', 'X ', 'Y', or 'Z'. +* In case of a Thomas-Raviart basis, can also be equal to 'WA', +* 'XA', 'YA' or 'ZA'. +* IPTRK L_TRACK pointer to the tracking information. +* IPSYS L_SYSTEM pointer to system matrices. +* ITY type of processing: +* =1 gather back; =2 scatter forth; +* =3 scatter forth and store the diagonal elements. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPSYS + CHARACTER HNAME*(*) + INTEGER ITY +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + CHARACTER TEXT12*12,HSMG*131,HCHAR*1 + INTEGER ITP(NSTATE) + REAL DUMMY(1) + TYPE(C_PTR) ASS_PTR,ASSV_PTR + INTEGER, DIMENSION(:), ALLOCATABLE :: MU,MUV,IPV,LBL + REAL, DIMENSION(:), POINTER :: ASS,ASSV + REAL, DIMENSION(:), ALLOCATABLE :: DGV +*---- +* RECOVER TRACKING INFORMATION FROM LCM +*---- + CALL KDRCPU(TK1) + HCHAR=HNAME(:1) + CALL LCMGET(IPTRK,'STATE-VECTOR',ITP) + ISEG=ITP(17) + IMPV=ITP(18) + CALL LCMLEN(IPTRK,'MU'//HCHAR,LL4,ITYLCM) + CALL LCMLEN(IPTRK,'LBL'//HCHAR,LON,ITYLCM) + ALLOCATE(MU(LL4),LBL(LON),MUV(LL4),IPV(LL4)) + CALL LCMGET(IPTRK,'MU'//HCHAR,MU) + CALL LCMGET(IPTRK,'LBL'//HCHAR,LBL) + CALL LCMGET(IPTRK,'MUV'//HCHAR,MUV) + CALL LCMGET(IPTRK,'IPV'//HCHAR,IPV) +* + TEXT12=HNAME + IIMAX=MU(LL4) + LBL0=0 + DO 10 I=1,LON + LBL0=LBL0+LBL(I) + 10 CONTINUE + IIMAXV=MUV(LBL0)*ISEG + IF(ITY.EQ.1) THEN +* SUPERVECTORIAL TO SCALAR REBUILD. + ASS_PTR=LCMARA(IIMAX) + CALL LCMLEN(IPSYS,TEXT12,ILEN,ITYLCM) + IF(ILEN.NE.IIMAXV) THEN + WRITE(HSMG,'(38HMTBLD: REBUILD FAILURE 1 IN PROCESSING, + 1 9H MATRIX '',A12,2H''.)') TEXT12 + CALL XABORT(HSMG) + ENDIF + CALL LCMGPD(IPSYS,TEXT12,ASSV_PTR) + CALL C_F_POINTER(ASSV_PTR,ASSV,(/ IIMAXV /)) + CALL C_F_POINTER(ASS_PTR,ASS,(/ IIMAX /)) + CALL VECBLD(ISEG,LL4,MU,LON,LBL,MUV,IPV,1,ASS,ASSV,DUMMY(1)) + CALL LCMPPD(IPSYS,TEXT12,IIMAX,2,ASS_PTR) + ELSE IF(ITY.GE.2) THEN +* SCALAR TO SUPERVECTORIAL REBUILD. + ALLOCATE(DGV(LBL0*ISEG)) + ASSV_PTR=LCMARA(IIMAXV) + CALL LCMLEN(IPSYS,TEXT12,ILEN,ITYLCM) + IF(ILEN.NE.IIMAX) THEN + WRITE(HSMG,'(38HMTBLD: REBUILD FAILURE 2 IN PROCESSING, + 1 9H MATRIX '',A12,2H''.)') TEXT12 + CALL XABORT(HSMG) + ENDIF + CALL LCMGPD(IPSYS,TEXT12,ASS_PTR) + CALL C_F_POINTER(ASSV_PTR,ASSV,(/ IIMAXV /)) + CALL C_F_POINTER(ASS_PTR,ASS,(/ IIMAX /)) + CALL VECBLD(ISEG,LL4,MU,LON,LBL,MUV,IPV,2,ASS,ASSV,DGV(1)) + IF(ITY.EQ.3) THEN + CALL LCMPUT(IPSYS,HCHAR//'D'//TEXT12(3:),LBL0*ISEG,2,DGV) + ENDIF + DEALLOCATE(DGV) + CALL LCMPPD(IPSYS,TEXT12,IIMAXV,2,ASSV_PTR) + ENDIF + DEALLOCATE(IPV,MUV,LBL,MU) + CALL KDRCPU(TK2) + IF(IMPV.GE.3) WRITE (6,'(/18H MTBLD: CPU TIME =,F7.2,3H S.)') + 1 TK2-TK1 + RETURN + END diff --git a/Trivac/src/MTLDLF.f b/Trivac/src/MTLDLF.f new file mode 100755 index 0000000..251ab4c --- /dev/null +++ b/Trivac/src/MTLDLF.f @@ -0,0 +1,130 @@ +*DECK MTLDLF + SUBROUTINE MTLDLF(NAMP,IPTRK,IPSYS,ITY,IMPX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* LCM driver for the L-D-L(t) factorization of a symmetric matrix. +* The factorized matrix is stored on LCM under name 'I'//NAMP. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): Alain Hebert +* +*Parameters: input +* NAMP name of the coefficient matrix. +* IPTRK L_TRACK pointer to the tracking information. +* IPSYS L_SYSTEM pointer to system matrices. +* ITY type of coefficient matrix (1: Bivac; 2: classical Trivac; +* 3: Thomas-Raviart). +* IMPX print flag (equal to zero for no print). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPSYS + CHARACTER NAMP*12 + INTEGER ITY,IMPX +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40,NPREF=5) + CHARACTER HIN*12,HOUT*12,PREFIX(5)*2,NAMLCM*12,NAMMY*12 + LOGICAL EMPTY,LCM + INTEGER ITP(NSTATE) + INTEGER, DIMENSION(:), ALLOCATABLE :: MU,NBL,LBL + REAL, DIMENSION(:), ALLOCATABLE :: T + REAL, DIMENSION(:), POINTER :: ASM + TYPE(C_PTR) ASM_PTR + DATA (PREFIX(I),I=1,NPREF)/' ','W_','X_','Y_','Z_'/ +* + IF(ITY.EQ.1) THEN +* BIVAC TRACKING. + CALL LCMGET(IPTRK,'STATE-VECTOR',ITP) + ISEG=0 + NLF=ITP(14) + ELSE +* CLASSICAL TRIVAC TRACKING. + CALL LCMGET(IPTRK,'STATE-VECTOR',ITP) + ISEG=ITP(17) + NLF=ITP(30) + ENDIF +* + DO 30 IS=1,NPREF + IF(PREFIX(IS).EQ.' ') THEN + HIN=NAMP + HOUT='I'//NAMP(:11) + ELSE + HIN=PREFIX(IS)//NAMP(:11) + HOUT=PREFIX(IS)(:1)//'I'//NAMP(:10) + ENDIF +*---- +* PERFORM FACTORIZATION OF MATRICES +*---- + CALL LCMLEN(IPSYS,HIN,ILENG,ITYLCM) + IF(ILENG.GT.0) THEN + IF(ISEG.EQ.0) THEN + CALL LCMLEN(IPTRK,'MU'//PREFIX(IS)(:1),LMU,ITYLCM) + ALLOCATE(MU(LMU)) + CALL LCMGET(IPTRK,'MU'//PREFIX(IS)(:1),MU) + ELSE + CALL LCMLEN(IPTRK,'MUV'//PREFIX(IS)(:1),LMU,ITYLCM) + ALLOCATE(MU(LMU)) + CALL LCMGET(IPTRK,'MUV'//PREFIX(IS)(:1),MU) + ENDIF + ILEN=MU(LMU) + IF(NLF.GT.0) ILEN=ILEN*NLF/2 + IF(IMPX.GT.0) THEN + CALL LCMINF(IPSYS,NAMLCM,NAMMY,EMPTY,ILONG,LCM) + WRITE(6,'(/30H MTLDLF: FACTORIZATION OF LCM , + 1 8HMATRIX '',A12,23H''. CREATION OF MATRIX '',A12, + 2 14H'' LOCATED IN '',A12,2H''.)') HIN,HOUT,NAMLCM + ENDIF + ASM_PTR=LCMARA(ILENG) + CALL C_F_POINTER(ASM_PTR,ASM,(/ ILENG /)) + CALL LCMGET(IPSYS,HIN,ASM) + IF(ISEG.EQ.0) THEN + IF(ILEN.NE.ILENG) CALL XABORT('MTLDLF: INCONSISTENT INF' + 1 //'ORMATION ON LCM (1).') + IF(NLF.EQ.0) THEN + CALL ALLDLF(LMU,ASM(1),MU) + ELSE + IOF=1 + DO 10 IL=0,NLF-2,2 + CALL ALLDLF(LMU,ASM(IOF),MU) + IOF=IOF+MU(LMU) + 10 CONTINUE + ENDIF + ELSE + IF(ISEG*ILEN.NE.ILENG) CALL XABORT('MTLDLF: INCONSISTEN' + 1 //'T INFORMATION ON LCM (2).') + CALL LCMLEN(IPTRK,'NBL'//PREFIX(IS)(:1),LON,ITYLCM) + ALLOCATE(NBL(LON),LBL(LON)) + CALL LCMGET(IPTRK,'NBL'//PREFIX(IS)(:1),NBL) + CALL LCMGET(IPTRK,'LBL'//PREFIX(IS)(:1),LBL) + ALLOCATE(T(ISEG)) + IF(NLF.EQ.0) THEN + CALL ALVDLF(ASM(1),MU,ISEG,LON,NBL,LBL,T) + ELSE + IOF=1 + DO 20 IL=0,NLF-2,2 + CALL ALVDLF(ASM(IOF),MU,ISEG,LON,NBL,LBL,T) + IOF=IOF+MU(LMU) + 20 CONTINUE + ENDIF + DEALLOCATE(T,LBL,NBL) + ENDIF + DEALLOCATE(MU) + CALL LCMPPD(IPSYS,HOUT,ILENG,2,ASM_PTR) + ENDIF + 30 CONTINUE + RETURN + END diff --git a/Trivac/src/MTLDLM.f b/Trivac/src/MTLDLM.f new file mode 100755 index 0000000..68f9327 --- /dev/null +++ b/Trivac/src/MTLDLM.f @@ -0,0 +1,435 @@ +*DECK MTLDLM + SUBROUTINE MTLDLM(NAMP,IPTRK,IPSYS,LL4,ITY,F2,F3) +* +*----------------------------------------------------------------------- +* +*Purpose: +* LCM driver for the multiplication of a matrix by a vector. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NAMP name of the coefficient matrix. +* IPTRK L_TRACK pointer to the tracking information. +* IPSYS L_SYSTEM pointer to system matrices. +* LL4 order of the matrix. +* ITY type of coefficient matrix (1: Bivac; 2: classical Trivac; +* 3: Raviart-Thomas; 11: SPN/Bivac; 13: SPN/Raviart-Thomas). +* F2 vector to multiply. +* +*Parameters: output +* F3 result of the multiplication. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPSYS + CHARACTER NAMP*(*) + INTEGER LL4,ITY + REAL F2(LL4),F3(LL4) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + CHARACTER NAMT*12,TEXT12*12 + INTEGER ITP(NSTATE),ASS_LEN + LOGICAL LMU,LMUW,LMUX,LMUY,LMUZ,DIAG + REAL, DIMENSION(:), ALLOCATABLE :: GAR,GAF + TYPE(C_PTR) MU_PTR,IP_PTR,IPV_PTR,NBL_PTR,LBL_PTR + TYPE(C_PTR) ASS_PTR + INTEGER, DIMENSION(:), ALLOCATABLE :: IPB + INTEGER, DIMENSION(:), POINTER :: MU,IP,IPV,NBL,LBL + REAL, DIMENSION(:), POINTER :: ASS +* +*----------------------------------------------------------------------- +* +* INFORMATION RECOVERED FROM XSM OR LCM (SPLITTED MATRIX): +* 'W_'//NAMP 'X_'//NAMP 'Y_'//NAMP 'Z_'//NAMP : W-, X-, Y- AND Z- +* ORIENTED MATRIX COMPONENTS. +* +* SCALAR INFORMATION RECOVERED FROM LCM. +* 'MUW' 'MUX' 'MUY' 'MUZ' : POSITION OF DIAGONAL ELEMENT IN W-, X-, Y- +* OR Z-ORIENTED MATRIX COMPONENTS. +* 'IPW' 'IPX' 'IPY' 'IPZ' : PERMUTATION INFORMATION FOR W-, X-, Y- OR +* Z-ORIENTED MATRIX COMPONENTS. +* +* SUPERVECTORIZATION INFORMATION RECOVERED FROM LCM. +* 'LL4VW' 'LL4VX' 'LL4VY' 'LL4VZ' : ORDER OF THE REORDERED W-, X-, Y- +* AND Z-ORIENTED MATRIX COMPONENTS. +* 'MUVW' 'MUVX' 'MUVY' 'MUVZ' : POSITION OF DIAGONAL ELEMENT IN W-, X-, +* Y-OR Z-ORIENTED MATRIX COMPONENTS. +* 'IPVW' 'IPVX' 'IPVY' 'IPVZ' : PERMUTATION INFORMATION FOR W-, X-, Y- +* OR Z-ORIENTED MATRIX COMPONENTS. +* 'NBLW' 'NBLX' 'NBLY' 'NBLZ' : NUMBER OF LINEAR SYSTEMS IN EACH SUPER- +* VECTORIAL UNKNOWN GROUP. +* 'LBLW' 'LBLX' 'LBLY' 'LBLZ' : ORDER OF LINEAR SYSTEMS IN EACH SUPER- +* VECTORIAL UNKNOWN GROUP. +* +*----------------------------------------------------------------------- +* + IF(ITY.EQ.1) THEN +* DIFFUSION BIVAC TRACKING. + ISEG=0 + ELSE IF(ITY.EQ.2) THEN +* CLASSICAL TRIVAC TRACKING. + CALL LCMGET(IPTRK,'STATE-VECTOR',ITP) + ISEG=ITP(17) + LTSW=ITP(19) + ELSE IF(ITY.EQ.3) THEN +* RAVIART-THOMAS TRIVAC TRACKING. + CALL FLDTRM(NAMP,IPTRK,IPSYS,LL4,F2,F3) + RETURN + ELSE IF(ITY.EQ.11) THEN +* SIMPLIFIED PN BIVAC TRACKING. + CALL LCMGET(IPSYS,'STATE-VECTOR',ITP) + NBMIX=ITP(7) + NAN=ITP(8) + IF(NAN.EQ.0) CALL XABORT('MTLDLM: SPN-ONLY ALGORITHM(1).') + F3(:LL4)=0.0 + CALL FLDBSM(NAMP,IPTRK,IPSYS,LL4,NBMIX,NAN,F2,F3) + RETURN + ELSE IF(ITY.EQ.13) THEN +* SIMPLIFIED PN TRIVAC TRACKING. + CALL LCMGET(IPSYS,'STATE-VECTOR',ITP) + NBMIX=ITP(7) + NAN=ITP(8) + IF(NAN.EQ.0) CALL XABORT('MTLDLM: SPN-ONLY ALGORITHM(2).') + F3(:LL4)=0.0 + CALL FLDTSM(NAMP,IPTRK,IPSYS,LL4,NBMIX,NAN,F2,F3) + RETURN + ENDIF +* + CALL LCMLEN(IPTRK,'MU',IDUM,ITYLCM) + LMU=(IDUM.NE.0).AND.(ITYLCM.EQ.1) + CALL LCMLEN(IPTRK,'MUW',IDUM,ITYLCM) + LMUW=(IDUM.NE.0).AND.(ITYLCM.EQ.1) + CALL LCMLEN(IPTRK,'MUX',IDUM,ITYLCM) + LMUX=(IDUM.NE.0).AND.(ITYLCM.EQ.1) + CALL LCMLEN(IPTRK,'MUY',IDUM,ITYLCM) + LMUY=(IDUM.NE.0).AND.(ITYLCM.EQ.1) + CALL LCMLEN(IPTRK,'MUZ',IDUM,ITYLCM) + LMUZ=(IDUM.NE.0).AND.(ITYLCM.EQ.1) + DIAG=LMUY.AND.(.NOT.LMUX) +* + NAMT=NAMP + IF(LMU) THEN + CALL LCMLEN(IPTRK,'MU',LL4TS,ITYLCM) + IF(LL4.NE.LL4TS) CALL XABORT('MTLDLM: INVALID LL4(1).') + CALL LCMGPD(IPTRK,'MU',MU_PTR) + CALL LCMGPD(IPSYS,NAMT,ASS_PTR) + CALL C_F_POINTER(MU_PTR,MU,(/ LL4 /)) + CALL C_F_POINTER(ASS_PTR,ASS,(/ MU(LL4) /)) + CALL ALLDLM(LL4,ASS,F2(1),F3(1),MU,1) + ELSE IF(ISEG.EQ.0) THEN +* SCALAR MULTIPLICATION FOR A W- OR X-ORIENTED MATRIX. + IF(LMUW) THEN + TEXT12='W_'//NAMT(:10) + CALL LCMGPD(IPTRK,'MUW',MU_PTR) + CALL LCMGPD(IPTRK,'IPW',IP_PTR) + CALL LCMLEN(IPTRK,'IPW',LL4TS,ITYLCM) + ELSE IF(DIAG) THEN + TEXT12='Y_'//NAMT(:10) + CALL LCMGPD(IPTRK,'MUY',MU_PTR) + CALL LCMGPD(IPTRK,'IPX',IP_PTR) + CALL LCMLEN(IPTRK,'IPX',LL4TS,ITYLCM) + ELSE + TEXT12='X_'//NAMT(:10) + CALL LCMGPD(IPTRK,'MUX',MU_PTR) + CALL LCMGPD(IPTRK,'IPX',IP_PTR) + CALL LCMLEN(IPTRK,'IPX',LL4TS,ITYLCM) + ENDIF + IF(LL4.NE.LL4TS) CALL XABORT('MTLDLM: INVALID LL4(2).') + CALL C_F_POINTER(MU_PTR,MU,(/ LL4 /)) + CALL C_F_POINTER(IP_PTR,IP,(/ LL4 /)) + ALLOCATE(GAR(LL4)) + DO 10 I=1,LL4 + GAR(IP(I))=F2(I) + 10 CONTINUE + DO 20 I=1,LL4 + F2(I)=GAR(I) + 20 CONTINUE + CALL LCMGPD(IPSYS,TEXT12,ASS_PTR) + CALL C_F_POINTER(ASS_PTR,ASS,(/ MU(LL4) /)) + CALL ALLDLM(LL4,ASS,F2(1),GAR(1),MU,1) + DO 30 I=1,LL4 + II=IP(I) + F3(I)=GAR(II) + GAR(II)=F2(II) + 30 CONTINUE + DO 40 I=1,LL4 + F2(I)=GAR(IP(I)) + 40 CONTINUE + IF(LMUW) THEN +* SCALAR MULTIPLICATION FOR A X-ORIENTED MATRIX. + CALL LCMGPD(IPTRK,'MUX',MU_PTR) + CALL LCMLEN(IPTRK,'IPX',LL4TS,ITYLCM) + IF(LL4.NE.LL4TS) CALL XABORT('MTLDLM: INVALID LL4(5).') + CALL LCMGPD(IPTRK,'IPX',IP_PTR) + CALL C_F_POINTER(MU_PTR,MU,(/ LL4 /)) + CALL C_F_POINTER(IP_PTR,IP,(/ LL4 /)) + DO 50 I=1,LL4 + GAR(IP(I))=F2(I) + 50 CONTINUE + DO 60 I=1,LL4 + II=IP(I) + F2(II)=GAR(II) + GAR(II)=F3(I) + 60 CONTINUE + CALL LCMGPD(IPSYS,'X_'//NAMT,ASS_PTR) + CALL C_F_POINTER(ASS_PTR,ASS,(/ MU(LL4) /)) + CALL ALLDLM(LL4,ASS,F2(1),GAR(1),MU,2) + DO 70 I=1,LL4 + II=IP(I) + F3(I)=GAR(II) + GAR(II)=F2(II) + 70 CONTINUE + DO 80 I=1,LL4 + F2(I)=GAR(IP(I)) + 80 CONTINUE + ENDIF + IF(LMUY) THEN +* SCALAR MULTIPLICATION FOR A Y-ORIENTED MATRIX. + CALL LCMGPD(IPTRK,'MUY',MU_PTR) + CALL LCMLEN(IPTRK,'IPY',LL4TS,ITYLCM) + IF(LL4.NE.LL4TS) CALL XABORT('MTLDLM: INVALID LL4(6).') + CALL LCMGPD(IPTRK,'IPY',IP_PTR) + CALL C_F_POINTER(MU_PTR,MU,(/ LL4 /)) + CALL C_F_POINTER(IP_PTR,IP,(/ LL4 /)) + DO 90 I=1,LL4 + GAR(IP(I))=F2(I) + 90 CONTINUE + DO 100 I=1,LL4 + II=IP(I) + F2(II)=GAR(II) + GAR(II)=F3(I) + 100 CONTINUE + CALL LCMGPD(IPSYS,'Y_'//NAMT,ASS_PTR) + CALL C_F_POINTER(ASS_PTR,ASS,(/ MU(LL4) /)) + CALL ALLDLM(LL4,ASS,F2(1),GAR(1),MU,2) + DO 110 I=1,LL4 + II=IP(I) + F3(I)=GAR(II) + GAR(II)=F2(II) + 110 CONTINUE + DO 120 I=1,LL4 + F2(I)=GAR(IP(I)) + 120 CONTINUE + ENDIF + IF(LMUZ) THEN +* SCALAR MULTIPLICATION FOR A Z-ORIENTED MATRIX. + CALL LCMGPD(IPTRK,'MUZ',MU_PTR) + CALL LCMLEN(IPTRK,'IPZ',LL4TS,ITYLCM) + IF(LL4.NE.LL4TS) CALL XABORT('MTLDLM: INVALID LL4(7).') + CALL LCMGPD(IPTRK,'IPZ',IP_PTR) + CALL C_F_POINTER(MU_PTR,MU,(/ LL4 /)) + CALL C_F_POINTER(IP_PTR,IP,(/ LL4 /)) + DO 130 I=1,LL4 + GAR(IP(I))=F2(I) + 130 CONTINUE + DO 140 I=1,LL4 + II=IP(I) + F2(II)=GAR(II) + GAR(II)=F3(I) + 140 CONTINUE + CALL LCMGPD(IPSYS,'Z_'//NAMT,ASS_PTR) + CALL C_F_POINTER(ASS_PTR,ASS,(/ MU(LL4) /)) + CALL ALLDLM(LL4,ASS,F2(1),GAR(1),MU,2) + DO 150 I=1,LL4 + II=IP(I) + F3(I)=GAR(II) + GAR(II)=F2(II) + 150 CONTINUE + DO 160 I=1,LL4 + F2(I)=GAR(IP(I)) + 160 CONTINUE + ENDIF + DEALLOCATE(GAR) + ELSE IF(ISEG.GT.0) THEN +* SUPERVECTORIAL MULTIPLICATION FOR A W- OR X-ORIENTED MATRIX. + IF(LMUW) THEN + CALL LCMGET(IPTRK,'LL4VW',LL4V) + CALL LCMGPD(IPTRK,'MUVW',MU_PTR) + TEXT12='W_'//NAMT(:10) + CALL LCMLEN(IPTRK,'IPW',LL4TS,ITYLCM) + IF(LL4.NE.LL4TS) CALL XABORT('MTLDLM: INVALID LL4(8).') + CALL LCMGPD(IPTRK,'IPW',IP_PTR) + CALL LCMGPD(IPTRK,'IPVW',IPV_PTR) + CALL LCMLEN(IPTRK,'NBLW',NBL_LEN,ITYLCM) + CALL LCMGPD(IPTRK,'NBLW',NBL_PTR) + CALL LCMGPD(IPTRK,'LBLW',LBL_PTR) + ELSE IF(DIAG) THEN + CALL LCMGET(IPTRK,'LL4VY',LL4V) + CALL LCMGPD(IPTRK,'MUVY',MU_PTR) + TEXT12='Y_'//NAMT(:10) + CALL LCMLEN(IPTRK,'IPX',LL4TS,ITYLCM) + IF(LL4.NE.LL4TS) CALL XABORT('MTLDLM: INVALID LL4(9).') + CALL LCMGPD(IPTRK,'IPX',IP_PTR) + CALL LCMGPD(IPTRK,'IPVY',IPV_PTR) + CALL LCMLEN(IPTRK,'NBLY',NBL_LEN,ITYLCM) + CALL LCMGPD(IPTRK,'NBLY',NBL_PTR) + CALL LCMGPD(IPTRK,'LBLY',LBL_PTR) + ELSE + CALL LCMGET(IPTRK,'LL4VX',LL4V) + CALL LCMGPD(IPTRK,'MUVX',MU_PTR) + TEXT12='X_'//NAMT(:10) + CALL LCMLEN(IPTRK,'IPX',LL4TS,ITYLCM) + IF(LL4.NE.LL4TS) CALL XABORT('MTLDLM: INVALID LL4(10).') + CALL LCMGPD(IPTRK,'IPX',IP_PTR) + CALL LCMGPD(IPTRK,'IPVX',IPV_PTR) + CALL LCMLEN(IPTRK,'NBLX',NBL_LEN,ITYLCM) + CALL LCMGPD(IPTRK,'NBLX',NBL_PTR) + CALL LCMGPD(IPTRK,'LBLX',LBL_PTR) + ENDIF + CALL C_F_POINTER(MU_PTR,MU,(/ LL4V/ISEG /)) + CALL C_F_POINTER(IP_PTR,IP,(/ LL4 /)) + CALL C_F_POINTER(IPV_PTR,IPV,(/ IPV_LEN /)) + CALL C_F_POINTER(NBL_PTR,NBL,(/ NBL_LEN /)) + CALL C_F_POINTER(LBL_PTR,LBL,(/ NBL_LEN /)) + ALLOCATE(IPB(LL4),GAR(LL4V),GAF(LL4V)) + DO 165 I=1,LL4 + IPB(I)=IPV(IP(I)) + 165 CONTINUE + GAR(:LL4V)=0.0 + DO 180 I=1,LL4 + GAR(IPB(I))=F2(I) + 180 CONTINUE + CALL LCMLEN(IPSYS,TEXT12,ASS_LEN,ITYLCM) + CALL LCMGPD(IPSYS,TEXT12,ASS_PTR) + CALL C_F_POINTER(ASS_PTR,ASS,(/ ASS_LEN /)) + CALL ALVDLM(LTSW,ASS,GAR,GAF,MU,1,ISEG,NBL_LEN,NBL,LBL) + DO 190 I=1,LL4 + II=IPB(I) + F2(I)=GAR(II) + F3(I)=GAF(II) + 190 CONTINUE + DEALLOCATE(GAF,GAR,IPB) + IF(LMUW) THEN +* SUPERVECTORIAL MULTIPLICATION FOR A X-ORIENTED MATRIX. + CALL LCMGET(IPTRK,'LL4VX',LL4V) + CALL LCMGPD(IPTRK,'MUVX',MU_PTR) + CALL C_F_POINTER(MU_PTR,MU,(/ LL4V/ISEG /)) + CALL LCMLEN(IPTRK,'IPX',LL4TS,ITYLCM) + IF(LL4.NE.LL4TS) CALL XABORT('MTLDLM: INVALID LL4(11).') + CALL LCMGPD(IPTRK,'IPX',IP_PTR) + CALL LCMLEN(IPTRK,'IPVX',IPV_LEN,ITYLCM) + CALL LCMGPD(IPTRK,'IPVX',IPV_PTR) + CALL C_F_POINTER(IP_PTR,IP,(/ LL4 /)) + CALL C_F_POINTER(IPV_PTR,IPV,(/ IPV_LEN /)) + CALL LCMLEN(IPTRK,'NBLX',NBL_LEN,ITYLCM) + CALL LCMGPD(IPTRK,'NBLX',NBL_PTR) + CALL LCMGPD(IPTRK,'LBLX',LBL_PTR) + CALL C_F_POINTER(NBL_PTR,NBL,(/ NBL_LEN /)) + CALL C_F_POINTER(LBL_PTR,LBL,(/ NBL_LEN /)) + ALLOCATE(IPB(LL4),GAR(LL4V),GAF(LL4V)) + DO 200 I=1,LL4 + IPB(I)=IPV(IP(I)) + 200 CONTINUE + GAR(:LL4V)=0.0 + GAF(:LL4V)=0.0 + DO 220 I=1,LL4 + II=IPB(I) + GAR(II)=F2(I) + GAF(II)=F3(I) + 220 CONTINUE + CALL LCMLEN(IPSYS,'X_'//NAMT,ASS_LEN,ITYLCM) + CALL LCMGPD(IPSYS,'X_'//NAMT,ASS_PTR) + CALL C_F_POINTER(ASS_PTR,ASS,(/ ASS_LEN /)) + CALL ALVDLM(LTSW,ASS,GAR,GAF,MU,2,ISEG,NBL_LEN,NBL,LBL) + DO 230 I=1,LL4 + II=IPB(I) + F2(I)=GAR(II) + F3(I)=GAF(II) + 230 CONTINUE + DEALLOCATE(GAF,GAR,IPB) + ENDIF + IF(LMUY) THEN +* SUPERVECTORIAL MULTIPLICATION FOR A Y-ORIENTED MATRIX. + CALL LCMGET(IPTRK,'LL4VY',LL4V) + CALL LCMGPD(IPTRK,'MUVY',MU_PTR) + CALL C_F_POINTER(MU_PTR,MU,(/ LL4V/ISEG /)) + CALL LCMLEN(IPTRK,'IPY',LL4TS,ITYLCM) + IF(LL4.NE.LL4TS) CALL XABORT('MTLDLM: INVALID LL4(12).') + CALL LCMGPD(IPTRK,'IPY',IP_PTR) + CALL LCMLEN(IPTRK,'IPVY',IPV_LEN,ITYLCM) + CALL LCMGPD(IPTRK,'IPVY',IPV_PTR) + CALL C_F_POINTER(IP_PTR,IP,(/ LL4 /)) + CALL C_F_POINTER(IPV_PTR,IPV,(/ IPV_LEN /)) + CALL LCMLEN(IPTRK,'NBLY',NBL_LEN,ITYLCM) + CALL LCMGPD(IPTRK,'NBLY',NBL_PTR) + CALL LCMGPD(IPTRK,'LBLY',LBL_PTR) + CALL C_F_POINTER(NBL_PTR,NBL,(/ NBL_LEN /)) + CALL C_F_POINTER(LBL_PTR,LBL,(/ NBL_LEN /)) + ALLOCATE(IPB(LL4),GAR(LL4V),GAF(LL4V)) + DO 235 I=1,LL4 + IPB(I)=IPV(IP(I)) + 235 CONTINUE + GAR(:LL4V)=0.0 + GAF(:LL4V)=0.0 + DO 260 I=1,LL4 + II=IPB(I) + GAR(II)=F2(I) + GAF(II)=F3(I) + 260 CONTINUE + CALL LCMLEN(IPSYS,'Y_'//NAMT,ASS_LEN,ITYLCM) + CALL LCMGPD(IPSYS,'Y_'//NAMT,ASS_PTR) + CALL C_F_POINTER(ASS_PTR,ASS,(/ ASS_LEN /)) + CALL ALVDLM(LTSW,ASS,GAR,GAF,MU,2,ISEG,NBL_LEN,NBL,LBL) + DO 270 I=1,LL4 + II=IPB(I) + F2(I)=GAR(II) + F3(I)=GAF(II) + 270 CONTINUE + DEALLOCATE(GAF,GAR,IPB) + ENDIF + IF(LMUZ) THEN +* SUPERVECTORIAL MULTIPLICATION FOR A Z-ORIENTED MATRIX. + CALL LCMGET(IPTRK,'LL4VZ',LL4V) + CALL LCMGPD(IPTRK,'MUVZ',MU_PTR) + CALL C_F_POINTER(MU_PTR,MU,(/ LL4V/ISEG /)) + CALL LCMLEN(IPTRK,'IPZ',LL4TS,ITYLCM) + IF(LL4.NE.LL4TS) CALL XABORT('MTLDLM: INVALID LL4(13).') + CALL LCMGPD(IPTRK,'IPZ',IP_PTR) + CALL LCMLEN(IPTRK,'IPVZ',IPV_LEN,ITYLCM) + CALL LCMGPD(IPTRK,'IPVZ',IPV_PTR) + CALL C_F_POINTER(IP_PTR,IP,(/ LL4 /)) + CALL C_F_POINTER(IPV_PTR,IPV,(/ IPV_LEN /)) + CALL LCMLEN(IPTRK,'NBLZ',NBL_LEN,ITYLCM) + CALL LCMGPD(IPTRK,'NBLZ',NBL_PTR) + CALL LCMGPD(IPTRK,'LBLZ',LBL_PTR) + CALL C_F_POINTER(NBL_PTR,NBL,(/ NBL_LEN /)) + CALL C_F_POINTER(LBL_PTR,LBL,(/ NBL_LEN /)) + ALLOCATE(IPB(LL4),GAR(LL4V),GAF(LL4V)) + DO 275 I=1,LL4 + IPB(I)=IPV(IP(I)) + 275 CONTINUE + GAR(:LL4V)=0.0 + GAF(:LL4V)=0.0 + DO 300 I=1,LL4 + II=IPB(I) + GAR(II)=F2(I) + GAF(II)=F3(I) + 300 CONTINUE + CALL LCMLEN(IPSYS,'Z_'//NAMT,ASS_LEN,ITYLCM) + CALL LCMGPD(IPSYS,'Z_'//NAMT,ASS_PTR) + CALL C_F_POINTER(ASS_PTR,ASS,(/ ASS_LEN /)) + CALL ALVDLM(LTSW,ASS,GAR,GAF,MU,2,ISEG,NBL_LEN,NBL,LBL) + DO 310 I=1,LL4 + II=IPB(I) + F2(I)=GAR(II) + F3(I)=GAF(II) + 310 CONTINUE + DEALLOCATE(GAF,GAR,IPB) + ENDIF + ENDIF + RETURN + END diff --git a/Trivac/src/MTLDLS.f b/Trivac/src/MTLDLS.f new file mode 100755 index 0000000..fe9557b --- /dev/null +++ b/Trivac/src/MTLDLS.f @@ -0,0 +1,418 @@ +*DECK MTLDLS + SUBROUTINE MTLDLS(NAMP,IPTRK,IPSYS,LL4,ITY,F1) +* +*----------------------------------------------------------------------- +* +*Purpose: +* LCM driver for the solution of a linear system after LDL(t) +* factorization. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NAMP name of the coefficient matrix. +* IPTRK L_TRACK pointer to the tracking information. +* IPSYS L_SYSTEM pointer to system matrices. +* LL4 order of the matrix. +* ITY type of coefficient matrix (1: Bivac; 2: classical Trivac; +* 3: Raviart-Thomas; 11: SPN/Bivac; 13: SPN/Raviart-Thomas). +* F1 right-hand side of the linear system. +* +*Parameters: output +* F1 solution of the linear system. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPSYS + CHARACTER NAMP*(*) + INTEGER LL4,ITY + REAL F1(LL4) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + CHARACTER NAMT*12,TEXT12*12 + INTEGER ITP(NSTATE),ASS_LEN + LOGICAL LMU,LMUW,LMUX,LMUY,LMUZ,DIAG + REAL, DIMENSION(:), ALLOCATABLE :: GAR + TYPE(C_PTR) MU_PTR,IP_PTR,IPV_PTR,NBL_PTR,LBL_PTR + TYPE(C_PTR) ASS_PTR,DGV_PTR + INTEGER, DIMENSION(:), ALLOCATABLE :: IPB + INTEGER, DIMENSION(:), POINTER :: MU,IP,IPV,NBL,LBL + REAL, DIMENSION(:), POINTER :: ASS,DGV +* +*----------------------------------------------------------------------- +* +* INFORMATION RECOVERED FROM XSM OR LCM (NON-SPLITTED MATRIX): +* NAMP : COEFFICIENT MATRIX. +* 'I'//NAMP : FACTORIZED COEFFICIENT MATRIX. +* 'MU' : POSITION OF DIAGONAL ELEMENT IN COEFFICIENT MATRIX. +* +* INFORMATION RECOVERED FROM XSM OR LCM (SPLITTED MATRIX): +* 'W_'//NAMP 'X_'//NAMP 'Y_'//NAMP 'Z_'//NAMP : W-, X-, Y- AND Z- +* ORIENTED MATRIX COMPONENTS. +* 'WI'//NAMP 'XI'//NAMP 'YI'//NAMP 'ZI'//NAMP : W-, X-, Y- AND Z- +* ORIENTED FACTORIZED MATRIX COMPONENTS. +* +* SCALAR INFORMATION RECOVERED FROM LCM. +* 'MUW' 'MUX' 'MUY' 'MUZ' : POSITION OF DIAGONAL ELEMENT IN W-, X-, Y- +* OR Z-ORIENTED MATRIX COMPONENTS. +* 'IPW' 'IPX' 'IPY' 'IPZ' : PERMUTATION INFORMATION FOR W-, X-, Y- OR +* Z-ORIENTED MATRIX COMPONENTS. +* +* SUPERVECTORIZATION INFORMATION RECOVERED FROM LCM. +* 'WD'//NAMP 'XD'//NAMP 'YD'//NAMP 'ZD'//NAMP : DIAGONAL ELEMENTS FOR +* W-, X-, Y- AND Z-ORIENTED MATRIX COMPONENTS. +* 'LL4VW' 'LL4VX' 'LL4VY' 'LL4VZ' : ORDER OF THE REORDERED W-, X-, Y- +* AND Z-ORIENTED MATRIX COMPONENTS. +* 'MUVW' 'MUVX' 'MUVY' 'MUVZ' : POSITION OF DIAGONAL ELEMENT IN W-, X-, +* Y-OR Z-ORIENTED MATRIX COMPONENTS. +* 'IPVW' 'IPVX' 'IPVY' 'IPVZ' : PERMUTATION INFORMATION FOR W-, X-, Y- +* OR Z-ORIENTED MATRIX COMPONENTS. +* 'NBLW' 'NBLX' 'NBLY' 'NBLZ' : NUMBER OF LINEAR SYSTEMS IN EACH SUPER- +* VECTORIAL UNKNOWN GROUP. +* 'LBLW' 'LBLX' 'LBLY' 'LBLZ' : ORDER OF LINEAR SYSTEMS IN EACH SUPER- +* VECTORIAL UNKNOWN GROUP. +* +*----------------------------------------------------------------------- +* + IF(ITY.EQ.1) THEN +* BIVAC TRACKING. + ISEG=0 + ELSE IF(ITY.EQ.2) THEN +* CLASSICAL TRIVAC TRACKING. + CALL LCMGET(IPTRK,'STATE-VECTOR',ITP) + ISEG=ITP(17) + LTSW=ITP(19) + ELSE IF(ITY.EQ.3) THEN +* RAVIART-THOMAS/DIFFUSION TRIVAC TRACKING. + ALLOCATE(GAR(LL4)) + GAR(:LL4)=F1(:LL4) + F1(:LL4)=0.0 + CALL FLDTRS(NAMP,IPTRK,IPSYS,LL4,GAR,F1,1) + DEALLOCATE(GAR) + RETURN + ELSE IF(ITY.EQ.11) THEN +* SIMPLIFIED PN BIVAC TRACKING. + CALL LCMGET(IPSYS,'STATE-VECTOR',ITP) + NBMIX=ITP(7) + NAN=ITP(8) + IF(NAN.EQ.0) CALL XABORT('MTLDLS: SPN-ONLY ALGORITHM(1).') + CALL FLDBSS(NAMP,IPTRK,IPSYS,LL4,NBMIX,NAN,F1,1) + RETURN + ELSE IF(ITY.EQ.13) THEN +* RAVIART-THOMAS/SIMPLIFIED PN TRIVAC TRACKING. + CALL LCMGET(IPSYS,'STATE-VECTOR',ITP) + NBMIX=ITP(7) + NAN=ITP(8) + IF(NAN.EQ.0) CALL XABORT('MTLDLS: SPN-ONLY ALGORITHM(2).') + ALLOCATE(GAR(LL4)) + GAR(:LL4)=F1(:LL4) + F1(:LL4)=0.0 + CALL FLDSPN(NAMP,IPTRK,IPSYS,LL4,NBMIX,NAN,GAR,F1,1) + DEALLOCATE(GAR) + RETURN + ENDIF +* + CALL LCMLEN(IPTRK,'MU',IDUM,ITYLCM) + LMU=(IDUM.NE.0).AND.(ITYLCM.EQ.1) + CALL LCMLEN(IPTRK,'MUW',IDUM,ITYLCM) + LMUW=(IDUM.NE.0).AND.(ITYLCM.EQ.1) + CALL LCMLEN(IPTRK,'MUX',IDUM,ITYLCM) + LMUX=(IDUM.NE.0).AND.(ITYLCM.EQ.1) + CALL LCMLEN(IPTRK,'MUY',IDUM,ITYLCM) + LMUY=(IDUM.NE.0).AND.(ITYLCM.EQ.1) + CALL LCMLEN(IPTRK,'MUZ',IDUM,ITYLCM) + LMUZ=(IDUM.NE.0).AND.(ITYLCM.EQ.1) + DIAG=LMUY.AND.(.NOT.LMUX) +* + NAMT=NAMP + IF(LMU) THEN + CALL LCMLEN(IPTRK,'MU',LL4TS,ITYLCM) + IF(LL4.NE.LL4TS) CALL XABORT('MTLDLS: INVALID LL4(1).') + CALL LCMGPD(IPTRK,'MU',MU_PTR) + CALL LCMGPD(IPSYS,'I'//NAMT,ASS_PTR) + CALL C_F_POINTER(MU_PTR,MU,(/ LL4 /)) + CALL C_F_POINTER(ASS_PTR,ASS,(/ MU(LL4) /)) + CALL ALLDLS(LL4,MU,ASS,F1(1)) + ELSE IF(ISEG.EQ.0) THEN +* SCALAR SOLUTION FOR A W- OR X-ORIENTED LINEAR SYSTEM. + TEXT12=' ' + IF(LMUW) THEN + TEXT12='WI'//NAMT(:10) + CALL LCMGPD(IPTRK,'MUW',MU_PTR) + CALL LCMGPD(IPTRK,'IPW',IP_PTR) + CALL LCMLEN(IPTRK,'IPW',LL4TS,ITYLCM) + ELSE IF(DIAG) THEN + TEXT12='YI'//NAMT(:10) + CALL LCMGPD(IPTRK,'MUY',MU_PTR) + CALL LCMGPD(IPTRK,'IPX',IP_PTR) + CALL LCMLEN(IPTRK,'IPX',LL4TS,ITYLCM) + ELSE + TEXT12='XI'//NAMT(:10) + CALL LCMGPD(IPTRK,'MUX',MU_PTR) + CALL LCMGPD(IPTRK,'IPX',IP_PTR) + CALL LCMLEN(IPTRK,'IPX',LL4TS,ITYLCM) + ENDIF + IF(LL4.NE.LL4TS) CALL XABORT('MTLDLS: INVALID LL4(2).') + CALL C_F_POINTER(MU_PTR,MU,(/ LL4 /)) + CALL C_F_POINTER(IP_PTR,IP,(/ LL4 /)) + ALLOCATE(GAR(LL4)) + DO 10 I=1,LL4 + GAR(IP(I))=F1(I) + 10 CONTINUE + CALL LCMGPD(IPSYS,TEXT12,ASS_PTR) + CALL C_F_POINTER(ASS_PTR,ASS,(/ MU(LL4) /)) + CALL ALLDLS(LL4,MU,ASS,GAR(1)) + DO 20 I=1,LL4 + F1(I)=GAR(IP(I)) + 20 CONTINUE + IF(LMUW) THEN +* SCALAR SOLUTION FOR A X-ORIENTED LINEAR SYSTEM. + CALL LCMGPD(IPTRK,'MUX',MU_PTR) + CALL LCMGPD(IPTRK,'IPX',IP_PTR) + CALL C_F_POINTER(MU_PTR,MU,(/ LL4 /)) + CALL C_F_POINTER(IP_PTR,IP,(/ LL4 /)) + CALL LCMGPD(IPSYS,'X_'//NAMT,ASS_PTR) + CALL C_F_POINTER(ASS_PTR,ASS,(/ MU(LL4) /)) + DO 30 I=1,LL4 + II=IP(I) + GAR(II)=F1(I)*ASS(MU(II)) + 30 CONTINUE + CALL LCMGPD(IPSYS,'XI'//NAMT,ASS_PTR) + CALL C_F_POINTER(ASS_PTR,ASS,(/ MU(LL4) /)) + CALL ALLDLS(LL4,MU,ASS,GAR(1)) + DO 50 I=1,LL4 + F1(I)=GAR(IP(I)) + 50 CONTINUE + ENDIF + IF(LMUY) THEN +* SCALAR SOLUTION FOR A Y-ORIENTED LINEAR SYSTEM. + CALL LCMGPD(IPTRK,'MUY',MU_PTR) + CALL LCMGPD(IPTRK,'IPY',IP_PTR) + CALL C_F_POINTER(MU_PTR,MU,(/ LL4 /)) + CALL C_F_POINTER(IP_PTR,IP,(/ LL4 /)) + CALL LCMGPD(IPSYS,'Y_'//NAMT,ASS_PTR) + CALL C_F_POINTER(ASS_PTR,ASS,(/ MU(LL4) /)) + DO 60 I=1,LL4 + II=IP(I) + GAR(II)=F1(I)*ASS(MU(II)) + 60 CONTINUE + CALL LCMGPD(IPSYS,'YI'//NAMT,ASS_PTR) + CALL C_F_POINTER(ASS_PTR,ASS,(/ MU(LL4) /)) + CALL ALLDLS(LL4,MU,ASS,GAR(1)) + DO 80 I=1,LL4 + F1(I)=GAR(IP(I)) + 80 CONTINUE + ENDIF + IF(LMUZ) THEN +* SCALAR SOLUTION FOR A Z-ORIENTED LINEAR SYSTEM. + CALL LCMGPD(IPTRK,'MUZ',MU_PTR) + CALL LCMGPD(IPTRK,'IPZ',IP_PTR) + CALL C_F_POINTER(MU_PTR,MU,(/ LL4 /)) + CALL C_F_POINTER(IP_PTR,IP,(/ LL4 /)) + CALL LCMGPD(IPSYS,'Z_'//NAMT,ASS_PTR) + CALL C_F_POINTER(ASS_PTR,ASS,(/ MU(LL4) /)) + DO 90 I=1,LL4 + II=IP(I) + GAR(II)=F1(I)*ASS(MU(II)) + 90 CONTINUE + CALL LCMGPD(IPSYS,'ZI'//NAMT,ASS_PTR) + CALL C_F_POINTER(ASS_PTR,ASS,(/ MU(LL4) /)) + CALL ALLDLS(LL4,MU,ASS,GAR(1)) + DO 110 I=1,LL4 + F1(I)=GAR(IP(I)) + 110 CONTINUE + ENDIF + DEALLOCATE(GAR) + ELSE IF(ISEG.GT.0) THEN +* SUPERVECTORIAL SOLUTION FOR A W- OR X-ORIENTED LINEAR SYSTEM. + IF(LMUW) THEN + CALL LCMGET(IPTRK,'LL4VW',LL4V) + CALL LCMGPD(IPTRK,'MUVW',MU_PTR) + TEXT12='WI'//NAMT(:10) + CALL LCMLEN(IPTRK,'IPW',LL4TS,ITYLCM) + IF(LL4.NE.LL4TS) CALL XABORT('MTLDLS: INVALID LL4(5).') + CALL LCMGPD(IPTRK,'IPW',IP_PTR) + CALL LCMLEN(IPTRK,'IPVW',IPV_LEN,ITYLCM) + CALL LCMGPD(IPTRK,'IPVW',IPV_PTR) + CALL LCMLEN(IPTRK,'NBLW',NBL_LEN,ITYLCM) + CALL LCMGPD(IPTRK,'NBLW',NBL_PTR) + CALL LCMGPD(IPTRK,'LBLW',LBL_PTR) + ELSE IF(DIAG) THEN + CALL LCMGET(IPTRK,'LL4VY',LL4V) + CALL LCMGPD(IPTRK,'MUVY',MU_PTR) + TEXT12='YI'//NAMT(:10) + CALL LCMLEN(IPTRK,'IPX',LL4TS,ITYLCM) + IF(LL4.NE.LL4TS) CALL XABORT('MTLDLS: INVALID LL4(6).') + CALL LCMGPD(IPTRK,'IPX',IP_PTR) + CALL LCMLEN(IPTRK,'IPVY',IPV_LEN,ITYLCM) + CALL LCMGPD(IPTRK,'IPVY',IPV_PTR) + CALL LCMLEN(IPTRK,'NBLY',NBL_LEN,ITYLCM) + CALL LCMGPD(IPTRK,'NBLY',NBL_PTR) + CALL LCMGPD(IPTRK,'LBLY',LBL_PTR) + ELSE + CALL LCMGET(IPTRK,'LL4VX',LL4V) + CALL LCMGPD(IPTRK,'MUVX',MU_PTR) + TEXT12='XI'//NAMT(:10) + CALL LCMLEN(IPTRK,'IPX',LL4TS,ITYLCM) + IF(LL4.NE.LL4TS) CALL XABORT('MTLDLS: INVALID LL4(7).') + CALL LCMGPD(IPTRK,'IPX',IP_PTR) + CALL LCMLEN(IPTRK,'IPVX',IPV_LEN,ITYLCM) + CALL LCMGPD(IPTRK,'IPVX',IPV_PTR) + CALL LCMLEN(IPTRK,'NBLX',NBL_LEN,ITYLCM) + CALL LCMGPD(IPTRK,'NBLX',NBL_PTR) + CALL LCMGPD(IPTRK,'LBLX',LBL_PTR) + ENDIF + CALL C_F_POINTER(MU_PTR,MU,(/ LL4V/ISEG /)) + CALL C_F_POINTER(IP_PTR,IP,(/ LL4 /)) + CALL C_F_POINTER(IPV_PTR,IPV,(/ IPV_LEN /)) + CALL C_F_POINTER(NBL_PTR,NBL,(/ NBL_LEN /)) + CALL C_F_POINTER(LBL_PTR,LBL,(/ NBL_LEN /)) + ALLOCATE(IPB(LL4),GAR(LL4V)) + DO 120 I=1,LL4 + IPB(I)=IPV(IP(I)) + 120 CONTINUE + GAR(:LL4V)=0.0 + DO 130 I=1,LL4 + GAR(IPB(I))=F1(I) + 130 CONTINUE + CALL LCMLEN(IPSYS,TEXT12,ASS_LEN,ITYLCM) + CALL LCMGPD(IPSYS,TEXT12,ASS_PTR) + CALL C_F_POINTER(ASS_PTR,ASS,(/ ASS_LEN /)) + CALL ALVDLS(LTSW,MU,ASS,GAR,ISEG,NBL_LEN,NBL,LBL) + DO 140 I=1,LL4 + F1(I)=GAR(IPB(I)) + 140 CONTINUE + DEALLOCATE(GAR,IPB) + IF(LMUW) THEN +* SUPERVECTORIAL SOLUTION FOR A X-ORIENTED LINEAR SYSTEM. + CALL LCMGET(IPTRK,'LL4VX',LL4V) + CALL LCMGPD(IPTRK,'MUVX',MU_PTR) + CALL C_F_POINTER(MU_PTR,MU,(/ LL4V/ISEG /)) + CALL LCMLEN(IPTRK,'IPX',LL4,ITYLCM) + CALL LCMGPD(IPTRK,'IPX',IP_PTR) + CALL LCMLEN(IPTRK,'IPVX',IPV_LEN,ITYLCM) + CALL LCMGPD(IPTRK,'IPVX',IPV_PTR) + CALL C_F_POINTER(IP_PTR,IP,(/ LL4 /)) + CALL C_F_POINTER(IPV_PTR,IPV,(/ IPV_LEN /)) + CALL LCMLEN(IPTRK,'NBLX',NBL_LEN,ITYLCM) + CALL LCMGPD(IPTRK,'NBLX',NBL_PTR) + CALL LCMGPD(IPTRK,'LBLX',LBL_PTR) + CALL C_F_POINTER(NBL_PTR,NBL,(/ NBL_LEN /)) + CALL C_F_POINTER(LBL_PTR,LBL,(/ NBL_LEN /)) + ALLOCATE(IPB(LL4),GAR(LL4V)) + DO 150 I=1,LL4 + IPB(I)=IPV(IP(I)) + 150 CONTINUE + GAR(:LL4V)=0.0 + DO 160 I=1,LL4 + GAR(IPB(I))=F1(I) + 160 CONTINUE + CALL LCMLEN(IPSYS,'XI'//NAMT,ASS_LEN,ITYLCM) + CALL LCMGPD(IPSYS,'XI'//NAMT,ASS_PTR) + CALL LCMGPD(IPSYS,'XD'//NAMT,DGV_PTR) + CALL C_F_POINTER(ASS_PTR,ASS,(/ ASS_LEN /)) + CALL C_F_POINTER(DGV_PTR,DGV,(/ LL4V /)) +CDIR$ IVDEP + DO 170 I=1,LL4V + GAR(I)=GAR(I)*DGV(I) + 170 CONTINUE + CALL ALVDLS(LTSW,MU,ASS,GAR,ISEG,NBL_LEN,NBL,LBL) + DO 190 I=1,LL4 + F1(I)=GAR(IPB(I)) + 190 CONTINUE + DEALLOCATE(GAR,IPB) + ENDIF + IF(LMUY) THEN +* SUPERVECTORIAL SOLUTION FOR A Y-ORIENTED LINEAR SYSTEM. + CALL LCMGET(IPTRK,'LL4VY',LL4V) + CALL LCMGPD(IPTRK,'MUVY',MU_PTR) + CALL C_F_POINTER(MU_PTR,MU,(/ LL4V/ISEG /)) + CALL LCMLEN(IPTRK,'IPY',LL4,ITYLCM) + CALL LCMGPD(IPTRK,'IPY',IP_PTR) + CALL LCMLEN(IPTRK,'IPVY',IPV_LEN,ITYLCM) + CALL LCMGPD(IPTRK,'IPVY',IPV_PTR) + CALL C_F_POINTER(IP_PTR,IP,(/ LL4 /)) + CALL C_F_POINTER(IPV_PTR,IPV,(/ IPV_LEN /)) + CALL LCMLEN(IPTRK,'NBLY',NBL_LEN,ITYLCM) + CALL LCMGPD(IPTRK,'NBLY',NBL_PTR) + CALL LCMGPD(IPTRK,'LBLY',LBL_PTR) + CALL C_F_POINTER(NBL_PTR,NBL,(/ NBL_LEN /)) + CALL C_F_POINTER(LBL_PTR,LBL,(/ NBL_LEN /)) + ALLOCATE(IPB(LL4),GAR(LL4V)) + DO 200 I=1,LL4 + IPB(I)=IPV(IP(I)) + 200 CONTINUE + GAR(:LL4V)=0.0 + DO 210 I=1,LL4 + GAR(IPB(I))=F1(I) + 210 CONTINUE + CALL LCMLEN(IPSYS,'YI'//NAMT,ASS_LEN,ITYLCM) + CALL LCMGPD(IPSYS,'YI'//NAMT,ASS_PTR) + CALL LCMGPD(IPSYS,'YD'//NAMT,DGV_PTR) + CALL C_F_POINTER(ASS_PTR,ASS,(/ ASS_LEN /)) + CALL C_F_POINTER(DGV_PTR,DGV,(/ LL4V /)) +CDIR$ IVDEP + DO 220 I=1,LL4V + GAR(I)=GAR(I)*DGV(I) + 220 CONTINUE + CALL ALVDLS(LTSW,MU,ASS,GAR,ISEG,NBL_LEN,NBL,LBL) + DO 240 I=1,LL4 + F1(I)=GAR(IPB(I)) + 240 CONTINUE + DEALLOCATE(GAR,IPB) + ENDIF + IF(LMUZ) THEN +* SUPERVECTORIAL SOLUTION FOR A Z-ORIENTED LINEAR SYSTEM. + CALL LCMGET(IPTRK,'LL4VZ',LL4V) + CALL LCMGPD(IPTRK,'MUVZ',MU_PTR) + CALL C_F_POINTER(MU_PTR,MU,(/ LL4V/ISEG /)) + CALL LCMLEN(IPTRK,'IPZ',LL4,ITYLCM) + CALL LCMGPD(IPTRK,'IPZ',IP_PTR) + CALL LCMLEN(IPTRK,'IPVZ',IPV_LEN,ITYLCM) + CALL LCMGPD(IPTRK,'IPVZ',IPV_PTR) + CALL C_F_POINTER(IP_PTR,IP,(/ LL4 /)) + CALL C_F_POINTER(IPV_PTR,IPV,(/ IPV_LEN /)) + CALL LCMLEN(IPTRK,'NBLZ',NBL_LEN,ITYLCM) + CALL LCMGPD(IPTRK,'NBLZ',NBL_PTR) + CALL LCMGPD(IPTRK,'LBLZ',LBL_PTR) + CALL C_F_POINTER(NBL_PTR,NBL,(/ NBL_LEN /)) + CALL C_F_POINTER(LBL_PTR,LBL,(/ NBL_LEN /)) + ALLOCATE(IPB(LL4),GAR(LL4V)) + DO 250 I=1,LL4 + IPB(I)=IPV(IP(I)) + 250 CONTINUE + GAR(:LL4V)=0.0 + DO 260 I=1,LL4 + GAR(IPB(I))=F1(I) + 260 CONTINUE + CALL LCMLEN(IPSYS,'ZI'//NAMT,ASS_LEN,ITYLCM) + CALL LCMGPD(IPSYS,'ZI'//NAMT,ASS_PTR) + CALL LCMGPD(IPSYS,'ZD'//NAMT,DGV_PTR) + CALL C_F_POINTER(ASS_PTR,ASS,(/ ASS_LEN /)) + CALL C_F_POINTER(DGV_PTR,DGV,(/ LL4V /)) +CDIR$ IVDEP + DO 270 I=1,LL4V + GAR(I)=GAR(I)*DGV(I) + 270 CONTINUE + CALL ALVDLS(LTSW,MU,ASS,GAR,ISEG,NBL_LEN,NBL,LBL) + DO 290 I=1,LL4 + F1(I)=GAR(IPB(I)) + 290 CONTINUE + DEALLOCATE(GAR,IPB) + ENDIF + ENDIF + RETURN + END diff --git a/Trivac/src/MTOPEN.f b/Trivac/src/MTOPEN.f new file mode 100755 index 0000000..46ccdfb --- /dev/null +++ b/Trivac/src/MTOPEN.f @@ -0,0 +1,105 @@ +*DECK MTOPEN + SUBROUTINE MTOPEN(IMPX,IPTRK,LL4) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Examine and print information related to the automatic matrix +* processor (MTLDLS and MTLDLM). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IMPX print parameter (equal to zero for no print). +* IPTRK L_TRACK pointer to the tracking information. +* LL4 order of the coefficient matrix. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK + INTEGER IMPX,LL4 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + CHARACTER HSMG*90,CMODUL*12 + LOGICAL LMU,LMUW,LMUX,LMUY,LMUZ + INTEGER ITP(NSTATE) +* + CALL LCMGTC(IPTRK,'TRACK-TYPE',12,CMODUL) + CALL LCMGET(IPTRK,'STATE-VECTOR',ITP) + ICHX=0 + NLF=0 + ISEG=0 + IF(CMODUL.EQ.'BIVAC') THEN + NLF=ITP(14) + ISEG=ITP(17) + ELSE IF(CMODUL.EQ.'TRIVAC') THEN + ICHX=ITP(12) + ISEG=ITP(17) + NLF=ITP(30) + ENDIF + IF((IMPX.GT.0).AND.(ISEG.GT.0)) THEN + IMPV=ITP(18) + LTSW=ITP(19) + WRITE(6,'(9X,36HSUPERVECTORIZATION OPTION ON. ISEG =,I4, + 1 8H IMPV =,I3,8H LTSW =,I3)') ISEG,IMPV,LTSW + ENDIF + CALL LCMLEN(IPTRK,'MU',LL40,ITYLCM) + LMU=(LL40.NE.0).AND.(ITYLCM.EQ.1) + CALL LCMLEN(IPTRK,'MUW',LL4W,ITYLCM) + LMUW=(LL4W.NE.0).AND.(ITYLCM.EQ.1) + CALL LCMLEN(IPTRK,'MUX',LL4X,ITYLCM) + LMUX=(LL4X.NE.0).AND.(ITYLCM.EQ.1) + CALL LCMLEN(IPTRK,'MUY',LL4Y,ITYLCM) + LMUY=(LL4Y.NE.0).AND.(ITYLCM.EQ.1) + CALL LCMLEN(IPTRK,'MUZ',LL4Z,ITYLCM) + LMUZ=(LL4Z.NE.0).AND.(ITYLCM.EQ.1) + IDIM=1 + IF(LMU) THEN + LL4TST=LL40 + HSMG='INVERSE POWER METHOD.' + ELSE IF(LMUW) THEN + IDIM=2 + IF((.NOT.LMUX).OR.(.NOT.LMUY)) CALL XABORT('MTOPEN: X- OR Y-C' + 1 //'OMPONENT MISSING IN HEXAGONAL GEOMETRY CASE.') + IF(LMUZ) IDIM=3 + CALL LCMLEN(IPTRK,'IPW',LL4TST,ITYLCM) + IF(ICHX.EQ.2) LL4TST=ITP(25)+LL4W+LL4X+LL4Y+LL4Z + WRITE(HSMG,'(I1,33H-AXIS HEXAGONAL ADI POWER METHOD.)') IDIM+1 + ELSE IF(LMUX) THEN + IF(LMUY) IDIM=2 + IF(LMUZ) IDIM=3 + CALL LCMLEN(IPTRK,'IPX',LL4TST,ITYLCM) + IF(ICHX.EQ.2) LL4TST=ITP(25)+LL4W+LL4X+LL4Y+LL4Z + WRITE(HSMG,'(I1,33H-AXIS CARTESIAN ADI POWER METHOD.)') IDIM + ELSE IF(LMUY) THEN + IDIM=2 + IF(LMUZ) IDIM=3 + CALL LCMLEN(IPTRK,'IPY',LL4TST,ITYLCM) + IF(ICHX.EQ.2) LL4TST=ITP(25)+LL4W+2*LL4Y+LL4Z + WRITE(HSMG,'(I1,42H-AXIS CARTESIAN ADI POWER METHOD (DIAGONAL, + 1 10H SYMMETRY))') IDIM + ELSE + CALL XABORT('MTOPEN: MISSING MU INFO ON LCM.') + ENDIF +* + IF(NLF.GT.0) LL4TST=LL4TST*NLF/2 + IF(LL4TST.LE.0) CALL XABORT('MTOPEN: UNABLE TO FIND THE NUMBER O' + 1 //'F UNKNOWNS.') + IF(IMPX.GT.0) WRITE(6,'(/29H MTOPEN: NUMBER OF UNKNOWNS =,I8, + 1 2H. ,A90)') LL4TST,HSMG + IF(LL4TST.NE.LL4) CALL XABORT('MTOPEN: INVALID NB OF UNKNOWNS.') + RETURN + END diff --git a/Trivac/src/Makefile b/Trivac/src/Makefile new file mode 100644 index 0000000..6a70191 --- /dev/null +++ b/Trivac/src/Makefile @@ -0,0 +1,199 @@ +#--------------------------------------------------------------------------- +# +# Makefile for building the Trivac library and load module +# Author : A. Hebert (2018-5-10) +# +#--------------------------------------------------------------------------- +# +ARCH = $(shell uname -m) +ifneq (,$(filter $(ARCH),aarch64 arm64)) + nbit = +else + ifneq (,$(filter $(ARCH),i386 i686)) + nbit = -m32 + else + nbit = -m64 + endif +endif + +DIRNAME = $(shell uname -sm | sed 's/[ ]/_/') +OS = $(shell uname -s | cut -d"_" -f1) +opt = -O -g +ifeq ($(openmp),1) + COMP = -fopenmp +else + COMP = +endif + +ifeq ($(intel),1) + fcompiler = ifort + ccompiler = icc +else + ifeq ($(nvidia),1) + fcompiler = nvfortran + ccompiler = nvc + else + ifeq ($(llvm),1) + fcompiler = flang-new + ccompiler = clang + else + fcompiler = gfortran + ccompiler = gcc + endif + endif +endif + +ifeq ($(OS),AIX) + python_version_major := 2 +else + python_version_full := $(wordlist 2,4,$(subst ., ,$(shell python --version 2>&1))) + python_version_major := $(word 1,${python_version_full}) + ifneq ($(python_version_major),2) + python_version_major := 3 + endif +endif + +ifeq ($(OS),Darwin) + ifeq ($(openmp),1) + ccompiler = gcc-14 + endif + F90 = $(fcompiler) + FFLAGS = $(nbit) -fPIC + FFLAG77 = $(nbit) -fPIC + LFLAGS = $(nbit) +else +ifeq ($(OS),Linux) + F90 = $(fcompiler) + FFLAGS = -Wall $(nbit) -fPIC + FFLAG77 = -Wall $(nbit) -fPIC + LFLAGS = $(nbit) +else +ifeq ($(OS),CYGWIN) + F90 = $(fcompiler) + FFLAGS = -Wall $(nbit) -fPIC + FFLAG77 = -Wall $(nbit) -fPIC + LFLAGS = $(nbit) +else +ifeq ($(OS),SunOS) + fcompiler = + MAKE = gmake + F90 = f90 + FFLAGS = $(nbit) -s -ftrap=%none + FFLAG77 = $(nbit) -s -ftrap=%none + LFLAGS = $(nbit) +else +ifeq ($(OS),AIX) + fcompiler = + opt = -O4 + MAKE = gmake + DIRNAME = AIX + F90 = xlf90 + FFLAGS = -qstrict -qmaxmem=-1 -qsuffix=f=f90 + FFLAG77 = -qstrict -qmaxmem=-1 -qxlf77=leadzero -qfixed + LFLAGS = -qstrict -bmaxdata:0x80000000 -qipa +else + $(error $(OS) is not a valid OS) +endif +endif +endif +endif +endif +ifeq ($(fcompiler),gfortran) + ifneq (,$(filter $(ARCH),i386 i686 x86_64)) + summary = + else + summary = -ffpe-summary=none + endif + ifeq ($(OS),Darwin) + summary = -ffpe-summary=none + endif + FFLAGS += $(summary) + FFLAG77 += -frecord-marker=4 $(summary) +endif + +ifeq ($(intel),1) + FFLAGS = -fPIC + FFLAG77 = -fPIC + lib = ../lib/$(DIRNAME)_intel + libUtl = ../../Utilib/lib/$(DIRNAME)_intel + libGan = ../../Ganlib/lib/$(DIRNAME)_intel + bin = ../bin/$(DIRNAME)_intel + INCLUDE = -I../../Ganlib/lib/$(DIRNAME)_intel/modules/ +else + ifeq ($(nvidia),1) + lib = ../lib/$(DIRNAME)_nvidia + libUtl = ../../Utilib/lib/$(DIRNAME)_nvidia + libGan = ../../Ganlib/lib/$(DIRNAME)_nvidia + bin = ../bin/$(DIRNAME)_nvidia + INCLUDE = -I../../Ganlib/lib/$(DIRNAME)_nvidia/modules/ + else + ifeq ($(llvm),1) + lib = ../lib/$(DIRNAME)_llvm + libUtl = ../../Utilib/lib/$(DIRNAME)_llvm + libGan = ../../Ganlib/lib/$(DIRNAME)_llvm + bin = ../bin/$(DIRNAME)_llvm + INCLUDE = -I../../Ganlib/lib/$(DIRNAME)_llvm/modules/ + FFLAGS += -mmlir -fdynamic-heap-array + LFLAGS += -lclang_rt.osx + else + lib = ../lib/$(DIRNAME) + libUtl = ../../Utilib/lib/$(DIRNAME) + libGan = ../../Ganlib/lib/$(DIRNAME) + bin = ../bin/$(DIRNAME) + INCLUDE = -I../../Ganlib/lib/$(DIRNAME)/modules/ + endif + endif +endif + +ifeq ($(hdf5),1) + FLAGS += -DHDF5_LIB -I${HDF5_INC} + FFLAGS += -I${HDF5_INC} + LFLAGS += -L${HDF5_API} -lhdf5 +endif + +SRC77 = $(shell ls *.f) +ifeq ($(python_version_major),2) + SRC90 = $(shell python ../../script/make_depend.py *.f90) +else + SRC90 = $(shell python3 ../../script/make_depend_py3.py *.f90) +endif +OBJ90 = $(SRC90:.f90=.o) +OBJ77 = $(SRC77:.f=.o) +all : sub-make Trivac +ifeq ($(openmp),1) + @echo 'Trivac: openmp is defined' +endif +ifeq ($(intel),1) + @echo 'Trivac: intel is defined' +endif +ifeq ($(nvidia),1) + @echo 'Trivac: nvidia is defined' +endif +ifeq ($(llvm),1) + @echo 'Trivac: llvm is defined' +endif +ifeq ($(hdf5),1) + @echo 'Trivac: hdf5 is defined' +endif +sub-make: + $(MAKE) openmp=$(openmp) intel=$(intel) nvidia=$(nvidia) llvm=$(llvm) -C ../../Utilib/src + $(MAKE) openmp=$(openmp) intel=$(intel) nvidia=$(nvidia) llvm=$(llvm) hdf5=$(hdf5) -C ../../Ganlib/src +%.o : %.f90 + $(F90) $(FFLAGS) $(opt) $(COMP) $(INCLUDE) -c $< -o $@ +%.o : %.f + $(F90) $(FFLAG77) $(opt) $(COMP) $(INCLUDE) -c $< -o $@ +$(lib)/: + mkdir -p $(lib)/ +libTrivac.a: $(OBJ90) $(OBJ77) $(lib)/ + ar r $@ $(OBJ90) $(OBJ77) + cp $@ $(lib)/$@ +$(bin)/: + mkdir -p $(bin)/ +Trivac: libTrivac.a TRIVAC.o $(bin)/ sub-make + $(F90) $(opt) $(COMP) TRIVAC.o $(lib)/libTrivac.a $(libUtl)/libUtilib.a \ + $(libGan)/libGanlib.a $(LFLAGS) -o Trivac + cp $@ $(bin)/$@ +clean: + $(MAKE) -C ../../Utilib/src clean + $(MAKE) -C ../../Ganlib/src clean + /bin/rm -f *.o *.a sub-make temp.* Trivac diff --git a/Trivac/src/NEIGH1.f b/Trivac/src/NEIGH1.f new file mode 100755 index 0000000..1293bab --- /dev/null +++ b/Trivac/src/NEIGH1.f @@ -0,0 +1,1603 @@ +*DECK NEIGH1 + SUBROUTINE NEIGH1 (NC,N,K,M,POIDS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the index of a neighbour hexagon for a given symmetry. +* The following SUBROUTINE points are available: +* NEIGH1: S30 symmetry; NEIGH2: SA60 symmetry; +* NEIGH3: SB60 symmetry; NEIGH4: S90 symmetry; +* NEIGH5: R120 symmetry; NEIGH6: R180 symmetry; +* NEIGH7: SA180 symmetry; NEIGH8: SB180 symmetry; +* NEIGH9: complete assembly; NEIG10: S30 symmetry with HBC SYME; +* NEIG11: SA60 symmetry with HBC SYME. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Benaboud +* +*Parameters: input +* NC total number of hexagonal crowns. +* N index of the considered hexagon. +* K index of the side. +* POIDS weight of the hexagon. +* +*Parameters: output +* M index of the neighbour hexagon (=n: reflection on side k; +* .LT.0: axial symmetry or rotation). +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NC,N,K,M + REAL POIDS +*---- +* LOCAL VARIABLES +*---- + LOGICAL EVEN + INTEGER, DIMENSION(:), ALLOCATABLE :: NBA,FSTA,LSTA +* + ALLOCATE(NBA(NC+2),FSTA(NC+2),LSTA(NC+2)) + EVEN=.TRUE. + NBA(:NC+2)=0 + FSTA(:NC+2)=0 + LSTA(:NC+2)=0 + FSTA(1) = 1 + IL=0 + DO 1 L = 1,NC+1,2 + NBA(L) = 1+IL + NBA(L+1) = 1+IL + IL = IL+1 + 1 CONTINUE + DO 2 L = 2,NC+1 + FSTA(L) = FSTA(L-1)+NBA(L-1) + 2 CONTINUE + IL=0 + DO 3 L = 1,NC+1,2 + LSTA(L) = FSTA(L)+IL + LSTA(L+1) = FSTA(L+1)+IL + IL = IL+1 + 3 CONTINUE +* + I=1 + IF (N.GT.1) THEN + I=0 + DO 4 I0 = 1,NC + IF ((N.GE.FSTA(I0)).AND.(N.LE.LSTA(I0))) THEN + I=I0 + GO TO 5 + ENDIF + 4 CONTINUE + 5 IF (I.EQ.0) CALL XABORT('NEIGH1: ALGORITHM FAILURE.') + ENDIF +* + N1 = FSTA(I) + N2 = LSTA(I) + EVEN = MOD(I,2).EQ.0 +* + IF (K.EQ.1) THEN +* + IF (N.EQ.1) THEN + M = 2 + ELSE IF (EVEN) THEN + M = N+NBA(I)+1 + ELSE IF (.NOT.EVEN) THEN + M = N+NBA(I) + ENDIF +* + ELSE IF (K.EQ.2) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF (N.EQ.N2) THEN + M = -(LSTA(I+1)-1) + ELSE + M = N+1 + ENDIF +* + ELSE IF (K.EQ.3) THEN +* + IF ((N.EQ.1).OR.(N.EQ.2)) THEN + M = -2 + ELSE IF (N.EQ.N2) THEN + M = -(N-1) + ELSE IF (EVEN) THEN + M = N-NBA(I-1)+1 + ELSE IF (.NOT.EVEN) THEN + M = N-NBA(I-1) + ENDIF +* + ELSE IF (K.EQ.4) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + M = -FSTA(I-1) + ELSE IF (EVEN) THEN + M = N-NBA(I-1) + ELSE IF (.NOT.EVEN) THEN + M = N-NBA(I-1)-1 + ENDIF +* + ELSE IF (K.EQ.5) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF ((N.EQ.N1).AND.EVEN) THEN + M = N + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + M = -(N+1) + ELSE + M = N-1 + ENDIF +* + ELSE IF (K.EQ.6) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + M = -FSTA(I+1) + ELSE IF (EVEN) THEN + M = N+NBA(I) + ELSE IF (.NOT.EVEN) THEN + M = N+NBA(I)-1 + ENDIF +* + ENDIF +* + IF (N.EQ.1) THEN + POIDS = 1./12. + ELSE IF (N.EQ.N2) THEN + POIDS = 0.5 + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + POIDS = 0.5 + ELSE + POIDS = 1. + ENDIF + DEALLOCATE(NBA,FSTA,LSTA) + RETURN + END +* + SUBROUTINE NEIGH2 (NC,N,K,M,POIDS) +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NC,N,K,M + REAL POIDS +*---- +* LOCAL VARIABLES +*---- + LOGICAL EVEN + INTEGER, DIMENSION(:), ALLOCATABLE :: NBA,FSTA,LSTA +* + ALLOCATE(NBA(NC+2),FSTA(NC+2),LSTA(NC+2)) + EVEN=.TRUE. + NBA(:NC+2)=0 + FSTA(:NC+2)=0 + LSTA(:NC+2)=0 + NBA(1) = 1 + LSTA(1) = 1 + FSTA(1) = 1 + FSTA(2) = 2 + DO 7 L = 2,NC+1 + NBA(L) = L + LSTA(L) = L+LSTA(L-1) + FSTA(L+1) = L+FSTA(L) + 7 CONTINUE +* + I=0 + DO 8 I0 = 1,NC + IF ((N.GE.FSTA(I0)).AND.(N.LE.LSTA(I0))) THEN + I=I0 + GO TO 9 + ENDIF + 8 CONTINUE + IF (I.EQ.0) CALL XABORT('NEIGH2: ALGORITHM FAILURE.') +* + 9 N1 = FSTA(I) + N2 = LSTA(I) +* + IF (K.EQ.1) THEN +* + M = N+NBA(I)+1 +* + ELSE IF (K.EQ.2) THEN +* + IF (N.EQ.N2) THEN + M = -(N+NBA(I)) + ELSE + M = N+1 + ENDIF +* + ELSE IF (K.EQ.3) THEN +* + IF (N.EQ.1) THEN + M = -3 + ELSE IF (N.EQ.N2) THEN + M = -(N-1) + ELSE + M = N-NBA(I-1) + ENDIF +* + ELSE IF (K.EQ.4) THEN +* + IF (N.EQ.N1) THEN + M = -(N+1) + ELSE + M = N-NBA(I-1)-1 + ENDIF +* + ELSE IF (K.EQ.5) THEN +* + IF (N.EQ.N1) THEN + M = -(N+NBA(I)+1) + ELSE + M = N-1 + ENDIF +* + ELSE IF (K.EQ.6) THEN +* + M = N+NBA(I) +* + ENDIF +* + IF (N.EQ.1) THEN + POIDS = 1./6. + ELSE IF ((N.EQ.N1).OR.(N.EQ.N2)) THEN + POIDS = 0.5 + ELSE + POIDS = 1. + ENDIF + DEALLOCATE(NBA,FSTA,LSTA) + RETURN + END +* + SUBROUTINE NEIGH3 (NC,N,K,M,POIDS) +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NC,N,K,M + REAL POIDS +*---- +* LOCAL VARIABLES +*---- + LOGICAL EVEN + INTEGER, DIMENSION(:), ALLOCATABLE :: NBA,FSTA,LSTA +* + ALLOCATE(NBA(NC+2),FSTA(NC+2),LSTA(NC+2)) + EVEN=.TRUE. + NBA(:NC+2)=0 + FSTA(:NC+2)=0 + LSTA(:NC+2)=0 + LSTA(1) = 1 + FSTA(1) = 1 + IL=0 + DO 10 L = 1,NC+1,2 + NBA(L) = 1+IL + NBA(L+1) = 1+IL + IL = IL+2 + 10 CONTINUE + DO 11 L = 2,NC+1 + FSTA(L) = FSTA(L-1)+NBA(L-1) + LSTA(L) = NBA(L)+LSTA(L-1) + 11 CONTINUE +* + I=0 + N1=0 + N2=0 + N3=0 + IF (N.EQ.1) GOTO 14 + DO 12 I0 = 1,NC + IF ((N.GE.FSTA(I0)).AND.(N.LE.LSTA(I0))) THEN + I=I0 + GO TO 13 + ENDIF + 12 CONTINUE + IF (I.EQ.0) CALL XABORT('NEIGH3: ALGORITHM FAILURE.') +* + 13 N1 = FSTA(I) + N2 = (FSTA(I)+LSTA(I))/2 + N3 = LSTA(I) + EVEN = MOD(I,2).EQ.0 +* + 14 IF (K.EQ.1) THEN +* + IF (N.EQ.1) THEN + M = 2 + ELSE IF ((N.GE.N1).AND.(N.LE.N3)) THEN + M = N+I + ENDIF +* + ELSE IF (K.EQ.2) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF (N.EQ.2) THEN + M = 5 + ELSE IF ((N.GE.N1).AND.(N.LT.N2)) THEN + M = N+1 + ELSE IF ((N.GE.N2).AND.(N.LT.N3)) THEN + M = N+I+1 + ELSE IF ((N.EQ.N3).AND.EVEN) THEN + M = LSTA(I+1) + ELSE IF ((N.EQ.N3).AND.(.NOT.EVEN)) THEN + M = -LSTA(I+1) + ENDIF +* + ELSE IF (K.EQ.3) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF (N.EQ.2) THEN + M = 2 + ELSE IF ((N.GE.N1).AND.(N.LT.N2)) THEN + M = N+2-I + ELSE IF ((N.GE.N2).AND.(N.LT.N3)) THEN + M = N+1 + ELSE IF ((N.EQ.N3).AND.EVEN) THEN + M = N + ELSE IF ((N.EQ.N3).AND.(.NOT.EVEN)) THEN + M = -(N-1) + ENDIF +* + ELSE IF (K.EQ.4) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF ((N.EQ.N1).AND.EVEN) THEN + M = N+1-I + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + M = -(N+2-I) + ELSE IF ((N.GT.N1).AND.(N.LT.N3)) THEN + M = N+1-I + ELSE IF ((N.EQ.N3).AND.EVEN) THEN + M = N+1-I + ELSE IF ((N.EQ.N3).AND.(.NOT.EVEN)) THEN + M = -(N-I) + ENDIF +* + ELSE IF (K.EQ.5) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF ((N.EQ.N1).AND.EVEN) THEN + M = N + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + M = -(N+1) + ELSE IF ((N.GT.N1).AND.(N.LE.N2)) THEN + M = N-1 + ELSE IF ((N.GT.N2).AND.(N.LE.N3)) THEN + M = N-I + ENDIF +* + ELSE IF (K.EQ.6) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF ((N.EQ.N1).AND.EVEN) THEN + M = N+I-1 + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + M = -(N+I) + ELSE IF ((N.GT.N1).AND.(N.LE.N2)) THEN + M = N+I-1 + ELSE IF ((N.GT.N2).AND.(N.LE.N3)) THEN + M = N-1 + ENDIF +* + ENDIF +* + IF (N.EQ.1) THEN + POIDS = 1./6. + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + POIDS = 0.5 + ELSE IF ((N.EQ.N3).AND.(.NOT.EVEN)) THEN + POIDS = 0.5 + ELSE + POIDS = 1. + ENDIF + DEALLOCATE(NBA,FSTA,LSTA) + RETURN + END +* + SUBROUTINE NEIGH4 (NC,N,K,M,POIDS) +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NC,N,K,M + REAL POIDS +*---- +* LOCAL VARIABLES +*---- + LOGICAL EVEN + INTEGER, DIMENSION(:), ALLOCATABLE :: NBA,FSTA,LSTA,INTA +* + ALLOCATE(NBA(NC+2),FSTA(NC+2),LSTA(NC+2),INTA(NC+2)) + EVEN=.TRUE. + NBA(:NC+2)=0 + FSTA(:NC+2)=0 + LSTA(:NC+2)=0 + INTA(:NC+2)=0 + LSTA(1) = 1 + FSTA(1) = 1 + IL=0 + DO 15 L = 1,NC+1,2 + NBA(L) = L+IL + NBA(L+1) = L+1+IL + IL = IL+1 + 15 CONTINUE + DO 16 L = 2,NC+1 + FSTA(L) = FSTA(L-1)+NBA(L-1) + LSTA(L) = NBA(L)+LSTA(L-1) + 16 CONTINUE + IL=0 + DO 17 L = 1,NC+1,2 + INTA(L) = FSTA(L)+IL + INTA(L+1) = FSTA(L+1)+IL + IL = IL+1 + 17 CONTINUE +* + I=0 + N1=0 + N2=0 + N3=0 + IF (N.EQ.1) GOTO 20 + DO 18 I0 = 1,NC + IF ((N.GE.FSTA(I0)).AND.(N.LE.LSTA(I0))) THEN + I=I0 + GO TO 19 + ENDIF + 18 CONTINUE + IF (I.EQ.0) CALL XABORT('NEIGH4: ALGORITHM FAILURE.') +* + 19 N1 = FSTA(I) + N2 = INTA(I) + N3 = LSTA(I) + EVEN = MOD(I,2).EQ.0 +* + 20 IF (K.EQ.1) THEN +* + IF (N.EQ.1) THEN + M = 2 + ELSE IF ((N.GE.N1).AND.(N.LE.N3).AND.EVEN) THEN + M = N+NBA(I)+1 + ELSE IF ((N.GE.N1).AND.(N.LE.N3).AND.(.NOT.EVEN)) THEN + M = N+NBA(I) + ENDIF +* + ELSE IF (K.EQ.2) THEN +* + IF (N.EQ.1) THEN + M = 3 + ELSE IF (N.EQ.2) THEN + M = 6 + ELSE IF (N.EQ.N1) THEN + M = N+1 + ELSE IF ((N.GT.N1).AND.(N.LT.N2)) THEN + M = N+1 + ELSE IF ((N.GE.N2).AND.(N.LE.N3)) THEN + M = N+NBA(I+1) + ENDIF +* + ELSE IF (K.EQ.3) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF (N.EQ.2) THEN + M = 3 + ELSE IF ((N.EQ.N1).AND.EVEN) THEN + M = FSTA(I-1)+1 + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + M = FSTA(I-1) + ELSE IF ((N.GT.N1).AND.(N.LT.N2).AND.EVEN) THEN + M = N-(I-1)-(INTA(I-1)-FSTA(I-1))+1 + ELSE IF ((N.GT.N1).AND.(N.LT.N2).AND.(.NOT.EVEN)) THEN + M = N-(I-1)-(INTA(I-1)-FSTA(I-1)) + ELSE IF ((N.GE.N2).AND.(N.LT.N3)) THEN + M = N+1 + ELSE IF (N.EQ.N3) THEN + M = -(LSTA(I+1)-1) + ENDIF +* + ELSE IF (K.EQ.4) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF ((N.EQ.N1).AND.EVEN) THEN + M = FSTA(I-1) + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + M = -FSTA(I-1) + ELSE IF ((N.GT.N1).AND.(N.LT.N3).AND.EVEN) THEN + M = N-NBA(I-1) + ELSE IF ((N.GT.N1).AND.(N.LT.N3).AND.(.NOT.EVEN)) THEN + M = N-NBA(I-1)-1 + ELSE IF (N.EQ.N3) THEN + M = -(N-1) + ENDIF +* + ELSE IF (K.EQ.5) THEN +* + IF (N.EQ.1) THEN + M = -3 + ELSE IF ((N.EQ.N1).AND.EVEN) THEN + M = N + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + M = -(N+1) + ELSE IF ((N.GT.N1).AND.(N.LE.N2)) THEN + M = N-1 + ELSE IF ((N.GT.N2).AND.(N.LE.N3)) THEN + M = N-NBA(I) + ENDIF +* + ELSE IF (K.EQ.6) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF ((N.EQ.N1).AND.EVEN) THEN + M = FSTA(I+1) + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + M = -FSTA(I+1) + ELSE IF ((N.GT.N1).AND.(N.LT.N2).AND.EVEN) THEN + M = N+I+INTA(I)-FSTA(I) + ELSE IF ((N.GT.N1).AND.(N.LT.N2).AND.(.NOT.EVEN)) THEN + M = N+I+INTA(I)-FSTA(I)-1 + ELSE IF (N.EQ.N2) THEN + M = INTA(I+1)-1 + ELSE IF ((N.GT.N2).AND.(N.LE.N3)) THEN + M = N-1 + ENDIF +* + ENDIF +* + IF (N.EQ.1) THEN + POIDS = 0.25 + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + POIDS = 0.5 + ELSE IF (N.EQ.N3) THEN + POIDS = 0.5 + ELSE + POIDS = 1. + ENDIF + DEALLOCATE(NBA,FSTA,LSTA,INTA) + RETURN + END +* + SUBROUTINE NEIGH5 (NC,N,K,M,POIDS) +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NC,N,K,M + REAL POIDS +*---- +* LOCAL VARIABLES +*---- + LOGICAL EVEN + INTEGER, DIMENSION(:), ALLOCATABLE :: NBA,FSTA,LSTA +* + ALLOCATE(NBA(NC+2),FSTA(NC+2),LSTA(NC+2)) + EVEN=.TRUE. + NBA(:NC+2)=0 + FSTA(:NC+2)=0 + LSTA(:NC+2)=0 + NBA (1) = 1 + LSTA(1) = 1 + FSTA(1) = 1 + DO 21 L = 2,NC+1 + NBA(L) = 2*(L-1) + LSTA(L) = NBA(L)+LSTA(L-1) + FSTA(L) = NBA(L-1)+FSTA(L-1) + 21 CONTINUE +* + I=0 + DO 22 I0 = 1,NC + IF ((N.GE.FSTA(I0)).AND.(N.LE.LSTA(I0))) THEN + I=I0 + GO TO 23 + ENDIF + 22 CONTINUE + IF (I.EQ.0) CALL XABORT('NEIGH5: ALGORITHM FAILURE.') +* + 23 N1 = FSTA(I) + N2 = FSTA(I) + (I-2) + N3 = LSTA(I) +* + IF (K.EQ.1) THEN +* + IF (N.EQ.1) THEN + M = 2 + ELSE IF ((N.GE.N1).AND.(N.LT.N2).AND.(N.NE.1)) THEN + M = N+NBA(I+1)-1 + ELSE IF ((N.GE.N2).AND.(N.LT.N3)) THEN + M = N+NBA(I)+1 + ELSE IF (N.EQ.N3) THEN + M = N+NBA(I+1)-1 + ENDIF +* + ELSE IF (K.EQ.2) THEN +* + IF (N.EQ.1) THEN + M = 3 + ELSE IF (N.EQ.2) THEN + M = 6 + ELSE IF ((N.GE.N1).AND.(N.LT.N2)) THEN + M = N+1 + ELSE IF ((N.GE.N2).AND.(N.LT.N3)) THEN + M = N+NBA(I)+2 + ELSE IF (N.EQ.N3) THEN + M = N+NBA(I+1) + ENDIF +* + ELSE IF (K.EQ.3) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF (N.EQ.2) THEN + M = 3 + ELSE IF ((N.GE.N1).AND.(N.LT.N2).AND.(N.NE.1)) THEN + M = N-NBA(I-1) + ELSE IF ((N.GE.N2).AND.(N.LT.N3)) THEN + M = N+1 + ELSE IF (N.EQ.N3) THEN + M = -(N+1) + ENDIF +* + ELSE IF (K.EQ.4) THEN +* + IF (N.EQ.1) THEN + M = -3 + ELSE IF (N.EQ.2) THEN + M = 1 + ELSE IF (N.EQ.3) THEN + M = -2 + ELSE IF ((N.EQ.N1).AND.(N.NE.1)) THEN + M = -LSTA(I-1) + ELSE IF ((N.GT.N1).AND.(N.LT.N3)) THEN + M = N-NBA(I-1)-1 + ELSE IF ((N.EQ.N3).AND.(N.NE.3)) THEN + M = -(N-NBA(I-1)-1) + ENDIF +* + ELSE IF (K.EQ.5) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF (N.EQ.2) THEN + M = -3 + ELSE IF ((N.EQ.N1).AND.(N.NE.1)) THEN + M = -LSTA(I) + ELSE IF ((N.GT.N1).AND.(N.LE.N2).AND.(N.NE.3)) THEN + M = N-1 + ELSE IF ((N.GT.N2).AND.(N.LT.N3)) THEN + M = N-NBA(I-1)-2 + ELSE IF (N.EQ.N3) THEN + M = N-NBA(I) + ENDIF +* + ELSE IF (K.EQ.6) THEN +* + IF (N.EQ.1) THEN + M = -3 + ELSE IF (N.EQ.3) THEN + M = 2 + ELSE IF ((N.EQ.N1).AND.(N.NE.1)) THEN + M = FSTA(I+1) + ELSE IF ((N.GT.N1).AND.(N.LT.N2)) THEN + M = N+NBA(I+1)-2 + ELSE IF (N.EQ.N2) THEN + M = N+NBA(I) + ELSE IF ((N.GT.N2).AND.(N.LE.N3)) THEN + M = N-1 + ENDIF +* + ENDIF +* + IF (N.EQ.1) THEN + POIDS = 1./3. + ELSE + POIDS = 1. + ENDIF + DEALLOCATE(NBA,FSTA,LSTA) + RETURN + END +* + SUBROUTINE NEIGH6 (NC,N,K,M,POIDS) +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NC,N,K,M + REAL POIDS +*---- +* LOCAL VARIABLES +*---- + LOGICAL EVEN + INTEGER, DIMENSION(:), ALLOCATABLE :: NBA,FSTA,LSTA +* + ALLOCATE(NBA(NC+2),FSTA(NC+2),LSTA(NC+2)) + EVEN=.TRUE. + NBA(:NC+2)=0 + FSTA(:NC+2)=0 + LSTA(:NC+2)=0 + NBA (1) = 1 + LSTA(1) = 1 + FSTA(1) = 1 + DO 24 L = 2,NC+1 + NBA(L) = 3*(L-1) + LSTA(L) = NBA(L)+LSTA(L-1) + FSTA(L) = NBA(L-1)+FSTA(L-1) + 24 CONTINUE +* + I=0 + N1=0 + N2=0 + N3=0 + N4=0 + IF (N.EQ.1) GOTO 27 + DO 25 I0 = 1,NC + IF ((N.GE.FSTA(I0)).AND.(N.LE.LSTA(I0))) THEN + I=I0 + GO TO 26 + ENDIF + 25 CONTINUE + IF (I.EQ.0) CALL XABORT('NEIGH6: ALGORITHM FAILURE.') +* + 26 N1 = FSTA(I) + N2 = LSTA(I-1) + (I-1) + N3 = LSTA(I-1) + 2*(I-1) + N4 = LSTA(I) +* + 27 IF (K.EQ.1) THEN +* + IF (N.EQ.1) THEN + M = 3 + ELSE IF (N.EQ.2) THEN + M = 7 + ELSE IF ((N.GE.N1).AND.(N.LT.N2)) THEN + M = N+1 + ELSE IF ((N.GE.N2).AND.(N.LE.N4)) THEN + M = N+NBA(I)+2 + ENDIF +* + ELSE IF (K.EQ.2) THEN +* + IF (N.EQ.1) THEN + M = 4 + ELSE IF (N.EQ.2) THEN + M = 3 + ELSE IF ((N.GE.N1).AND.(N.LT.N2)) THEN + M = N-NBA(I-1) + ELSE IF ((N.GE.N2).AND.(N.LT.N3)) THEN + M = N+1 + ELSE IF ((N.GE.N3).AND.(N.LE.N4)) THEN + M = N+NBA(I+1) + ENDIF +* + ELSE IF (K.EQ.3) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF (N.EQ.2) THEN + M = 1 + ELSE IF (N.EQ.N1) THEN + M = -(N-1) + ELSE IF ((N.GT.N1).AND.(N.LT.N3)) THEN + M = N-NBA(I-1)-1 + ELSE IF ((N.GE.N3).AND.(N.LT.N4)) THEN + M = N+1 + ELSE IF (N.EQ.N4) THEN + M = -(N+1) + ENDIF +* + ELSE IF (K.EQ.4) THEN +* + IF (N.EQ.1) THEN + M = -3 + ELSE IF (N.EQ.2) THEN + M = -4 + ELSE IF (N.EQ.3) THEN + M = 1 + ELSE IF (N.EQ.N1) THEN + M = -LSTA(I) + ELSE IF ((N.GT.N1).AND.(N.LE.N2)) THEN + M = N-1 + ELSE IF ((N.GT.N2).AND.(N.LT.N4)) THEN + M = N-NBA(I)+1 + ELSE IF (N.EQ.N4) THEN + M = -(N-NBA(I)+1) + ENDIF +* + ELSE IF (K.EQ.5) THEN +* + IF (N.EQ.1) THEN + M = -4 + ELSE IF (N.EQ.3) THEN + M = 2 + ELSE IF ((N.GE.N1).AND.(N.LE.N2)) THEN + M = N+NBA(I) + ELSE IF ((N.GT.N2).AND.(N.LE.N3)) THEN + M = N-1 + ELSE IF ((N.GT.N3).AND.(N.LE.N4)) THEN + M = N-NBA(I) + ENDIF +* + ELSE IF (K.EQ.6) THEN +* + IF (N.EQ.1) THEN + M = 2 + ELSE IF ((N.GE.N1).AND.(N.LE.N3)) THEN + M = N+NBA(I)+1 + ELSE IF ((N.GT.N3).AND.(N.LE.N4)) THEN + M = N-1 + ENDIF +* + ENDIF +* + IF (N.EQ.1) THEN + POIDS = 1./2. + ELSE + POIDS = 1. + ENDIF + DEALLOCATE(NBA,FSTA,LSTA) + RETURN + END +* + SUBROUTINE NEIGH7 (NC,N,K,M,POIDS) +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NC,N,K,M + REAL POIDS +*---- +* LOCAL VARIABLES +*---- + LOGICAL EVEN + INTEGER, DIMENSION(:), ALLOCATABLE :: NBA,FSTA,LSTA +* + ALLOCATE(NBA(NC+2),FSTA(NC+2),LSTA(NC+2)) + EVEN=.TRUE. + NBA(:NC+2)=0 + FSTA(:NC+2)=0 + LSTA(:NC+2)=0 + NBA (1) = 1 + LSTA(1) = 1 + FSTA(1) = 1 + DO 28 L = 2,NC+1 + NBA(L) = 3+NBA(L-1) + LSTA(L) = NBA(L)+LSTA(L-1) + FSTA(L) = 1+LSTA(L-1) + 28 CONTINUE +* + I=0 + DO 29 I0 = 1,NC + IF ((N.GE.FSTA(I0)).AND.(N.LE.LSTA(I0))) THEN + I=I0 + GO TO 30 + ENDIF + 29 CONTINUE + IF (I.EQ.0) CALL XABORT('NEIGH7: ALGORITHM FAILURE.') +* + 30 N1 = FSTA(I) + N2 = FSTA(I) + (I-1) + N3 = FSTA(I) + 2*(I-1) + N4 = LSTA(I) +* + IF (K.EQ.1) THEN +* + IF (N.EQ.1) THEN + M = 4 + ELSE IF ((N.GE.N1).AND.(N.LT.N2).AND.(N.NE.1)) THEN + M = N+1 + ELSE IF ((N.GE.N2).AND.(N.LT.N3)) THEN + M = NBA(I)+N+2 + ELSE IF ((N.GE.N3).AND.(N.LE.N4)) THEN + M = NBA(I+1)+N-1 + ENDIF +* + ELSE IF (K.EQ.2) THEN +* + IF (N.EQ.1) THEN + M = 5 + ELSE IF ((N.GE.N1).AND.(N.LT.N2).AND.(N.NE.1)) THEN + M = N-NBA(I-1) + ELSE IF ((N.GE.N2).AND.(N.LT.N3)) THEN + M = N+1 + ELSE IF ((N.GE.N3).AND.(N.LE.N4)) THEN + M = N+NBA(I+1) + ENDIF +* + ELSE IF (K.EQ.3) THEN +* + IF (N.EQ.1) THEN + M = -4 + ELSE IF ((N.EQ.N1).AND.(N.NE.1)) THEN + M = -(N+1) + ELSE IF ((N.GT.N1).AND.(N.LT.N3)) THEN + M = N-NBA(I-1)-1 + ELSE IF ((N.GE.N3).AND.(N.LT.N4)) THEN + M = N+1 + ELSE IF (N.EQ.N4) THEN + M = -(N+NBA(I+1)-1) + ENDIF +* + ELSE IF (K.EQ.4) THEN +* + IF (N.EQ.1) THEN + M = -3 + ELSE IF ((N.EQ.N1).AND.(N.NE.1)) THEN + M = -(FSTA(I+1)+1) + ELSE IF ((N.GT.N1).AND.(N.LE.N2)) THEN + M = N-1 + ELSE IF ((N.GT.N2).AND.(N.LT.N3)) THEN + M = N-NBA(I-1)-2 + ELSE IF ((N.GE.N3).AND.(N.LT.N4)) THEN + M = N-NBA(I)+1 + ELSE IF (N.EQ.N4) THEN + M = -(N-1) + ENDIF +* + ELSE IF (K.EQ.5) THEN +* + IF (N.EQ.N1) THEN + M = FSTA(I+1) + ELSE IF ((N.GT.N1).AND.(N.LE.N2)) THEN + M = N+NBA(I) + ELSE IF ((N.GT.N2).AND.(N.LE.N3)) THEN + M = N-1 + ELSE IF ((N.GT.N3).AND.(N.LE.N4)) THEN + M = N-NBA(I) + ENDIF +* + ELSE IF (K.EQ.6) THEN +* + IF (N.EQ.N1) THEN + M = FSTA(I+1)+1 + ELSE IF ((N.GT.N1).AND.(N.LT.N3)) THEN + M = N+NBA(I)+1 + ELSE IF (N.EQ.N3) THEN + M = N+NBA(I+1)-2 + ELSE IF ((N.GT.N3).AND.(N.LE.N4)) THEN + M = N-1 + ENDIF +* + ENDIF +* + IF ((N.EQ.N1).OR.(N.EQ.N4)) THEN + POIDS = 0.5 + ELSE + POIDS = 1. + ENDIF + DEALLOCATE(NBA,FSTA,LSTA) + RETURN + END +* + SUBROUTINE NEIGH8 (NC,N,K,M,POIDS) +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NC,N,K,M + REAL POIDS +*---- +* LOCAL VARIABLES +*---- + LOGICAL EVEN + INTEGER, DIMENSION(:), ALLOCATABLE :: NBA,FSTA,LSTA +* + ALLOCATE(NBA(NC+2),FSTA(NC+2),LSTA(NC+2)) + EVEN=.TRUE. + NBA(:NC+2)=0 + FSTA(:NC+2)=0 + LSTA(:NC+2)=0 + NBA (1) = 1 + LSTA(1) = 1 + FSTA(1) = 1 + DO 31 L = 2,NC+1,2 + NBA(L) = 3*(L-1) + NBA(L+1) = 3*L+1 + 31 CONTINUE + DO 32 L = 2,NC+1 + LSTA(L) = NBA(L)+LSTA(L-1) + FSTA(L) = NBA(L-1)+FSTA(L-1) + 32 CONTINUE +* + I=0 + N1=0 + N2=0 + N3=0 + N4=0 + N5=0 + IF (N.EQ.1) GOTO 35 + DO 33 I0 = 1,NC + IF ((N.GE.FSTA(I0)).AND.(N.LE.LSTA(I0))) THEN + I=I0 + GO TO 34 + ENDIF + 33 CONTINUE + IF (I.EQ.0) CALL XABORT('NEIGH8: ALGORITHM FAILURE.') +* + 34 N1 = FSTA(I) + N2 = (FSTA(I) + LSTA(I))/2 - (I-1) + N3 = (FSTA(I) + LSTA(I))/2 + N4 = (FSTA(I) + LSTA(I))/2 + (I-1) + N5 = LSTA(I) + EVEN = MOD(I,2).EQ.0 +* + 35 IF (K.EQ.1) THEN +* + IF (N.EQ.1) THEN + M = 2 + ELSE IF ((N.GE.N1).AND.(N.LE.N3)) THEN + M = N+3*I-2 + ELSE IF ((N.GT.N3).AND.(N.LE.N4)) THEN + M = N-1 + ELSE IF ((N.GT.N4).AND.(N.LE.N5)) THEN + M = N-(3*I-2) + ENDIF +* + ELSE IF (K.EQ.2) THEN +* + IF (N.EQ.1) THEN + M = 3 + ELSE IF (N.EQ.2) THEN + M = 7 + ELSE IF ((N.GE.N1).AND.(N.LT.N2)) THEN + M = N+1 + ELSE IF ((N.GE.N2).AND.(N.LE.N4)) THEN + M = N+3*I-1 + ELSE IF ((N.GT.N4).AND.(N.LE.N5)) THEN + M = N-1 + ENDIF +* + ELSE IF (K.EQ.3) THEN +* + IF (N.EQ.1) THEN + M = 4 + ELSE IF (N.EQ.2) THEN + M = 3 + ELSE IF ((N.GE.N1).AND.(N.LT.N2)) THEN + M = N-3*(I-2) + ELSE IF ((N.GE.N2).AND.(N.LT.N3)) THEN + M = N+1 + ELSE IF ((N.GE.N3).AND.(N.LE.N5)) THEN + M = N+3*I + ENDIF +* + ELSE IF (K.EQ.4) THEN +* + IF (N.EQ.1) THEN + M = -4 + ELSE IF ((N.EQ.N1).AND.EVEN) THEN + M = FSTA(I-1) + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + M = -FSTA(I-1) + ELSE IF ((N.GT.N1).AND.(N.LT.N3)) THEN + M = N-3*I+5 + ELSE IF ((N.GE.N3).AND.(N.LT.N4)) THEN + M = N+1 + ELSE IF ((N.GE.N4).AND.(N.LT.N5)) THEN + M = N+3*I+1 + ELSE IF ((N.EQ.N5).AND.EVEN) THEN + M = LSTA(I+1) + ELSE IF ((N.EQ.N5).AND.(.NOT.EVEN)) THEN + M = -LSTA(I+1) + ENDIF +* + ELSE IF (K.EQ.5) THEN +* + IF (N.EQ.1) THEN + M = -3 + ELSE IF ((N.EQ.N1).AND.EVEN) THEN + M = N + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + M = -(N+1) + ELSE IF ((N.GT.N1).AND.(N.LE.N2)) THEN + M = N-1 + ELSE IF ((N.GT.N2).AND.(N.LT.N4)) THEN + M = N-3*I+4 + ELSE IF ((N.GE.N4).AND.(N.LT.N5)) THEN + M = N+1 + ELSE IF ((N.EQ.N5).AND.EVEN) THEN + M = N + ELSE IF ((N.EQ.N5).AND.(.NOT.EVEN)) THEN + M = -(N-1) + ENDIF +* + ELSE IF (K.EQ.6) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF ((N.EQ.N1).AND.EVEN) THEN + M = FSTA(I+1) + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + M = -FSTA(I+1) + ELSE IF ((N.GT.N1).AND.(N.LE.N2)) THEN + M = N+3*(I-1) + ELSE IF ((N.GT.N2).AND.(N.LE.N3)) THEN + M = N-1 + ELSE IF ((N.GT.N3).AND.(N.LT.N5)) THEN + M = N-3*(I-1) + ELSE IF ((N.EQ.N5).AND.EVEN) THEN + M = LSTA(I-1) + ELSE IF ((N.EQ.N5).AND.(.NOT.EVEN)) THEN + M = -LSTA(I-1) + ENDIF +* + ENDIF +* + IF (N.EQ.1) THEN + POIDS = 0.5 + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + POIDS = 0.5 + ELSE IF ((N.EQ.N5).AND.(.NOT.EVEN)) THEN + POIDS = 0.5 + ELSE + POIDS = 1. + ENDIF + DEALLOCATE(NBA,FSTA,LSTA) + RETURN + END +* + SUBROUTINE NEIGH9 (NC,N,K,M,POIDS) +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NC,N,K,M + REAL POIDS +*---- +* LOCAL VARIABLES +*---- + LOGICAL EVEN + INTEGER, DIMENSION(:), ALLOCATABLE :: NBA,FSTA,LSTA +* + ALLOCATE(NBA(NC+2),FSTA(NC+2),LSTA(NC+2)) + EVEN=.TRUE. + NBA(:NC+2)=0 + FSTA(:NC+2)=0 + LSTA(:NC+2)=0 + POIDS = 1. + NBA(1) = 1 + LSTA(1) = 1 + FSTA(1) = 1 + DO 36 L = 2,NC+1 + NBA(L) = (L-1)*6 + LSTA(L) = 1+3*L*(L-1) + FSTA(L) = 1+LSTA(L-1) + 36 CONTINUE +* + I=0 + IF (N.EQ.1) THEN + M = K+1 + RETURN + ELSE IF(N.GT.1) THEN + DO 37 I0 = 2,NC + IF ((N.GE.FSTA(I0)).AND.(N.LE.LSTA(I0))) THEN + I=I0 + GO TO 38 + ENDIF + 37 CONTINUE + IF (I.EQ.0) CALL XABORT('NEIGH9: ALGORITHM FAILURE.') + ENDIF +* + 38 N1 = FSTA(I) + N2 = FSTA(I) + (I-1) + N3 = FSTA(I) + 2*(I-1) + N4 = FSTA(I) + 3*(I-1) + N5 = FSTA(I) + 4*(I-1) + N6 = FSTA(I) + 5*(I-1) + N7 = LSTA(I) +* + IF (K.EQ.1) THEN +* + IF (N.EQ.N1) THEN + M = FSTA(I+1) + ELSE IF ((N.GT.N1).AND.(N.LT.N2)) THEN + M = N+NBA(I) + ELSE IF (N.EQ.N2) THEN + M = FSTA(I+1)+I-1 + ELSE IF ((N.GT.N2).AND.(N.LE.N3)) THEN + M = N-1 + ELSE IF ((N.GT.N3).AND.(N.LT.N4)) THEN + M = N-NBA(I-1)-3 + ELSE IF (N.EQ.5) THEN + M = 1 + ELSE IF (N.EQ.N4) THEN + M = FSTA(I-1)+3*(I-2) + ELSE IF ((N.GT.N4).AND.(N.LT.N5)) THEN + M = N-NBA(I-1)-3 + ELSE IF ((N.GE.N5).AND.(N.LT.N6)) THEN + M = N+1 + ELSE IF (N.EQ.7) THEN + M = 19 + ELSE IF ((N.GE.N6).AND.(N.LE.N7)) THEN + M = N+NBA(I)+6 + ENDIF +* + ELSE IF (K.EQ.2) THEN +* + IF (N.EQ.N1) THEN + M = FSTA(I+1)+1 + ELSE IF ((N.GT.N1).AND.(N.LT.N2)) THEN + M = N+NBA(I)+1 + ELSE IF (N.EQ.N2) THEN + M = FSTA(I+1)+I + ELSE IF ((N.GT.N2).AND.(N.LE.N3)) THEN + M = N+NBA(I)+1 + ELSE IF ((N.GT.N3).AND.(N.LE.N4)) THEN + M = N-1 + ELSE IF ((N.GT.N4).AND.(N.LT.N5)) THEN + M = N-NBA(I-1)-4 + ELSE IF (N.EQ.6) THEN + M = 1 + ELSE IF (N.EQ.N5) THEN + M = FSTA(I-1)+4*(I-2) + ELSE IF ((N.GT.N5).AND.(N.LT.N6)) THEN + M = N-NBA(I-1)-4 + ELSE IF ((N.GE.N6).AND.(N.LT.N7)) THEN + M = N+1 + ELSE IF (N.EQ.N7) THEN + M = FSTA(I) + ENDIF +* + ELSE IF (K.EQ.3) THEN +* + IF ((N.GE.N1).AND.(N.LT.N2)) THEN + M = N+1 + ELSE IF (N.EQ.N2) THEN + M = FSTA(I+1)+I+1 + ELSE IF ((N.GT.N2).AND.(N.LE.N4)) THEN + M = N+NBA(I)+2 + ELSE IF ((N.GT.N4).AND.(N.LE.N5)) THEN + M = N-1 + ELSE IF (N.EQ.7) THEN + M = 1 + ELSE IF ((N.GT.N5).AND.(N.LT.N7)) THEN + M = N-NBA(I-1)-5 + ELSE IF (N.EQ.N7) THEN + M = FSTA(I-1) + ENDIF +* + ELSE IF (K.EQ.4) THEN +* + IF (N.EQ.2) THEN + M = 1 + ELSE IF ((N.GE.N1).AND.(N.LT.N2)) THEN + M = N-NBA(I-1) + ELSE IF ((N.GE.N2).AND.(N.LT.N3)) THEN + M = N+1 + ELSE IF ((N.GE.N3).AND.(N.LE.N5)) THEN + M = N+NBA(I)+3 + ELSE IF ((N.GT.N5).AND.(N.LE.N6)) THEN + M = N-1 + ELSE IF ((N.GT.N6).AND.(N.LT.N7)) THEN + M = N-NBA(I-1)-6 + ELSE IF (N.EQ.N7) THEN + M = LSTA(I-1) + ENDIF +* + ELSE IF (K.EQ.5) THEN +* + IF (N.EQ.N1) THEN + M = LSTA(I) + ELSE IF (N.EQ.3) THEN + M = 1 + ELSE IF (N.EQ.7) THEN + M = 17 + ELSE IF ((N.GT.N1).AND.(N.LT.N3)) THEN + M = N-NBA(I-1)-1 + ELSE IF ((N.GE.N3).AND.(N.LT.N4)) THEN + M = N+1 + ELSE IF ((N.GE.N4).AND.(N.LE.N6)) THEN + M = N+NBA(I)+4 + ELSE IF ((N.GT.N6).AND.(N.LE.N7)) THEN + M = N-1 + ENDIF +* + ELSE IF (K.EQ.6) THEN +* + IF (N.EQ.N1) THEN + M = LSTA(I+1) + ELSE IF ((N.GT.N1).AND.(N.LE.N2)) THEN + M = N-1 + ELSE IF ((N.GT.N2).AND.(N.LT.N4)) THEN + M = N-NBA(I-1)-2 + ELSE IF ((N.GE.N4).AND.(N.LT.N5)) THEN + M = N+1 + ELSE IF ((N.GE.N5).AND.(N.LE.N7)) THEN + M = N+NBA(I)+5 + ENDIF + ENDIF + DEALLOCATE(NBA,FSTA,LSTA) + RETURN + END +* + SUBROUTINE NEIG10 (NC,N,K,M,POIDS) +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NC,N,K,M + REAL POIDS +*---- +* LOCAL VARIABLES +*---- + LOGICAL EVEN,OUTER + INTEGER, DIMENSION(:), ALLOCATABLE :: NBA,FSTA,LSTA +* + ALLOCATE(NBA(NC+2),FSTA(NC+2),LSTA(NC+2)) + EVEN=.TRUE. + NBA(:NC+2)=0 + FSTA(:NC+2)=0 + LSTA(:NC+2)=0 + FSTA(1) = 1 + IL=0 + DO 39 L = 1,NC+1,2 + NBA(L) = 1+IL + NBA(L+1) = 1+IL + IL = IL+1 + 39 CONTINUE + DO 40 L = 2,NC+1 + FSTA(L) = FSTA(L-1)+NBA(L-1) + 40 CONTINUE + IL=0 + DO 41 L = 1,NC+1,2 + LSTA(L) = FSTA(L)+IL + LSTA(L+1) = FSTA(L+1)+IL + IL = IL+1 + 41 CONTINUE +* + I=1 + IF (N.GT.1) THEN + I=0 + DO 42 I0 = 1,NC + IF ((N.GE.FSTA(I0)).AND.(N.LE.LSTA(I0))) THEN + I=I0 + GO TO 43 + ENDIF + 42 CONTINUE + 43 IF (I.EQ.0) CALL XABORT('NEIG10: ALGORITHM FAILURE.') + ENDIF +* + N1 = FSTA(I) + N2 = LSTA(I) + EVEN = MOD(I,2).EQ.0 + OUTER = I.EQ.NC +* + IF (K.EQ.1) THEN +* + IF (N.EQ.1) THEN + M = 2 + ELSE IF (OUTER.AND.(N.EQ.2)) THEN + M = -2 + ELSE IF (OUTER.AND.(N.EQ.N2)) THEN + M = -(N-1) + ELSE IF (OUTER.AND.EVEN) THEN + M = -(N-NBA(I-1)+1) + ELSE IF (OUTER.AND.(.NOT.EVEN)) THEN + M = -(N-NBA(I-1)) + ELSE IF (EVEN) THEN + M = N+NBA(I)+1 + ELSE IF (.NOT.EVEN) THEN + M = N+NBA(I) + ENDIF +* + ELSE IF (K.EQ.2) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF (OUTER.AND.(N.EQ.N2)) THEN + M = -LSTA(I-1) + ELSE IF (N.EQ.N2) THEN + M = -(LSTA(I+1)-1) + ELSE + M = N+1 + ENDIF +* + ELSE IF (K.EQ.3) THEN +* + IF ((N.EQ.1).OR.(N.EQ.2)) THEN + M = -2 + ELSE IF (N.EQ.N2) THEN + M = -(N-1) + ELSE IF (EVEN) THEN + M = N-NBA(I-1)+1 + ELSE IF (.NOT.EVEN) THEN + M = N-NBA(I-1) + ENDIF +* + ELSE IF (K.EQ.4) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + M = -FSTA(I-1) + ELSE IF (EVEN) THEN + M = N-NBA(I-1) + ELSE IF (.NOT.EVEN) THEN + M = N-NBA(I-1)-1 + ENDIF +* + ELSE IF (K.EQ.5) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF ((N.EQ.N1).AND.EVEN) THEN + M = N + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + M = -(N+1) + ELSE + M = N-1 + ENDIF +* + ELSE IF (K.EQ.6) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF (OUTER.AND.(N.EQ.N1)) THEN + M = -FSTA(I-1) + ELSE IF (OUTER.AND.EVEN) THEN + M = -(N-NBA(I-1)) + ELSE IF (OUTER.AND.(.NOT.EVEN)) THEN + M = -(N-NBA(I-1)-1) + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + M = -FSTA(I+1) + ELSE IF (EVEN) THEN + M = N+NBA(I) + ELSE IF (.NOT.EVEN) THEN + M = N+NBA(I)-1 + ENDIF +* + ENDIF +* + IF (N.EQ.1) THEN + POIDS = 1./12. + ELSE IF (OUTER.AND.(N.EQ.N2)) THEN + POIDS = 1./6. + ELSE IF (OUTER.AND.(N.EQ.N1).AND.(.NOT.EVEN)) THEN + POIDS = 0.25 + ELSE IF (OUTER.OR.(N.EQ.N2)) THEN + POIDS = 0.5 + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + POIDS = 0.5 + ELSE + POIDS = 1. + ENDIF + DEALLOCATE(NBA,FSTA,LSTA) + RETURN + END +* + SUBROUTINE NEIG11 (NC,N,K,M,POIDS) +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NC,N,K,M + REAL POIDS +*---- +* LOCAL VARIABLES +*---- + LOGICAL EVEN,OUTER + INTEGER, DIMENSION(:), ALLOCATABLE :: NBA,FSTA,LSTA +* + ALLOCATE(NBA(NC+2),FSTA(NC+2),LSTA(NC+2)) + EVEN=.TRUE. + NBA(:NC+2)=0 + FSTA(:NC+2)=0 + LSTA(:NC+2)=0 + NBA(1) = 1 + LSTA(1) = 1 + FSTA(1) = 1 + FSTA(2) = 2 + DO 45 L = 2,NC+1 + NBA(L) = L + LSTA(L) = L+LSTA(L-1) + FSTA(L+1) = L+FSTA(L) + 45 CONTINUE +* + I=0 + DO 46 I0 = 1,NC + IF ((N.GE.FSTA(I0)).AND.(N.LE.LSTA(I0))) THEN + I=I0 + GO TO 47 + ENDIF + 46 CONTINUE + IF (I.EQ.0) CALL XABORT('NEIG11: ALGORITHM FAILURE.') +* + 47 N1 = FSTA(I) + N2 = LSTA(I) + OUTER = I.EQ.NC +* + IF (K.EQ.1) THEN +* + IF (N.EQ.1) THEN + M = 3 + ELSE IF (OUTER.AND.(N.EQ.N2)) THEN + M = -(N-1) + ELSE IF (OUTER) THEN + M = -(N-NBA(I-1)) + ELSE + M = N+NBA(I)+1 + ENDIF +* + ELSE IF (K.EQ.2) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF (OUTER.AND.(N.EQ.N2)) THEN + M = -(N-NBA(I-1)-1) + ELSE IF (N.EQ.N2) THEN + M = -(N+NBA(I)) + ELSE + M = N+1 + ENDIF +* + ELSE IF (K.EQ.3) THEN +* + IF (N.EQ.1) THEN + M = -3 + ELSE IF (N.EQ.N2) THEN + M = -(N-1) + ELSE + M = N-NBA(I-1) + ENDIF +* + ELSE IF (K.EQ.4) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF (N.EQ.N1) THEN + M = -(N+1) + ELSE + M = N-NBA(I-1)-1 + ENDIF +* + ELSE IF (K.EQ.5) THEN +* + IF (N.EQ.1) THEN + M = -3 + ELSE IF (OUTER.AND.(N.EQ.N1)) THEN + M = -(N-NBA(I-1)) + ELSE IF (N.EQ.N1) THEN + M = -(N+NBA(I)+1) + ELSE + M = N-1 + ENDIF +* + ELSE IF (K.EQ.6) THEN +* + IF (N.EQ.1) THEN + M = 2 + ELSE IF (OUTER.AND.(N.EQ.N1)) THEN + M = -(N+1) + ELSE IF (OUTER) THEN + M = -(N-NBA(I-1)-1) + ELSE + M = N+NBA(I) + ENDIF +* + ENDIF +* + IF (N.EQ.1) THEN + POIDS = 1./6. + ELSE IF (OUTER.AND.((N.EQ.N1).OR.(N.EQ.N2))) THEN + POIDS = 1./6. + ELSE IF (OUTER.OR.(N.EQ.N1).OR.(N.EQ.N2)) THEN + POIDS = 0.5 + ELSE + POIDS = 1. + ENDIF + DEALLOCATE(NBA,FSTA,LSTA) + RETURN + END diff --git a/Trivac/src/NEIGHB.f b/Trivac/src/NEIGHB.f new file mode 100755 index 0000000..1d0de37 --- /dev/null +++ b/Trivac/src/NEIGHB.f @@ -0,0 +1,158 @@ +*DECK NEIGHB + FUNCTION NEIGHB (J,K,IHEX,NH,POIDS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the index of a neighbour hexagon taking into account the +* symmetries. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Benaboud +* +*Parameters: input +* J index of the considered hexagon. +* K index of the side. +* IHEX type of symmetry: +* =1: S30; =2: SA60; =3: SB60; =4: S90; =5: R120; +* =6: R180; =7: SA180; =8: SB180; =9: complete; +* =10: S30 with HBC SYME; =11: sa60 with HBC SYME. +* NH total number of hexagons. +* POIDS weight of the hexagon. +* +*Parameters: output +* NEIGHB index of the neighbour hexagon. Note that: +* ABS(NEIGHB).GT.NH: external boundary; +* NEIGHB=J: reflection on side k; +* NEIGHB.LT.0: axial symmetry or rotation. +* +*----------------------------------------------------------------------- +* +* side 2 +* xxxxxx +* side 3 x x side 1 +* x x +* x x +* x x +* side 4 x x side 6 +* xxxxxx +* side 5 +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER J,K,IHEX,NH + REAL POIDS +* + IF ((IHEX.EQ.1).OR.(IHEX.EQ.10)) THEN + VI = 2.* SQRT(REAL(NH)) - 1. + VP = SQRT(REAL(4*NH+1)) - 1. + IF (AINT(VI).EQ.VI) THEN + NC = INT(VI) + ELSE IF (AINT(VP).EQ.VP) THEN + NC = INT(VP) + ELSE + CALL XABORT('NEIGHB: INVALID NUMBER OF HEXAGONS(1).') + ENDIF + ELSE IF ((IHEX.EQ.2).OR.(IHEX.EQ.11)) THEN + VA = (SQRT(REAL(8*NH+1)) - 1.)/2. + IF (AINT(VA).EQ.VA) THEN + NC = INT(VA) + ELSE + CALL XABORT('NEIGHB: INVALID NUMBER OF HEXAGONS(2).') + ENDIF + ELSE IF (IHEX.EQ.3) THEN + VI = SQRT(REAL(2*NH-1)) + VP = SQRT(REAL(2*NH)) + IF (AINT(VI).EQ.VI) THEN + NC = INT(VI) + ELSE IF (AINT(VP).EQ.VP) THEN + NC = INT(VP) + ELSE + CALL XABORT('NEIGHB: INVALID NUMBER OF HEXAGONS(3).') + ENDIF + ELSE IF (IHEX.EQ.4) THEN + VI = SQRT(REAL((4*NH-1)/3)) + VP = SQRT(REAL(4*NH/3)) + IF (AINT(VI).EQ.VI) THEN + NC = INT(VI) + ELSE IF (AINT(VP).EQ.VP) THEN + NC = INT(VP) + ELSE + CALL XABORT('NEIGHB: INVALID NUMBER OF HEXAGONS(4).') + ENDIF + ELSE IF (IHEX.EQ.5) THEN + VA = (SQRT(REAL(4*(NH-1)+1)) + 1.)/2. + IF (AINT(VA).EQ.VA) THEN + NC = INT(VA) + ELSE + CALL XABORT('NEIGHB: INVALID NUMBER OF HEXAGONS(5).') + ENDIF + ELSE IF (IHEX.EQ.6) THEN + VA = (SQRT(REAL(8*(NH-1)/3+1)) + 1)/2 + IF (AINT(VA).EQ.VA) THEN + NC = INT(VA) + ELSE + CALL XABORT('NEIGHB: INVALID NUMBER OF HEXAGONS(6).') + ENDIF + ELSE IF (IHEX.EQ.7) THEN + VA = (SQRT(REAL(24*NH+1)) + 1.)/6. + IF (AINT(VA).EQ.VA) THEN + NC = INT(VA) + ELSE + CALL XABORT('NEIGHB: INVALID NUMBER OF HEXAGONS(7).') + ENDIF + ELSE IF (IHEX.EQ.8) THEN + VI = (1.+SQRT(REAL(3*(2*NH-1)+1)))/3. + VP = (1.+SQRT(REAL(6*NH+1)))/3. + IF (AINT(VI).EQ.VI) THEN + NC = INT(VI) + ELSE IF (AINT(VP).EQ.VP) THEN + NC = INT(VP) + ELSE + CALL XABORT('NEIGHB: INVALID NUMBER OF HEXAGONS(8).') + ENDIF + ELSE IF (IHEX.EQ.9) THEN + VA = (SQRT(REAL((4*NH-1)/3)) + 1.)/2. + IF (AINT(VA).EQ.VA) THEN + NC = INT(VA) + ELSE + CALL XABORT('NEIGHB: INVALID NUMBER OF HEXAGONS(9).') + ENDIF + ELSE + CALL XABORT('NEIGHB: INVALID TYPE OF SYMMETRY.') + ENDIF +* + IF (IHEX.EQ.1) THEN + CALL NEIGH1 (NC,J,K,N,POIDS) + ELSE IF (IHEX.EQ.2) THEN + CALL NEIGH2 (NC,J,K,N,POIDS) + ELSE IF (IHEX.EQ.3) THEN + CALL NEIGH3 (NC,J,K,N,POIDS) + ELSE IF (IHEX.EQ.4) THEN + CALL NEIGH4 (NC,J,K,N,POIDS) + ELSE IF (IHEX.EQ.5) THEN + CALL NEIGH5 (NC,J,K,N,POIDS) + IF (-N.GT.NH) N=-N + ELSE IF (IHEX.EQ.6) THEN + CALL NEIGH6 (NC,J,K,N,POIDS) + IF (-N.GT.NH) N=-N + ELSE IF (IHEX.EQ.7) THEN + CALL NEIGH7 (NC,J,K,N,POIDS) + ELSE IF (IHEX.EQ.8) THEN + CALL NEIGH8 (NC,J,K,N,POIDS) + ELSE IF (IHEX.EQ.9) THEN + CALL NEIGH9 (NC,J,K,N,POIDS) + ELSE IF (IHEX.EQ.10) THEN + CALL NEIG10 (NC,J,K,N,POIDS) + ELSE IF (IHEX.EQ.11) THEN + CALL NEIG11 (NC,J,K,N,POIDS) + ENDIF + NEIGHB=N + RETURN + END diff --git a/Trivac/src/NSS1TR.f b/Trivac/src/NSS1TR.f new file mode 100755 index 0000000..c44a752 --- /dev/null +++ b/Trivac/src/NSS1TR.f @@ -0,0 +1,198 @@ +*DECK NSS1TR + SUBROUTINE NSS1TR(ITRIAL,NEL,NMIX,MAT,XX,IQFR,QFR,DIFF,SIGR,FD, + 1 A11) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Assembly of leakage system matrices for the nodal expansion method. +* +*Copyright: +* Copyright (C) 2021 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* ITRIAL type of base (=1: polynomial; =2: hyperbolic). +* NEL number of nodes +* NMIX number of mixtures +* MAT node mixtures +* XX node widths +* IQFR boundary conditions +* QFR albedo functions +* DIFF diffusion coefficients +* SIGR macroscopic removal cross sections +* FD discontinuity factors +* +*Parameters: output +* A11 assembly matrix. +* +*----------------------------------------------------------------------- +* + INTEGER ITRIAL(NMIX),NEL,NMIX,MAT(NEL),IQFR(6,NEL) + REAL XX(NEL),QFR(6,NEL),DIFF(NMIX),SIGR(NMIX),FD(NMIX,2), + 1 A11(5*NEL,5*NEL) +* + A11(:5*NEL,:5*NEL)=0.0 + ! WEIGHT RESIDUAL EQUATIONS: + NUM1=0 + DO KEL=1,NEL + IBM=MAT(KEL) + DX2=XX(KEL)**2 + SIGG=SIGR(IBM) + DIDD=DIFF(IBM) + ETA=XX(KEL)*SQRT(SIGG/DIDD) + A11(NUM1+1,NUM1+1)=SIGG + A11(NUM1+1,NUM1+3)=-6.0*DIDD/DX2 + A11(NUM1+2,NUM1+2)=SIGG/12.0 + A11(NUM1+3,NUM1+3)=SIGG/20.0 + IF(ITRIAL(IBM) == 1) THEN + A11(NUM1+1,NUM1+5)=-2.0*DIDD/(5.0*DX2) + A11(NUM1+2,NUM1+4)=-SIGG/120.0-DIDD/(2.0*DX2) + A11(NUM1+3,NUM1+5)=-SIGG/700.0-DIDD/(5.0*DX2) + ELSE + ALP0=2.0*ETA*SINH(ETA/2.0) + A11(NUM1+1,NUM1+5)=-DIDD*ALP0/DX2 + ENDIF + NUM1=NUM1+5 + ENDDO + ! continuity relations: + NUM1=0 + DO KEL=1,NEL-1 + IBM=MAT(KEL) + IBMP=MAT(KEL+1) + DIDD=DIFF(IBM) + DIDDP=DIFF(IBMP) + ETA=XX(KEL)*SQRT(SIGR(IBM)/DIDD) + ETAP=XX(KEL+1)*SQRT(SIGR(IBMP)/DIDDP) + NUM2=NUM1+5 + ! flux continuity: + FDP=FD(IBM,2) + FDM=FD(IBMP,1) + A11(NUM1+4,NUM1+1)=FDP + A11(NUM1+4,NUM1+2)=FDP/2.0 + A11(NUM1+4,NUM1+3)=FDP/2.0 + A11(NUM1+4,NUM2+1)=-FDM + A11(NUM1+4,NUM2+2)=FDM/2.0 + A11(NUM1+4,NUM2+3)=-FDM/2.0 + IF(ITRIAL(IBM) == 2) THEN + ALP1=ETA*COSH(ETA/2.0)-2.0*SINH(ETA/2.0) + A11(NUM1+4,NUM1+4)=FDP*SINH(ETA/2.0) + A11(NUM1+4,NUM1+5)=FDP*ALP1/ETA + ENDIF + IF(ITRIAL(IBMP) == 2) THEN + ALP1P=ETAP*COSH(ETAP/2.0)-2.0*SINH(ETAP/2.0) + A11(NUM1+4,NUM2+4)=FDM*SINH(ETAP/2.0) + A11(NUM1+4,NUM2+5)=-FDM*ALP1P/ETAP + ENDIF + ! current contunuity: + A11(NUM1+5,NUM1+2)=DIDD/XX(KEL) + A11(NUM1+5,NUM1+3)=3.0*DIDD/XX(KEL) + A11(NUM1+5,NUM2+2)=-DIDDP/XX(KEL+1) + A11(NUM1+5,NUM2+3)=3.0*DIDDP/XX(KEL+1) + IF(ITRIAL(IBM) == 1) THEN + A11(NUM1+5,NUM1+4)=DIDD/(2.0*XX(KEL)) + A11(NUM1+5,NUM1+5)=DIDD/(5.0*XX(KEL)) + ELSE + A11(NUM1+5,NUM1+4)=(DIDD/XX(KEL))*ETA*COSH(ETA/2.0) + A11(NUM1+5,NUM1+5)=(DIDD/XX(KEL))*ETA*SINH(ETA/2.0) + ENDIF + IF(ITRIAL(IBMP) == 1) THEN + A11(NUM1+5,NUM2+4)=-DIDDP/(2.0*XX(KEL+1)) + A11(NUM1+5,NUM2+5)=DIDDP/(5.0*XX(KEL+1)) + ELSE + A11(NUM1+5,NUM2+4)=-(DIDDP/XX(KEL+1))*ETAP*COSH(ETAP/2.0) + A11(NUM1+5,NUM2+5)=(DIDDP/XX(KEL+1))*ETAP*SINH(ETAP/2.0) + ENDIF + NUM1=NUM1+5 + ENDDO + ! left boundary condition: + IBM=MAT(1) + ETA=XX(1)*SQRT(SIGR(MAT(1))/DIFF(IBM)) + IF((IQFR(1,1) == -1).OR.(IQFR(1,1) > 0)) THEN + ! VOID + AFACTOR=QFR(1,1) + A11(NUM1+4,1)=AFACTOR + A11(NUM1+4,2)=-(AFACTOR/2.0+DIFF(IBM)/XX(1)) + A11(NUM1+4,3)=(AFACTOR/2.0+3.0*DIFF(IBM)/XX(1)) + IF(ITRIAL(IBM) == 1) THEN + A11(NUM1+4,4)=-DIFF(IBM)/(2.0*XX(1)) + A11(NUM1+4,5)=DIFF(IBM)/(5.0*XX(1)) + ELSE + ALP1=ETA*COSH(ETA/2.0)-2.0*SINH(ETA/2.0) + A11(NUM1+4,4)=-(AFACTOR*SINH(ETA/2.0)+(DIFF(IBM)/XX(1))* + 1 ETA*COSH(ETA/2.0)) + A11(NUM1+4,5)=AFACTOR*ALP1/ETA+(DIFF(IBM)/XX(1))*ETA* + 1 SINH(ETA/2.0) + ENDIF + ELSE IF(IQFR(1,1) == -2) THEN + ! REFL + A11(NUM1+4,2)=1.0 + A11(NUM1+4,3)=-3.0 + IF(ITRIAL(IBM) == 1) THEN + A11(NUM1+4,4)=1.0/2.0 + A11(NUM1+4,5)=-1.0/5.0 + ELSE + A11(NUM1+4,4)=ETA*COSH(ETA/2.0) + A11(NUM1+4,5)=-ETA*SINH(ETA/2.0) + ENDIF + ELSE IF(IQFR(1,1) == -3) THEN + ! ZERO + A11(NUM1+4,1)=1.0 + A11(NUM1+4,2)=-1.0/2.0 + A11(NUM1+4,3)=1.0/2.0 + IF(ITRIAL(IBM) == 2) THEN + ALP1=ETA*COSH(ETA/2.0)-2.0*SINH(ETA/2.0) + A11(NUM1+4,4)=-SINH(ETA/2.0) + A11(NUM1+4,5)=ALP1/ETA + ENDIF + ENDIF + ! right boundary condition: + IBM=MAT(NEL) + ETA=XX(NEL)*SQRT(SIGR(IBM)/DIFF(IBM)) + IF((IQFR(2,NEL) == -1).OR.(IQFR(2,NEL) > 0)) THEN + NUM2=5*(NEL-1) + ! VOID + AFACTOR=QFR(2,NEL) + A11(NUM1+5,NUM2+1)=AFACTOR + A11(NUM1+5,NUM2+2)=(AFACTOR/2.0+DIFF(IBM)/XX(NEL)) + A11(NUM1+5,NUM2+3)=(AFACTOR/2.0+3.0*DIFF(IBM)/XX(NEL)) + IF(ITRIAL(IBM) == 1) THEN + A11(NUM1+5,NUM2+4)=DIFF(IBM)/(2.0*XX(NEL)) + A11(NUM1+5,NUM2+5)=DIFF(IBM)/(5.0*XX(NEL)) + ELSE + ALP1=ETA*COSH(ETA/2.0)-2.0*SINH(ETA/2.0) + A11(NUM1+5,NUM2+4)=AFACTOR*SINH(ETA/2.0)+(DIFF(IBM)/ + 1 XX(NEL))*ETA*COSH(ETA/2.0) + A11(NUM1+5,NUM2+5)=AFACTOR*ALP1/ETA+(DIFF(IBM)/ + 1 XX(NEL))*ETA*SINH(ETA/2.0) + ENDIF + ELSE IF(IQFR(2,NEL) == -2) THEN + NUM2=5*(NEL-1) + ! REFL + A11(NUM1+5,NUM2+2)=1.0 + A11(NUM1+5,NUM2+3)=3.0 + IF(ITRIAL(IBM) == 1) THEN + A11(NUM1+5,NUM2+4)=1.0/2.0 + A11(NUM1+5,NUM2+5)=1.0/5.0 + ELSE + A11(NUM1+5,NUM2+4)=ETA*COSH(ETA/2.0) + A11(NUM1+5,NUM2+5)=ETA*SINH(ETA/2.0) + ENDIF + ELSE IF(IQFR(2,NEL) == -3) THEN + NUM2=5*(NEL-1) + ! ZERO + A11(NUM1+5,NUM2+1)=1.0 + A11(NUM1+5,NUM2+2)=1.0/2.0 + A11(NUM1+5,NUM2+3)=1.0/2.0 + IF(ITRIAL(IBM) == 2) THEN + ALP1=ETA*COSH(ETA/2.0)-2.0*SINH(ETA/2.0) + A11(NUM1+5,NUM2+4)=SINH(ETA/2.0) + A11(NUM1+5,NUM2+5)=ALP1/ETA + ENDIF + ENDIF + END SUBROUTINE NSS1TR diff --git a/Trivac/src/NSS2AC.f b/Trivac/src/NSS2AC.f new file mode 100755 index 0000000..bc8665e --- /dev/null +++ b/Trivac/src/NSS2AC.f @@ -0,0 +1,79 @@ +*DECK NSS2AC + SUBROUTINE NSS2AC(NG,NUN,IG0,FLUX,ZMU) +* +*----------------------------------------------------------------------- +* +*Purpose: +* One-factor variationnal acceleration of the flux. Double precision +* version. +* +*Copyright: +* Copyright (C) 2023 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* NG number of energy groups. +* NUN number of unknowns per energy group. +* IG0 first group to accelerate. +* +*Parameters: input/output +* FLUX neutron flux: +* FLUX(:,:,1) <=old; +* FLUX(:,:,2) <=present; +* FLUX(:,:,3) <=new. +* +*Parameters: output +* ZMU acceleration factor. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER :: NG, NUN, IG0 + REAL(KIND=8) :: FLUX(NUN,NG,3), ZMU +*---- +* LOCAL VARIABLES +*---- + INTEGER IG, IR + REAL(KIND=8) DMU, R1, R2 + REAL(KIND=8) DONE, DZERO, NOM, DENOM + PARAMETER ( DONE=1.0D0, DZERO=0.0D0 ) +*---- +* ZMU CALCULATION +*---- + NOM = DZERO + DENOM = DZERO + DO 3 IG= IG0,NG + DO 2 IR=1,NUN + R1 = FLUX(IR,IG,2) - FLUX(IR,IG,1) + R2 = FLUX(IR,IG,3) - FLUX(IR,IG,2) + NOM = NOM + R1*(R2-R1) + DENOM = DENOM + (R2-R1)*(R2-R1) + 2 CONTINUE + 3 CONTINUE +* + DMU = - NOM / DENOM + ZMU = DMU + IF( DMU.GT.DZERO )THEN + DO 13 IG= IG0,NG + DO 12 IR=1,NUN +* +* ACCELERATED VALUES FOR PHI(2) ET PHI(3) + FLUX(IR,IG,3) = FLUX(IR,IG,2) + DMU * + > (FLUX(IR,IG,3) - FLUX(IR,IG,2)) + FLUX(IR,IG,2) = FLUX(IR,IG,1) + DMU * + > (FLUX(IR,IG,2) - FLUX(IR,IG,1)) + 12 CONTINUE + 13 CONTINUE + ELSE + ZMU= DONE + ENDIF + RETURN + END diff --git a/Trivac/src/NSS2TR.f b/Trivac/src/NSS2TR.f new file mode 100755 index 0000000..76f664d --- /dev/null +++ b/Trivac/src/NSS2TR.f @@ -0,0 +1,125 @@ +*DECK NSS2TR + SUBROUTINE NSS2TR(ITRIAL,NEL,NMIX,MAT,XX,IQFR,QFR,DIFF,SIGR,SIGT, + 1 FD,A11) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Assembly of non-leakage system matrices for the nodal expansion method. +* +*Copyright: +* Copyright (C) 2021 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* ITRIAL type of base (=1: polynomial; =2: hyperbolic). +* NEL number of nodes +* NMIX number of mixtures +* MAT node mixtures +* XX node widths +* IQFR boundary conditions +* QFR albedo functions +* DIFF diffusion coefficients. +* SIGR macroscopic removal cross section. +* SIGT macroscopic cross section. +* FD discontinuity factors +* +*Parameters: output +* A11 assembly matrix. +* +*----------------------------------------------------------------------- +* + INTEGER ITRIAL(NMIX),NEL,NMIX,MAT(NEL),IQFR(6,NEL) + REAL XX(NEL),QFR(6,NEL),DIFF(NMIX),SIGR(NMIX),SIGT(NMIX), + 1 FD(NMIX,2),A11(5*NEL,5*NEL) +* + A11(:5*NEL,:5*NEL)=0.0 + NUM1=0 + DO KEL=1,NEL + IBM=MAT(KEL) + SIGG=SIGT(IBM) + ETA=XX(KEL)*SQRT(SIGR(IBM)/DIFF(IBM)) + ! WEIGHT RESIDUAL EQUATIONS: + A11(NUM1+1,NUM1+1)=SIGG + A11(NUM1+2,NUM1+2)=SIGG/12.0 + A11(NUM1+3,NUM1+3)=SIGG/20.0 + IF(ITRIAL(IBM) == 1) THEN + A11(NUM1+2,NUM1+4)=-SIGG/120.0 + A11(NUM1+3,NUM1+5)=-SIGG/700.0 + ELSE + ALP1=ETA*COSH(ETA/2.0)-2.0*SINH(ETA/2.0) + ALP2=((12.0+ETA**2)*SINH(ETA/2.0)-6.0*ETA*COSH(ETA/2.0))/ETA + A11(NUM1+2,NUM1+4)=SIGG*ALP1/(ETA**2) + A11(NUM1+3,NUM1+5)=SIGG*ALP2/(ETA**2) + ENDIF + NUM1=NUM1+5 + ENDDO + ! continuity relations: + NUM1=0 + DO KEL=1,NEL-1 + IBM=MAT(KEL) + IBMP=MAT(KEL+1) + DIDD=DIFF(IBM) + DIDDP=DIFF(IBMP) + ETA=XX(KEL)*SQRT(SIGR(IBM)/DIDD) + ETAP=XX(KEL+1)*SQRT(SIGR(IBMP)/DIDDP) + NUM2=NUM1+5 + ! flux continuity: + FDP=FD(IBM,2) + FDM=FD(IBMP,1) + A11(NUM1+4,NUM1+1)=-FDP + A11(NUM1+4,NUM1+2)=-FDP/2.0 + A11(NUM1+4,NUM1+3)=-FDP/2.0 + A11(NUM1+4,NUM2+1)=FDM + A11(NUM1+4,NUM2+2)=-FDM/2.0 + A11(NUM1+4,NUM2+3)=FDM/2.0 + IF(ITRIAL(IBM) == 2) THEN + ALP1=ETA*COSH(ETA/2.0)-2.0*SINH(ETA/2.0) + A11(NUM1+4,NUM1+4)=-FDP*SINH(ETA/2.0) + A11(NUM1+4,NUM1+5)=-FDP*ALP1/ETA + ENDIF + IF(ITRIAL(IBMP) == 2) THEN + ALP1P=ETAP*COSH(ETAP/2.0)-2.0*SINH(ETAP/2.0) + A11(NUM1+4,NUM2+4)=-FDM*SINH(ETAP/2.0) + A11(NUM1+4,NUM2+5)=FDM*ALP1P/ETAP + ENDIF + NUM1=NUM1+5 + ENDDO + ! left boundary condition: + IBM=MAT(1) + ETA=XX(1)*SQRT(SIGR(IBM)/DIFF(IBM)) + IF((IQFR(1,1) == -1).OR.(IQFR(1,1) > 0)) THEN + ! VOID + AFACTOR=QFR(1,1) + A11(NUM1+4,1)=-AFACTOR + A11(NUM1+4,2)=AFACTOR/2.0 + A11(NUM1+4,3)=-AFACTOR/2.0 + IF(ITRIAL(IBM) == 2) THEN + ALP1=ETA*COSH(ETA/2.0)-2.0*SINH(ETA/2.0) + A11(NUM1+4,4)=AFACTOR*SINH(ETA/2.0) + A11(NUM1+4,5)=-AFACTOR*ALP1/ETA + ENDIF + ENDIF + ! right boundary condition: + IBM=MAT(NEL) + ETA=XX(NEL)*SQRT(SIGR(IBM)/DIFF(IBM)) + IF((IQFR(2,NEL) == -1).OR.(IQFR(2,NEL) > 0)) THEN + NUM2=5*(NEL-1) + ! VOID + AFACTOR=QFR(2,NEL) + A11(NUM1+5,NUM2+1)=-AFACTOR + A11(NUM1+5,NUM2+2)=-AFACTOR/2.0 + A11(NUM1+5,NUM2+3)=-AFACTOR/2.0 + IF(ITRIAL(IBM) == 2) THEN + ALP1=ETA*COSH(ETA/2.0)-2.0*SINH(ETA/2.0) + A11(NUM1+5,NUM2+4)=-AFACTOR*SINH(ETA/2.0) + A11(NUM1+5,NUM2+5)=-AFACTOR*ALP1/ETA + ENDIF + ENDIF + RETURN + END SUBROUTINE NSS2TR diff --git a/Trivac/src/NSS3TR.f b/Trivac/src/NSS3TR.f new file mode 100755 index 0000000..237f27d --- /dev/null +++ b/Trivac/src/NSS3TR.f @@ -0,0 +1,58 @@ +*DECK NSS3TR + SUBROUTINE NSS3TR(ITRIAL,NEL,NMIX,MAT,XX,DIFF,SIGR,SIGT,B11) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Assembly of fission system matrices for the nodal expansion method. +* +*Copyright: +* Copyright (C) 2021 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* ITRIAL type of base (=1: polynomial; =2: hyperbolic) +* NEL number of nodes +* NMIX number of mixtures +* MAT node mixtures +* XX node widths +* DIFF diffusion coefficients. +* SIGR macroscopic removal cross section. +* SIGT fission cross section. +* +*Parameters: output +* B11 assembly matrix. +* +*----------------------------------------------------------------------- +* + INTEGER ITRIAL(NMIX),NEL,NMIX,MAT(NEL) + REAL XX(NEL),DIFF(NMIX),SIGR(NMIX),SIGT(NMIX),B11(5*NEL,5*NEL) +* + B11(:5*NEL,:5*NEL)=0.0 + NUM1=0 + DO KEL=1,NEL + IBM=MAT(KEL) + SIGG=SIGT(IBM) + ETA=XX(KEL)*SQRT(SIGR(IBM)/DIFF(IBM)) + ! WEIGHT RESIDUAL EQUATIONS: + B11(NUM1+1,NUM1+1)=SIGG + B11(NUM1+2,NUM1+2)=SIGG/12.0 + B11(NUM1+3,NUM1+3)=SIGG/20.0 + IF(ITRIAL(IBM) == 1) THEN + B11(NUM1+2,NUM1+4)=-SIGG/120.0 + B11(NUM1+3,NUM1+5)=-SIGG/700.0 + ELSE + ALP1=ETA*COSH(ETA/2.0)-2.0*SINH(ETA/2.0) + ALP2=((12.0+ETA**2)*SINH(ETA/2.0)-6.0*ETA*COSH(ETA/2.0))/ETA + B11(NUM1+2,NUM1+4)=SIGG*ALP1/(ETA**2) + B11(NUM1+3,NUM1+5)=SIGG*ALP2/(ETA**2) + ENDIF + NUM1=NUM1+5 + ENDDO + RETURN + END SUBROUTINE NSS3TR diff --git a/Trivac/src/NSS4TR.f b/Trivac/src/NSS4TR.f new file mode 100755 index 0000000..712a539 --- /dev/null +++ b/Trivac/src/NSS4TR.f @@ -0,0 +1,116 @@ +*DECK NSS4TR + SUBROUTINE NSS4TR(NEL,NMIX,MAT,XX,IQFR,QFR,DIFF,SIGR,FD,A11) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Assembly of leakage system matrices for the coarse mesh finite +* difference method. +* +*Copyright: +* Copyright (C) 2021 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NEL number of nodes +* NMIX number of mixtures +* MAT node mixtures +* XX node widths +* IQFR boundary conditions +* QFR albedo functions +* DIFF diffusion coefficients +* SIGR macroscopic removal cross sections +* FD discontinuity factors +* +*Parameters: output +* A11 assembly matrix. +* +*----------------------------------------------------------------------- +* + INTEGER NEL,NMIX,MAT(NEL),IQFR(6,NEL) + REAL XX(NEL),QFR(6,NEL),DIFF(NMIX),SIGR(NMIX),FD(NMIX,2), + 1 A11(3*NEL,3*NEL) +* + A11(:3*NEL,:3*NEL)=0.0 + ! WEIGHT RESIDUAL EQUATIONS: + NUM1=0 + DO KEL=1,NEL + IBM=MAT(KEL) + DX2=XX(KEL)**2 + SIGG=SIGR(IBM) + DIDD=DIFF(IBM) + A11(NUM1+1,NUM1+1)=SIGG + A11(NUM1+1,NUM1+3)=-2.0*DIDD/DX2 + A11(NUM1+2,NUM1+2)=SIGG/12.0 + A11(NUM1+3,NUM1+3)=SIGG/180.0 + NUM1=NUM1+3 + ENDDO + ! continuity relations: + NUM1=0 + DO KEL=1,NEL-1 + IBM=MAT(KEL) + IBMP=MAT(KEL+1) + DIDD=DIFF(IBM) + DIDDP=DIFF(IBMP) + NUM2=NUM1+3 + ! flux continuity: + FDP=FD(IBM,2) + FDM=FD(IBMP,1) + A11(NUM1+2,NUM1+1)=FDP + A11(NUM1+2,NUM1+2)=FDP/2.0 + A11(NUM1+2,NUM1+3)=FDP/6.0 + A11(NUM1+2,NUM2+1)=-FDM + A11(NUM1+2,NUM2+2)=FDM/2.0 + A11(NUM1+2,NUM2+3)=-FDM/6.0 + ! current contunuity: + A11(NUM1+3,NUM1+2)=DIDD/XX(KEL) + A11(NUM1+3,NUM1+3)=DIDD/XX(KEL) + A11(NUM1+3,NUM2+2)=-DIDDP/XX(KEL+1) + A11(NUM1+3,NUM2+3)=DIDDP/XX(KEL+1) + NUM1=NUM1+3 + ENDDO + ! left boundary condition: + IBM=MAT(1) + IF((IQFR(1,1) == -1).OR.(IQFR(1,1) > 0)) THEN + ! VOID + AFACTOR=QFR(1,1) + A11(NUM1+2,1)=AFACTOR + A11(NUM1+2,2)=-(AFACTOR/2.0+DIFF(IBM)/XX(1)) + A11(NUM1+2,3)=(AFACTOR/6.0+DIFF(IBM)/XX(1)) + ELSE IF(IQFR(1,1) == -2) THEN + ! REFL + A11(NUM1+2,2)=1.0 + A11(NUM1+2,3)=-1.0 + ELSE IF(IQFR(1,1) == -3) THEN + ! ZERO + A11(NUM1+2,1)=1.0 + A11(NUM1+2,2)=-1.0/2.0 + A11(NUM1+2,3)=1.0/6.0 + ENDIF + ! right boundary condition: + IBM=MAT(NEL) + IF((IQFR(2,NEL) == -1).OR.(IQFR(2,NEL) > 0)) THEN + NUM2=3*(NEL-1) + ! VOID + AFACTOR=QFR(2,NEL) + A11(NUM1+3,NUM2+1)=AFACTOR + A11(NUM1+3,NUM2+2)=(AFACTOR/2.0+DIFF(IBM)/XX(NEL)) + A11(NUM1+3,NUM2+3)=(AFACTOR/6.0+DIFF(IBM)/XX(NEL)) + ELSE IF(IQFR(2,NEL) == -2) THEN + NUM2=3*(NEL-1) + ! REFL + A11(NUM1+3,NUM2+2)=1.0 + A11(NUM1+3,NUM2+3)=1.0 + ELSE IF(IQFR(2,NEL) == -3) THEN + NUM2=3*(NEL-1) + ! ZERO + A11(NUM1+3,NUM2+1)=1.0 + A11(NUM1+3,NUM2+2)=1.0/2.0 + A11(NUM1+3,NUM2+3)=1.0/6.0 + ENDIF + END SUBROUTINE NSS4TR diff --git a/Trivac/src/NSS5TR.f b/Trivac/src/NSS5TR.f new file mode 100755 index 0000000..c38c3ef --- /dev/null +++ b/Trivac/src/NSS5TR.f @@ -0,0 +1,82 @@ +*DECK NSS5TR + SUBROUTINE NSS5TR(NEL,NMIX,MAT,IQFR,QFR,SIGT,FD,A11) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Assembly of non-leakage system matrices for the coarse mesh finite +* difference method. +* +*Copyright: +* Copyright (C) 2021 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NEL number of nodes +* NMIX number of mixtures +* MAT node mixtures +* IQFR boundary conditions +* QFR albedo functions +* SIGT macroscopic cross section. +* FD discontinuity factors +* +*Parameters: output +* A11 assembly matrix. +* +*----------------------------------------------------------------------- +* + INTEGER NEL,NMIX,MAT(NEL),IQFR(6,NEL) + REAL QFR(6,NEL),SIGT(NMIX),FD(NMIX,2),A11(3*NEL,3*NEL) +* + A11(:3*NEL,:3*NEL)=0.0 + NUM1=0 + DO KEL=1,NEL + IBM=MAT(KEL) + SIGG=SIGT(IBM) + ! WEIGHT RESIDUAL EQUATIONS: + A11(NUM1+1,NUM1+1)=SIGG + A11(NUM1+2,NUM1+2)=SIGG/12.0 + A11(NUM1+3,NUM1+3)=SIGG/180.0 + NUM1=NUM1+3 + ENDDO + ! continuity relations: + NUM1=0 + DO KEL=1,NEL-1 + IBM=MAT(KEL) + IBMP=MAT(KEL+1) + NUM2=NUM1+3 + ! flux continuity: + FDP=FD(IBM,2) + FDM=FD(IBMP,1) + A11(NUM1+2,NUM1+1)=-FDP + A11(NUM1+2,NUM1+2)=-FDP/2.0 + A11(NUM1+2,NUM1+3)=-FDP/6.0 + A11(NUM1+2,NUM2+1)=FDM + A11(NUM1+2,NUM2+2)=-FDM/2.0 + A11(NUM1+2,NUM2+3)=FDM/6.0 + NUM1=NUM1+3 + ENDDO + ! left boundary condition: + IF((IQFR(1,1) == -1).OR.(IQFR(1,1) > 0)) THEN + ! VOID + AFACTOR=QFR(1,1) + A11(NUM1+2,1)=-AFACTOR + A11(NUM1+2,2)=AFACTOR/2.0 + A11(NUM1+2,3)=-AFACTOR/6.0 + ENDIF + ! right boundary condition: + IF((IQFR(2,NEL) == -1).OR.(IQFR(2,NEL) > 0)) THEN + NUM2=3*(NEL-1) + ! VOID + AFACTOR=QFR(2,NEL) + A11(NUM1+3,NUM2+1)=-AFACTOR + A11(NUM1+3,NUM2+2)=-AFACTOR/2.0 + A11(NUM1+3,NUM2+3)=-AFACTOR/6.0 + ENDIF + RETURN + END SUBROUTINE NSS5TR diff --git a/Trivac/src/NSSANM1.f90 b/Trivac/src/NSSANM1.f90 new file mode 100755 index 0000000..f16c91a --- /dev/null +++ b/Trivac/src/NSSANM1.f90 @@ -0,0 +1,158 @@ +subroutine NSSANM1(nel,ng,nmix,iqfr,qfr,mat,xxx,keff,diff,sigr,chi,sigf,scat,fd,savg) +! +!----------------------------------------------------------------------- +! +!Purpose: +! Compute the ANM volume fluxes and boundary fluxes and currents using +! a solution of one- and two-node relations in Cartesian 1D geometry. +! +!Copyright: +! Copyright (C) 2022 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version +! +!Author(s): A. Hebert +! +!Parameters: input +! nel number of nodes in the nodal calculation. +! ng number of energy groups. +! nmix number of material mixtures in the nodal calculation. +! iqfr node-ordered physical albedo indices. +! qfr albedo function information. +! mat material mixture index in eacn node. +! xxx Cartesian coordinates along the X axis. +! keff effective multiplication facctor. +! diff diffusion coefficients +! sigr removal cross sections. +! chi fission spectra. +! sigf nu times fission cross section. +! scat scattering cross section. +! fd discontinuity factors +! savg nodal fluxes. +! +!Parameters: output +! savg boundary fluxes and currents. +! +!----------------------------------------------------------------------- + ! + !---- + ! subroutine arguments + !---- + integer,intent(in) :: nel,ng,nmix,iqfr(6,nel),mat(nel) + real,intent(in) :: qfr(6,nel,ng),xxx(nel+1),keff,diff(nmix,ng),sigr(nmix,ng), & + & chi(nmix,ng),sigf(nmix,ng),scat(nmix,ng,ng),fd(nmix,2,ng,ng) + real, dimension(4*nel+1,ng),intent(inout) :: savg + !---- + ! allocatable arrays + !---- + real, allocatable, dimension(:) :: work1,work2,work4,work5 + real, allocatable, dimension(:,:) :: A,B,Lambda,work3 + real(kind=8), allocatable, dimension(:,:,:) :: Lx,Rx + !---- + ! scratch storage allocation + !---- + allocate(A(ng,ng+1),B(ng,ng),Lambda(ng,ng)) + allocate(work1(ng),work2(ng),work3(ng,ng),work4(ng),work5(ng)) + allocate(Lx(ng,2*ng,nel),Rx(ng,2*ng,nel)) + ! + ! compute nodal coefficients + do iel=1,nel + ibm=mat(iel) + if(ibm == 0) cycle + work1(:ng)=diff(ibm,:ng) + work2(:ng)=sigr(ibm,:ng) + work3(:ng,:ng)=scat(ibm,:ng,:ng) + work4(:ng)=chi(ibm,:ng) + work5(:ng)=sigf(ibm,:ng) + delx=xxx(iel+1)-xxx(iel) + call NSSLR1(keff,ng,delx,work1,work2,work3,work4,work5, & + & Lx(1,1,iel),Rx(1,1,iel)) + enddo + !---- + ! compute boundary currents + ! left one-node relation + !---- + A(:ng,:ng+1)=0.0 + if((iqfr(1,1) > 0).or.(iqfr(1,1) == -1)) then + ! physical albedo + Lambda(:ng,:ng)=0.0 + do ig=1,ng + Lambda(ig,ig)=qfr(1,1,ig) + enddo + A(:ng,:ng)=real(matmul(Lambda(:ng,:ng),Lx(:ng,ng+1:2*ng,1)),4) + B(:ng,:ng)=real(matmul(Lambda(:ng,:ng),Lx(:ng,:ng,1)),4) + do ig=1,ng + A(ig,ig)=1.0+A(ig,ig) + enddo + A(:ng,ng+1)=-matmul(B(:ng,:ng),savg(1,:ng)) + else if(iqfr(1,1) == -2) then + ! zero net current + do ig=1,ng + A(ig,ig)=1.0 + enddo + else if(iqfr(1,1) == -3) then + ! zero flux + A(:ng,:ng)=real(Lx(:ng,ng+1:2*ng,1),4) + A(:ng,ng+1)=real(-matmul(Lx(:ng,:ng,1),savg(1,:ng)),4) + else + call XABORT('NSSANM1: illegal left boundary condition.') + endif + call ALSB(ng,1,A,ier,ng) + if(ier /= 0) call XABORT('NSSANM1: singular matrix.(1)') + savg(3*nel+1,:ng)=A(:ng,ng+1) + ! two-node relations + do i=2,nel + A(:ng,:ng)=real(matmul(fd(mat(i-1),2,:ng,:ng),Rx(:ng,ng+1:2*ng,i-1))- & + & matmul(fd(mat(i),1,:ng,:ng),Lx(:ng,ng+1:2*ng,i)),4) + A(:ng,ng+1)=-real(matmul(matmul(fd(mat(i-1),2,:ng,:ng),Rx(:ng,:ng,i-1)),savg(i-1,:ng))- & + & matmul(matmul(fd(mat(i),1,:ng,:ng),Lx(:ng,:ng,i)),savg(i,:ng)),4) + call ALSB(ng,1,A,ier,ng) + if(ier /= 0) call XABORT('NSSANM1: singular matrix.(2)') + savg(3*nel+i,:ng)=A(:ng,ng+1) + enddo + ! right one-node relation + if((iqfr(2,nel) > 0).or.(iqfr(2,nel) == -1)) then + ! physical albedo + Lambda(:ng,:ng)=0.0 + do ig=1,ng + Lambda(ig,ig)=qfr(2,nel,ig) + enddo + A(:ng,:ng)=real(matmul(Lambda(:ng,:ng),Rx(:ng,ng+1:2*ng,nel)),4) + B(:ng,:ng)=real(matmul(Lambda(:ng,:ng),Rx(:ng,:ng,nel)),4) + do ig=1,ng + A(ig,ig)=-1.0+A(ig,ig) + enddo + A(:ng,ng+1)=-matmul(B(:ng,:ng),savg(nel,:ng)) + else if(iqfr(2,nel) == -2) then + ! zero net current + do ig=1,ng + A(2*nel*ng+ig,2*nel*ng+ig)=1.0 + enddo + else if(iqfr(2,nel) == -3) then + ! zero flux + A(:ng,:ng)=real(Rx(:ng,ng+1:2*ng,nel),4) + A(:ng,ng+1)=real(-matmul(Rx(:ng,:ng,nel),savg(nel,:ng)),4) + else + call XABORT('NSSANM1: illegal right boundary condition.') + endif + call ALSB(ng,1,A,ier,ng) + if(ier /= 0) call XABORT('NSSANM1: singular matrix.(3)') + savg(4*nel+1,:ng)=A(:ng,ng+1) + !---- + ! compute boundary fluxes + !---- + do i=1,nel + savg(nel+i,:ng)=real(matmul(Lx(:ng,:ng,i),savg(i,:ng))+ & + & matmul(Lx(:ng,ng+1:2*ng,i),savg(3*nel+i,:ng)),4) + savg(2*nel+i,:ng)=real(matmul(Rx(:ng,:ng,i),savg(i,:ng))+ & + & matmul(Rx(:ng,ng+1:2*ng,i),savg(3*nel+i+1,:ng)),4) + enddo + !---- + ! scratch storage deallocation + !---- + deallocate(Rx,Lx) + deallocate(work5,work4,work3,work2,work1) + deallocate(Lambda,B,A) +end subroutine NSSANM1 diff --git a/Trivac/src/NSSANM2.f90 b/Trivac/src/NSSANM2.f90 new file mode 100755 index 0000000..da08e30 --- /dev/null +++ b/Trivac/src/NSSANM2.f90 @@ -0,0 +1,603 @@ +subroutine NSSANM2(nunkn,nx,ny,ll4f,ll4x,ng,bndtl,npass,nmix,idl,kn,iqfr, & +& qfr,mat,xxx,yyy,keff,diff,sigr,chi,sigf,scat,fd,savg) +! +!----------------------------------------------------------------------- +! +!Purpose: +! Compute the ANM boundary fluxes and currents using a solution of +! one- and two-node relations in Cartesian 2D geometry. +! +!Copyright: +! Copyright (C) 2022 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version +! +!Author(s): A. Hebert +! +!Parameters: input +! nunkn number of unknowns per energy group. +! nx number of x-nodes in the nodal calculation. +! ny number of y-nodes in the nodal calculation. +! ll4f number of averaged flux unknowns. +! ll4x number of X-directed net currents. +! ng number of energy groups. +! bndtl set to 'flat' or 'quadratic'. +! npass number of transverse current iterations. +! nmix number of material mixtures in the nodal calculation. +! idl position of averaged fluxes in unknown vector. +! kn element-ordered interface net current unknown list. +! iqfr node-ordered physical albedo indices. +! qfr albedo function information. +! mat material mixture index in eacn node. +! xxx Cartesian coordinates along the X axis. +! yyy Cartesian coordinates along the Y axis. +! keff effective multiplication facctor. +! diff diffusion coefficients +! sigr removal cross sections. +! chi fission spectra. +! sigf nu times fission cross section. +! scat scattering cross section. +! fd discontinuity factors. +! savg nodal fluxes and net currents. +! +!Parameters: output +! savg nodal fluxes, boundary fluxes and net currents. +! +!----------------------------------------------------------------------- + ! + !---- + ! subroutine arguments + !---- + integer,intent(in) :: nunkn,nx,ny,ll4f,ll4x,ng,npass,nmix,idl(nx,ny),kn(6,nx,ny), & + & iqfr(6,nx,ny),mat(nx,ny) + real,intent(in) :: qfr(6,nx,ny,ng),xxx(nx+1),yyy(ny+1),keff,diff(nmix,ng), & + & sigr(nmix,ng),chi(nmix,ng),sigf(nmix,ng),scat(nmix,ng,ng),fd(nmix,4,ng,ng) + real, dimension(nunkn,ng),intent(inout) :: savg + character(len=12), intent(in) :: bndtl + !---- + ! local and allocatable arrays + !---- + real :: xyz(4) + real, allocatable, dimension(:) :: work1,work2,work4,work5 + real, allocatable, dimension(:,:) :: A,Lambda,work3 + real(kind=8), allocatable, dimension(:,:) :: LLR + real(kind=8), allocatable, dimension(:,:,:,:) :: Lx,Rx,Ly,Ry + !---- + ! scratch storage allocation + !---- + allocate(A(ng,ng+1),Lambda(ng,ng),LLR(ng,8*ng)) + allocate(work1(ng),work2(ng),work3(ng,ng),work4(ng),work5(ng)) + allocate(Lx(ng,8*ng,nx,ny),Rx(ng,8*ng,nx,ny)) + allocate(Ly(ng,8*ng,nx,ny),Ry(ng,8*ng,nx,ny)) + !---- + ! compute 2D ANM coupling matrices for each single node + !---- + do j=1,ny + dely=yyy(j+1)-yyy(j) + do i=1,nx + delx=xxx(i+1)-xxx(i) + ibm=mat(i,j) + if(ibm == 0) cycle + work1(:ng)=diff(ibm,:ng) + work2(:ng)=sigr(ibm,:ng) + work3(:ng,:ng)=scat(ibm,:ng,:ng) + work4(:ng)=chi(ibm,:ng) + work5(:ng)=sigf(ibm,:ng) + ! + kk1=iqfr(1,i,j) + kk2=iqfr(2,i,j) + xyz(2:3)=xxx(i:i+1)-xxx(i) + if(kk1 == -2) then + ! reflection boundary condition + xyz(1)=2.0*xyz(2)-xyz(3) + else if(kk1 < 0) then + ! zero/void/albedo boundary condition + xyz(1)=-99999. + else + ! left neighbour + xyz(1)=xxx(i-1)-xxx(i) + endif + if(kk2 == -2) then + ! reflection boundary condition + xyz(4)=2.0*xyz(3)-xyz(2) + else if(kk2 < 0) then + ! zero/void/albedo boundary condition + xyz(4)=-99999. + else + ! right neighbour + xyz(4)=xxx(i+2)-xxx(i) + endif + call NSSLR2(keff,ng,bndtl,xyz,dely,work1,work2,work3,work4,work5,Lx(1,1,i,j),Rx(1,1,i,j)) + ! + kk3=iqfr(3,i,j) + kk4=iqfr(4,i,j) + xyz(2:3)=yyy(j:j+1)-yyy(j) + if(kk3 == -2) then + ! reflection boundary condition + xyz(1)=2.0*xyz(2)-xyz(3) + else if(kk3 < 0) then + ! zero/void/albedo boundary condition + xyz(1)=-99999. + else + ! left neighbour + xyz(1)=yyy(j-1)-yyy(j) + endif + if(kk4 == -2) then + ! reflection boundary condition + xyz(4)=2.0*xyz(3)-xyz(2) + else if(kk4 < 0) then + ! zero/void/albedo boundary condition + xyz(4)=-99999.0 + else + ! right neighbour + xyz(4)=yyy(j+2)-yyy(j) + endif + call NSSLR2(keff,ng,bndtl,xyz,delx,work1,work2,work3,work4,work5, & + & Ly(1,1,i,j),Ry(1,1,i,j)) + enddo + enddo + !---- + ! perform transverse current iterations + !---- + do ipass=1,npass + !---- + ! one- and two-node relations along X axis + !---- + do j=1,ny + nxmin=1 + do i=1,nx + if(mat(i,j) > 0) exit + nxmin=i+1 + enddo + if(nxmin > nx) cycle + nxmax=nx + do i=nx,1,-1 + if(mat(i,j) > 0) exit + nxmax=i-1 + enddo + ! one-node relation at left + ind1=idl(nxmin,j) + if(ind1 == 0) call XABORT('NSSANM2: invalid idl index.(1)') + iqf1=iqfr(1,nxmin,j) + jxm=kn(1,nxmin,j) ; jxp=kn(2,nxmin,j) ; jym=kn(3,nxmin,j) ; jyp=kn(4,nxmin,j) + jym_p=0 ; jyp_p=0 + if(nxmin < nx) then + jym_p=kn(3,nxmin+1,j) ; jyp_p=kn(4,nxmin+1,j) + endif + A(:ng,:ng+1)=0.0 + LLR(:ng,:8*ng)=0.0 + if((iqf1 > 0).or.(iqf1 == -1)) then + ! physical albedo + Lambda(:ng,:ng)=0.0 + do ig=1,ng + Lambda(ig,ig)=qfr(1,nxmin,j,ig) + enddo + LLR(:ng,:8*ng)=matmul(Lambda(:ng,:ng),Lx(:ng,:8*ng,nxmin,j)) + A(:ng,:ng)=-real(LLR(:ng,ng+1:2*ng),4) + do ig=1,ng + A(ig,ig)=-1.0+A(ig,ig) + enddo + else if(iqf1 == -2) then + ! zero net current + do ig=1,ng + A(ig,ig)=1.0 + enddo + else if(iqf1 == -3) then + ! zero flux + LLR(:ng,:8*ng)=Lx(:ng,:8*ng,nxmin,j) + A(:ng,:ng)=real(-LLR(:ng,ng+1:2*ng),4) + else if(iqf1 == -4) then + call XABORT('NSSANM2: SYME boundary condition is not supported.(1)') + else + call XABORT('NSSANM2: illegal left X-boundary condition.') + endif + if(iqf1 /= -2) then + A(:ng,ng+1)=real(matmul(LLR(:ng,:ng),savg(ind1,:ng)),4) + do ig=1,ng + do jg=1,ng + if(jym /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,3*ng+jg)*savg(5*ll4f+ll4x+jym,jg),4) + if(jym_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,4*ng+jg)*savg(5*ll4f+ll4x+jym_p,jg),4) + if(jyp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,6*ng+jg)*savg(5*ll4f+ll4x+jyp,jg),4) + if(jyp_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,7*ng+jg)*savg(5*ll4f+ll4x+jyp_p,jg),4) + enddo + enddo + endif + call ALSB(ng,1,A,ier,ng) + if(ier /= 0) call XABORT('NSSANM2: singular matrix.(1)') + savg(5*ll4f+jxm,:ng)=A(:ng,ng+1) + ! + ! two-node relations + do i=nxmin,nxmax-1 + ind1=idl(i,j) + if(ind1 == 0) call XABORT('NSSANM2: invalid idl index.(2)') + ind2=idl(i+1,j) + if(ind2 == 0) call XABORT('NSSANM2: invalid idl index.(3)') + if(kn(1,i+1,j) /= kn(2,i,j)) call XABORT('NSSANM2: invalid kn index.(1)') + if(iqfr(2,i,j) /= 0) call XABORT('NSSANM2: invalid iqfr index.(1)') + if(iqfr(1,i+1,j) /= 0) call XABORT('NSSANM2: invalid iqfr index.(2)') + jxm=kn(1,i,j) ; jxp=kn(2,i,j) ; jym=kn(3,i,j) ; jyp=kn(4,i,j) + jym_m=0 ; jyp_m=0 ; jym_pp=0 ; jyp_pp=0 + if((i == 1).and.(iqfr(1,1,j) == -2)) then + jym_m=kn(3,1,j) ; jyp_m=kn(4,1,j) + else if(i > 1) then + jym_m=kn(3,i-1,j) ; jyp_m=kn(4,i-1,j) + endif + jym_p=kn(3,i+1,j) ; jyp_p=kn(4,i+1,j) + if((i == nx-1).and.(iqfr(2,nx,j) == -2)) then + jym_pp=kn(3,nx,j) ; jyp_pp=kn(4,nx,j) + else if(i < nx-1) then + jym_pp=kn(3,i+2,j) ; jyp_pp=kn(4,i+2,j) + endif + ! + A(:ng,:ng+1)=0.0 + ! node i + LLR(:ng,:8*ng)=matmul(fd(mat(i,j),2,:ng,:ng),Rx(:ng,:8*ng,i,j)) + do ig=1,ng + A(:ng,ig)=A(:ng,ig)+real(LLR(:ng,ng+ig),4) + do jg=1,ng + A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,jg)*savg(ind1,jg),4) + if(jym_m /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,2*ng+jg)*savg(5*ll4f+ll4x+jym_m,jg),4) + if(jym /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,3*ng+jg)*savg(5*ll4f+ll4x+jym,jg),4) + if(jym_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,4*ng+jg)*savg(5*ll4f+ll4x+jym_p,jg),4) + if(jyp_m /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,5*ng+jg)*savg(5*ll4f+ll4x+jyp_m,jg),4) + if(jyp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,6*ng+jg)*savg(5*ll4f+ll4x+jyp,jg),4) + if(jyp_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,7*ng+jg)*savg(5*ll4f+ll4x+jyp_p,jg),4) + enddo + enddo + ! node i+1 + LLR(:ng,:8*ng)=matmul(fd(mat(i+1,j),1,:ng,:ng),Lx(:ng,:8*ng,i+1,j)) + do ig=1,ng + A(:ng,ig)=A(:ng,ig)+real(-LLR(:ng,ng+ig),4) + do jg=1,ng + A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,jg)*savg(ind2,jg),4) + if(jym /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,2*ng+jg)*savg(5*ll4f+ll4x+jym,jg),4) + if(jym_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,3*ng+jg)*savg(5*ll4f+ll4x+jym_p,jg),4) + if(jym_pp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,4*ng+jg)*savg(5*ll4f+ll4x+jym_pp,jg),4) + if(jyp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,5*ng+jg)*savg(5*ll4f+ll4x+jyp,jg),4) + if(jyp_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,6*ng+jg)*savg(5*ll4f+ll4x+jyp_p,jg),4) + if(jyp_pp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,7*ng+jg)*savg(5*ll4f+ll4x+jyp_pp,jg),4) + enddo + enddo + call ALSB(ng,1,A,ier,ng) + if(ier /= 0) call XABORT('NSSANM2: singular matrix.(2)') + if(jxp /= 0) savg(5*ll4f+jxp,:ng)=A(:ng,ng+1) + enddo + ! + ! one-node relation at right + ind1=idl(nxmax,j) + if(ind1 == 0) call XABORT('NSSANM2: invalid idl index.(4)') + iqf2=iqfr(2,nxmax,j) + jxm=kn(1,nxmax,j) ; jxp=kn(2,nxmax,j) ; jym=kn(3,nxmax,j) ; jyp=kn(4,nxmax,j) + jym_m=0 ; jyp_m=0 + if(nxmax > 1) then + jym_m=kn(3,nxmax-1,j) ; jyp_m=kn(4,nxmax-1,j) + endif + A(:ng,:ng+1)=0.0 + LLR(:ng,:8*ng)=0.0 + if((iqf2 > 0).or.(iqf2 == -1)) then + ! physical albedo + Lambda(:ng,:ng)=0.0 + do ig=1,ng + Lambda(ig,ig)=qfr(2,nxmax,j,ig) + enddo + LLR(:ng,:8*ng)=matmul(Lambda(:ng,:ng),Rx(:ng,:8*ng,nxmax,j)) + A(:ng,:ng)=real(LLR(:ng,ng+1:2*ng),4) + do ig=1,ng + A(ig,ig)=-1.0+A(ig,ig) + enddo + else if(iqf2 == -2) then + ! zero net current + do ig=1,ng + A(ig,ig)=1.0 + enddo + else if(iqf2 == -3) then + ! zero flux + LLR(:ng,:8*ng)=Rx(:ng,:8*ng,nxmax,j) + A(:ng,:ng)=real(LLR(:ng,ng+1:2*ng),4) + else if(iqf2 == -4) then + call XABORT('NSSANM2: SYME boundary condition is not supported.(2)') + else + call XABORT('NSSANM2: illegal right X-boundary condition.') + endif + if(iqf2 /= -2) then + A(:ng,ng+1)=real(matmul(-LLR(:ng,:ng),savg(ind1,:ng)),4) + do ig=1,ng + do jg=1,ng + if(jym_m /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,2*ng+jg)*savg(5*ll4f+ll4x+jym_m,jg),4) + if(jym /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,3*ng+jg)*savg(5*ll4f+ll4x+jym,jg),4) + if(jyp_m /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,5*ng+jg)*savg(5*ll4f+ll4x+jyp_m,jg),4) + if(jyp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,6*ng+jg)*savg(5*ll4f+ll4x+jyp,jg),4) + enddo + enddo + endif + call ALSB(ng,1,A,ier,ng) + if(ier /= 0) call XABORT('NSSANM2: singular matrix.(3)') + if(jxp /= 0) savg(5*ll4f+jxp,:ng)=A(:ng,ng+1) + enddo + !---- + ! one- and two-node relations along Y axis + !---- + do i=1,nx + nymin=1 + do j=1,ny + if(mat(i,j) > 0) exit + nymin=j+1 + enddo + if(nymin > ny) cycle + nymax=ny + do j=ny,1,-1 + if(mat(i,j) > 0) exit + nymax=j-1 + enddo + ! one-node relation at left + ind1=idl(i,nymin) + if(ind1 == 0) call XABORT('NSSANM2: invalid idl index.(5)') + iqf3=iqfr(3,i,nymin) + jxm=kn(1,i,nymin) ; jxp=kn(2,i,nymin) ; jym=kn(3,i,nymin) ; jyp=kn(4,i,nymin) + jxm_p=0 ; jxp_p=0 + if(nymin < ny) then + jxm_p=kn(1,i,nymin+1) ; jxp_p=kn(2,i,nymin+1) + endif + A(:ng,:ng+1)=0.0 + LLR(:ng,:8*ng)=0.0 + if((iqf3 > 0).or.(iqf3 == -1)) then + ! physical albedo + Lambda(:ng,:ng)=0.0 + do ig=1,ng + Lambda(ig,ig)=qfr(3,i,nymin,ig) + enddo + LLR(:ng,:8*ng)=matmul(Lambda(:ng,:ng),Ly(:ng,:8*ng,i,nymin)) + A(:ng,:ng)=-real(LLR(:ng,ng+1:2*ng),4) + do ig=1,ng + A(ig,ig)=-1.0+A(ig,ig) + enddo + else if(iqf3 == -2) then + ! zero net current + do ig=1,ng + A(ig,ig)=1.0 + enddo + else if(iqf3 == -3) then + ! zero flux + LLR(:ng,:8*ng)=Ly(:ng,:8*ng,i,nymin) + A(:ng,:ng)=real(-LLR(:ng,ng+1:2*ng),4) + else if(iqf3 == -4) then + call XABORT('NSSANM2: SYME boundary condition is not supported.(3)') + else + call XABORT('NSSANM2: illegal left Y-boundary condition.') + endif + if(iqf3 /= -2) then + A(:ng,ng+1)=real(matmul(LLR(:ng,:ng),savg(ind1,:ng)),4) + do ig=1,ng + do jg=1,ng + if(jxm /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,3*ng+jg)*savg(5*ll4f+jxm,jg),4) + if(jxm_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,4*ng+jg)*savg(5*ll4f+jxm_p,jg),4) + if(jxp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,6*ng+jg)*savg(5*ll4f+jxp,jg),4) + if(jxp_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,7*ng+jg)*savg(5*ll4f+jxp_p,jg),4) + enddo + enddo + endif + call ALSB(ng,1,A,ier,ng) + if(ier /= 0) call XABORT('NSSANM2: singular matrix.(4)') + if(jym /= 0) savg(5*ll4f+ll4x+jym,:ng)=A(:ng,ng+1) + ! + ! two-node relations + do j=nymin,nymax-1 + ind1=idl(i,j) + if(ind1 == 0) call XABORT('NSSANM2: invalid idl index.(6)') + ind2=idl(i,j+1) + if(ind2 == 0) call XABORT('NSSANM2: invalid idl index.(7)') + if(kn(3,i,j+1) /= kn(4,i,j)) call XABORT('NSSANM2: invalid kn index.(2)') + if(iqfr(4,i,j) /= 0) call XABORT('NSSANM2: invalid iqfr index.(3)') + if(iqfr(3,i,j+1) /= 0) call XABORT('NSSANM2: invalid iqfr index.(4)') + jxm=kn(1,i,j) ; jxp=kn(2,i,j) ; jym=kn(3,i,j) ; jyp=kn(4,i,j) + jxm_m=0 ; jxp_m=0 ; jxm_pp=0 ; jxp_pp=0 + if((j == 1).and.(iqfr(3,i,1) == -2)) then + jxm_m=kn(1,i,1) ; jxp_m=kn(2,i,1) + else if(j > 1) then + jxm_m=kn(1,i,j-1) ; jxp_m=kn(2,i,j-1) + endif + jxm_p=kn(1,i,j+1) ; jxp_p=kn(2,i,j+1) + if((j == ny-1).and.(iqfr(4,i,ny) == -2)) then + jxm_pp=kn(1,i,ny) ; jxp_pp=kn(2,i,ny) + else if(j < ny-1) then + jxm_pp=kn(1,i,j+2) ; jxp_pp=kn(2,i,j+2) + endif + ! + A(:ng,:ng+1)=0.0 + ! node j + LLR(:ng,:8*ng)=matmul(fd(mat(i,j),4,:ng,:ng),Ry(:ng,:8*ng,i,j)) + do ig=1,ng + A(:ng,ig)=A(:ng,ig)+real(LLR(:ng,ng+ig),4) + do jg=1,ng + A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,jg)*savg(ind1,jg),4) + if(jxm_m /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,2*ng+jg)*savg(5*ll4f+jxm_m,jg),4) + if(jxm /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,3*ng+jg)*savg(5*ll4f+jxm,jg),4) + if(jxm_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,4*ng+jg)*savg(5*ll4f+jxm_p,jg),4) + if(jxp_m /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,5*ng+jg)*savg(5*ll4f+jxp_m,jg),4) + if(jxp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,6*ng+jg)*savg(5*ll4f+jxp,jg),4) + if(jxp_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,7*ng+jg)*savg(5*ll4f+jxp_p,jg),4) + enddo + enddo + ! node j+1 + LLR(:ng,:8*ng)=matmul(fd(mat(i,j+1),3,:ng,:ng),Ly(:ng,:8*ng,i,j+1)) + do ig=1,ng + A(:ng,ig)=A(:ng,ig)+real(-LLR(:ng,ng+ig),4) + do jg=1,ng + A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,jg)*savg(ind2,jg),4) + if(jxm /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,2*ng+jg)*savg(5*ll4f+jxm,jg),4) + if(jxm_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,3*ng+jg)*savg(5*ll4f+jxm_p,jg),4) + if(jxm_pp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,4*ng+jg)*savg(5*ll4f+jxm_pp,jg),4) + if(jxp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,5*ng+jg)*savg(5*ll4f+jxp,jg),4) + if(jxp_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,6*ng+jg)*savg(5*ll4f+jxp_p,jg),4) + if(jxp_pp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,7*ng+jg)*savg(5*ll4f+jxp_pp,jg),4) + enddo + enddo + call ALSB(ng,1,A,ier,ng) + if(ier /= 0) call XABORT('NSSANM2: singular matrix.(5)') + if(jyp /= 0) savg(5*ll4f+ll4x+jyp,:ng)=A(:ng,ng+1) + enddo + ! + ! one-node relation at right + ind1=idl(i,nymax) + if(ind1 == 0) call XABORT('NSSANM2: invalid idl index.(8)') + iqf4=iqfr(4,i,nymax) + jxm=kn(1,i,nymax) ; jxp=kn(2,i,nymax) ; jym=kn(3,i,nymax) ; jyp=kn(4,i,nymax) + jxm_m=0 ; jxp_m=0 + if(nymax > 1) then + jxm_m=kn(1,i,nymax-1) ; jxp_m=kn(2,i,nymax-1) + endif + A(:ng,:ng+1)=0.0 + LLR(:ng,:8*ng)=0.0 + if((iqf4 > 0).or.(iqf4 == -1)) then + ! physical albedo + Lambda(:ng,:ng)=0.0 + do ig=1,ng + Lambda(ig,ig)=qfr(4,i,nymax,ig) + enddo + LLR(:ng,:8*ng)=matmul(Lambda(:ng,:ng),Ry(:ng,:8*ng,i,nymax)) + A(:ng,:ng)=real(LLR(:ng,ng+1:2*ng),4) + do ig=1,ng + A(ig,ig)=-1.0+A(ig,ig) + enddo + else if(iqf4 == -2) then + ! zero net current + do ig=1,ng + A(ig,ig)=1.0 + enddo + else if(iqf4 == -3) then + ! zero flux + LLR(:ng,:8*ng)=Ry(:ng,:8*ng,i,nymax) + A(:ng,:ng)=real(LLR(:ng,ng+1:2*ng),4) + else if(iqf4 == -4) then + call XABORT('NSSANM2: SYME boundary condition is not supported.(4)') + else + call XABORT('NSSANM2: illegal right Y-boundary condition.') + endif + if(iqf4 /= -2) then + A(:ng,ng+1)=real(matmul(-LLR(:ng,:ng),savg(ind1,:ng)),4) + do ig=1,ng + do jg=1,ng + if(jxm_m /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,2*ng+jg)*savg(5*ll4f+jxm_m,jg),4) + if(jxm /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,3*ng+jg)*savg(5*ll4f+jxm,jg),4) + if(jxp_m /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,5*ng+jg)*savg(5*ll4f+jxp_m,jg),4) + if(jxp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,6*ng+jg)*savg(5*ll4f+jxp,jg),4) + enddo + enddo + endif + call ALSB(ng,1,A,ier,ng) + if(ier /= 0) call XABORT('NSSANM2: singular matrix.(6)') + if(jyp /= 0) savg(5*ll4f+ll4x+jyp,:ng)=A(:ng,ng+1) + enddo + !---- + ! end of transverse current iterations + !---- + enddo + !---- + ! compute boundary fluxes + !---- + do j=1,ny + do i=1,nx + ind1=idl(i,j) + if(ind1 == 0) cycle + jxm=kn(1,i,j) ; jxp=kn(2,i,j) ; jym=kn(3,i,j) ; jyp=kn(4,i,j) + jym_m=0 ; jyp_m=0 ; jym_p=0 ; jyp_p=0 + if((i == 1).and.(iqfr(1,1,j) == -2)) then + jym_m=kn(3,1,j) ; jyp_m=kn(4,1,j) + else if(i > 1) then + jym_m=kn(3,i-1,j) ; jyp_m=kn(4,i-1,j) + endif + if((i == nx).and.(iqfr(2,nx,j) == -2)) then + jym_p=kn(3,nx,j) ; jyp_p=kn(4,nx,j) + else if(i < nx) then + jym_p=kn(3,i+1,j) ; jyp_p=kn(4,i+1,j) + endif + ! x- relations + savg(ll4f+ind1,:ng)=real(matmul(Lx(:ng,:ng,i,j),savg(ind1,:ng)),4) + if(jxm /= 0) savg(ll4f+ind1,:ng)=savg(ll4f+ind1,:ng)+ & + & real(matmul(Lx(:ng,ng+1:2*ng,i,j),savg(5*ll4f+jxm,:ng)),4) + if(jym_m /= 0) savg(ll4f+ind1,:ng)=savg(ll4f+ind1,:ng)+ & + & real(matmul(Lx(:ng,2*ng+1:3*ng,i,j),savg(5*ll4f+ll4x+jym_m,:ng)),4) + if(jym /= 0) savg(ll4f+ind1,:ng)=savg(ll4f+ind1,:ng)+ & + & real(matmul(Lx(:ng,3*ng+1:4*ng,i,j),savg(5*ll4f+ll4x+jym,:ng)),4) + if(jym_p /= 0) savg(ll4f+ind1,:ng)=savg(ll4f+ind1,:ng)+ & + & real(matmul(Lx(:ng,4*ng+1:5*ng,i,j),savg(5*ll4f+ll4x+jym_p,:ng)),4) + if(jyp_m /= 0) savg(ll4f+ind1,:ng)=savg(ll4f+ind1,:ng)+ & + & real(matmul(Lx(:ng,5*ng+1:6*ng,i,j),savg(5*ll4f+ll4x+jyp_m,:ng)),4) + if(jyp /= 0) savg(ll4f+ind1,:ng)=savg(ll4f+ind1,:ng)+ & + & real(matmul(Lx(:ng,6*ng+1:7*ng,i,j),savg(5*ll4f+ll4x+jyp,:ng)),4) + if(jyp_p /= 0) savg(ll4f+ind1,:ng)=savg(ll4f+ind1,:ng)+ & + & real(matmul(Lx(:ng,7*ng+1:8*ng,i,j),savg(5*ll4f+ll4x+jyp_p,:ng)),4) + ! + ! x+ relations + savg(2*ll4f+ind1,:ng)=real(matmul(Rx(:ng,:ng,i,j),savg(ind1,:ng)),4) + if(jxp /= 0) savg(2*ll4f+ind1,:ng)=savg(2*ll4f+ind1,:ng)+ & + & real(matmul(Rx(:ng,ng+1:2*ng,i,j),savg(5*ll4f+jxp,:ng)),4) + if(jym_m /= 0) savg(2*ll4f+ind1,:ng)=savg(2*ll4f+ind1,:ng)+ & + & real(matmul(Rx(:ng,2*ng+1:3*ng,i,j),savg(5*ll4f+ll4x+jym_m,:ng)),4) + if(jym /= 0) savg(2*ll4f+ind1,:ng)=savg(2*ll4f+ind1,:ng)+ & + & real(matmul(Rx(:ng,3*ng+1:4*ng,i,j),savg(5*ll4f+ll4x+jym,:ng)),4) + if(jym_p /= 0) savg(2*ll4f+ind1,:ng)=savg(2*ll4f+ind1,:ng)+ & + & real(matmul(Rx(:ng,4*ng+1:5*ng,i,j),savg(5*ll4f+ll4x+jym_p,:ng)),4) + if(jyp_m /= 0) savg(2*ll4f+ind1,:ng)=savg(2*ll4f+ind1,:ng)+ & + & real(matmul(Rx(:ng,5*ng+1:6*ng,i,j),savg(5*ll4f+ll4x+jyp_m,:ng)),4) + if(jyp /= 0) savg(2*ll4f+ind1,:ng)=savg(2*ll4f+ind1,:ng)+ & + & real(matmul(Rx(:ng,6*ng+1:7*ng,i,j),savg(5*ll4f+ll4x+jyp,:ng)),4) + if(jyp_p /= 0) savg(2*ll4f+ind1,:ng)=savg(2*ll4f+ind1,:ng)+ & + & real(matmul(Rx(:ng,7*ng+1:8*ng,i,j),savg(5*ll4f+ll4x+jyp_p,:ng)),4) + ! + jxm_m=0 ; jxp_m=0 ; jxm_p=0 ; jxp_p=0 + jxm=kn(1,i,j) ; jxp=kn(2,i,j) ; jym=kn(3,i,j) ; jyp=kn(4,i,j) + if((j == 1).and.(iqfr(3,i,1) == -2)) then + jxm_m=kn(1,i,1) ; jxp_m=kn(2,i,1) + else if(j > 1) then + jxm_m=kn(1,i,j-1) ; jxp_m=kn(2,i,j-1) + endif + if((j == ny).and.(iqfr(4,i,ny) == -2)) then + jxm_p=kn(1,i,ny) ; jxp_p=kn(2,i,ny) + else if(j < ny) then + jxm_p=kn(1,i,j+1) ; jxp_p=kn(2,i,j+1) + endif + ! y- relations + savg(3*ll4f+ind1,:ng)=real(matmul(Ly(:ng,:ng,i,j),savg(ind1,:ng)),4) + if(jym /= 0) savg(3*ll4f+ind1,:ng)=savg(3*ll4f+ind1,:ng)+ & + & real(matmul(Ly(:ng,ng+1:2*ng,i,j),savg(5*ll4f+ll4x+jym,:ng)),4) + if(jxm_m /= 0) savg(3*ll4f+ind1,:ng)=savg(3*ll4f+ind1,:ng)+ & + & real(matmul(Ly(:ng,2*ng+1:3*ng,i,j),savg(5*ll4f+jxm_m,:ng)),4) + if(jxm /= 0) savg(3*ll4f+ind1,:ng)=savg(3*ll4f+ind1,:ng)+ & + & real(matmul(Ly(:ng,3*ng+1:4*ng,i,j),savg(5*ll4f+jxm,:ng)),4) + if(jxm_p /= 0) savg(3*ll4f+ind1,:ng)=savg(3*ll4f+ind1,:ng)+ & + & real(matmul(Ly(:ng,4*ng+1:5*ng,i,j),savg(5*ll4f+jxm_p,:ng)),4) + if(jxp_m /= 0) savg(3*ll4f+ind1,:ng)=savg(3*ll4f+ind1,:ng)+ & + & real(matmul(Ly(:ng,5*ng+1:6*ng,i,j),savg(5*ll4f+jxp_m,:ng)),4) + if(jxp /= 0) savg(3*ll4f+ind1,:ng)=savg(3*ll4f+ind1,:ng)+ & + & real(matmul(Ly(:ng,6*ng+1:7*ng,i,j),savg(5*ll4f+jxp,:ng)),4) + if(jxp_p /= 0) savg(3*ll4f+ind1,:ng)=savg(3*ll4f+ind1,:ng)+ & + & real(matmul(Ly(:ng,7*ng+1:8*ng,i,j),savg(5*ll4f+jxp_p,:ng)),4) + ! + ! y+ relations + savg(4*ll4f+ind1,:ng)=real(matmul(Ry(:ng,:ng,i,j),savg(ind1,:ng)),4) + if(jyp /= 0) savg(4*ll4f+ind1,:ng)=savg(4*ll4f+ind1,:ng)+ & + & real(matmul(Ry(:ng,ng+1:2*ng,i,j),savg(5*ll4f+ll4x+jyp,:ng)),4) + if(jxm_m /= 0) savg(4*ll4f+ind1,:ng)=savg(4*ll4f+ind1,:ng)+ & + & real(matmul(Ry(:ng,2*ng+1:3*ng,i,j),savg(5*ll4f+jxm_m,:ng)),4) + if(jxm /= 0) savg(4*ll4f+ind1,:ng)=savg(4*ll4f+ind1,:ng)+ & + & real(matmul(Ry(:ng,3*ng+1:4*ng,i,j),savg(5*ll4f+jxm,:ng)),4) + if(jxm_p /= 0) savg(4*ll4f+ind1,:ng)=savg(4*ll4f+ind1,:ng)+ & + & real(matmul(Ry(:ng,4*ng+1:5*ng,i,j),savg(5*ll4f+jxm_p,:ng)),4) + if(jxp_m /= 0) savg(4*ll4f+ind1,:ng)=savg(4*ll4f+ind1,:ng)+ & + & real(matmul(Ry(:ng,5*ng+1:6*ng,i,j),savg(5*ll4f+jxp_m,:ng)),4) + if(jxp /= 0) savg(4*ll4f+ind1,:ng)=savg(4*ll4f+ind1,:ng)+ & + & real(matmul(Ry(:ng,6*ng+1:7*ng,i,j),savg(5*ll4f+jxp,:ng)),4) + if(jxp_p /= 0) savg(4*ll4f+ind1,:ng)=savg(4*ll4f+ind1,:ng)+ & + & real(matmul(Ry(:ng,7*ng+1:8*ng,i,j),savg(5*ll4f+jxp_p,:ng)),4) + enddo + enddo + !---- + ! scratch storage deallocation + !---- + deallocate(Ry,Ly,Rx,Lx) + deallocate(work5,work4,work3,work2,work1) + deallocate(LLR,Lambda,A) +end subroutine NSSANM2 diff --git a/Trivac/src/NSSANM3.f90 b/Trivac/src/NSSANM3.f90 new file mode 100755 index 0000000..0f92381 --- /dev/null +++ b/Trivac/src/NSSANM3.f90 @@ -0,0 +1,1071 @@ +subroutine NSSANM3(nunkn,nx,ny,nz,ll4f,ll4x,ll4y,ng,bndtl,npass,nmix,idl, & +& kn,iqfr,qfr,mat,xxx,yyy,zzz,keff,diff,sigr,chi,sigf,scat,fd,savg) +! +!----------------------------------------------------------------------- +! +!Purpose: +! Compute the ANM boundary fluxes and currents using a solution of +! one- and two-node relations in Cartesian 3D geometry. +! +!Copyright: +! Copyright (C) 2022 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version +! +!Author(s): A. Hebert +! +!Parameters: input +! nunkn number of unknowns per energy group. +! nx number of x-nodes in the nodal calculation. +! ny number of y-nodes in the nodal calculation. +! nz number of z-nodes in the nodal calculation. +! ll4f number of averaged flux unknowns. +! ll4x number of X-directed net currents. +! ll4y number of Y-directed net currents. +! ng number of energy groups. +! bndtl set to 'flat' or 'quadratic'. +! npass number of transverse current iterations. +! nmix number of material mixtures in the nodal calculation. +! idl position of averaged fluxes in unknown vector. +! kn element-ordered interface net current unknown list. +! iqfr node-ordered physical albedo indices. +! qfr albedo function information. +! mat material mixture index in eacn node. +! xxx Cartesian coordinates along the X axis. +! yyy Cartesian coordinates along the Y axis. +! zzz Cartesian coordinates along the Z axis. +! keff effective multiplication facctor. +! diff diffusion coefficients +! sigr removal cross sections. +! chi fission spectra. +! sigf nu times fission cross section. +! scat scattering cross section. +! fd discontinuity factors. +! savg nodal fluxes and net currents. +! +!Parameters: output +! savg nodal fluxes, boundary fluxes and net currents. +! +!----------------------------------------------------------------------- + ! + !---- + ! subroutine arguments + !---- + integer,intent(in) :: nunkn,nx,ny,nz,ll4f,ll4x,ll4y,ng,npass,nmix,idl(nx,ny,nz), & + & kn(6,nx,ny,nz),iqfr(6,nx,ny,nz),mat(nx,ny,nz) + real,intent(in) :: qfr(6,nx,ny,nz,ng),xxx(nx+1),yyy(ny+1),zzz(nz+1),keff,diff(nmix,ng), & + & sigr(nmix,ng),chi(nmix,ng),sigf(nmix,ng),scat(nmix,ng,ng),fd(nmix,6,ng,ng) + real, dimension(nunkn,ng),intent(inout) :: savg + character(len=12), intent(in) :: bndtl + !---- + ! local and allocatable arrays + !---- + real :: xyz(4) + real, allocatable, dimension(:) :: work1,work2,work4,work5 + real, allocatable, dimension(:,:) :: A,Lambda,work3 + real(kind=8), allocatable, dimension(:,:) :: LLR + real(kind=8), allocatable, dimension(:,:,:,:,:) :: Lx,Rx,Ly,Ry,Lz,Rz + !---- + ! scratch storage allocation + !---- + allocate(A(ng,ng+1),Lambda(ng,ng),LLR(ng,14*ng)) + allocate(work1(ng),work2(ng),work3(ng,ng),work4(ng),work5(ng)) + allocate(Lx(ng,14*ng,nx,ny,nz),Rx(ng,14*ng,nx,ny,nz)) + allocate(Ly(ng,14*ng,nx,ny,nz),Ry(ng,14*ng,nx,ny,nz)) + allocate(Lz(ng,14*ng,nx,ny,nz),Rz(ng,14*ng,nx,ny,nz)) + !---- + ! compute 3D ANM coupling matrices for each single node + !---- + do k=1,nz + delz=zzz(k+1)-zzz(k) + do j=1,ny + dely=yyy(j+1)-yyy(j) + do i=1,nx + delx=xxx(i+1)-xxx(i) + ibm=mat(i,j,k) + if(ibm == 0) cycle + work1(:ng)=diff(ibm,:ng) + work2(:ng)=sigr(ibm,:ng) + work3(:ng,:ng)=scat(ibm,:ng,:ng) + work4(:ng)=chi(ibm,:ng) + work5(:ng)=sigf(ibm,:ng) + ! + kk1=iqfr(1,i,j,k) + kk2=iqfr(2,i,j,k) + xyz(2:3)=xxx(i:i+1)-xxx(i) + if(kk1 == -2) then + ! reflection boundary condition + xyz(1)=2.0*xyz(2)-xyz(3) + else if(kk1 < 0) then + ! zero/void/albedo boundary condition + xyz(1)=-99999. + else + ! left neighbour + xyz(1)=xxx(i-1)-xxx(i) + endif + if(kk2 == -2) then + ! reflection boundary condition + xyz(4)=2.0*xyz(3)-xyz(2) + else if(kk2 < 0) then + ! zero/void/albedo boundary condition + xyz(4)=-99999. + else + ! right neighbour + xyz(4)=xxx(i+2)-xxx(i) + endif + call NSSLR3(keff,ng,bndtl,xyz,dely,delz,work1,work2,work3, & + & work4,work5,Lx(1,1,i,j,k),Rx(1,1,i,j,k)) + ! + kk3=iqfr(3,i,j,k) + kk4=iqfr(4,i,j,k) + xyz(2:3)=yyy(j:j+1)-yyy(j) + if(kk3 == -2) then + ! reflection boundary condition + xyz(1)=2.0*xyz(2)-xyz(3) + else if(kk3 < 0) then + ! zero/void/albedo boundary condition + xyz(1)=-99999. + else + ! left neighbour + xyz(1)=yyy(j-1)-yyy(j) + endif + if(kk4 == -2) then + ! reflection boundary condition + xyz(4)=2.0*xyz(3)-xyz(2) + else if(kk4 < 0) then + ! zero/void/albedo boundary condition + xyz(4)=-99999.0 + else + ! right neighbour + xyz(4)=yyy(j+2)-yyy(j) + endif + call NSSLR3(keff,ng,bndtl,xyz,delz,delx,work1,work2,work3, & + & work4,work5,Ly(1,1,i,j,k),Ry(1,1,i,j,k)) + ! + kk5=iqfr(5,i,j,k) + kk6=iqfr(6,i,j,k) + xyz(2:3)=zzz(k:k+1)-zzz(k) + if(kk5 == -2) then + ! reflection boundary condition + xyz(1)=2.0*xyz(2)-xyz(3) + else if(kk5 < 0) then + ! zero/void/albedo boundary condition + xyz(1)=-99999. + else + ! left neighbour + xyz(1)=zzz(k-1)-zzz(k) + endif + if(kk6 == -2) then + ! reflection boundary condition + xyz(4)=2.0*xyz(3)-xyz(2) + else if(kk6 < 0) then + ! zero/void/albedo boundary condition + xyz(4)=-99999.0 + else + ! right neighbour + xyz(4)=zzz(k+2)-zzz(k) + endif + call NSSLR3(keff,ng,bndtl,xyz,delx,dely,work1,work2,work3, & + & work4,work5,Lz(1,1,i,j,k),Rz(1,1,i,j,k)) + enddo + enddo + enddo + !---- + ! perform transverse current iterations + !---- + do ipass=1,npass + !---- + ! one- and two-node relations along X axis + !---- + do k=1,nz + do j=1,ny + nxmin=1 + do i=1,nx + if(mat(i,j,k) > 0) exit + nxmin=i+1 + enddo + if(nxmin > nx) cycle + nxmax=nx + do i=nx,1,-1 + if(mat(i,j,k) > 0) exit + nxmax=i-1 + enddo + ! one-node relation at left + ind1=idl(nxmin,j,k) + if(ind1 == 0) call XABORT('NSSANM3: invalid idl index.(1)') + iqf1=iqfr(1,nxmin,j,k) + jxm=kn(1,nxmin,j,k) ; jxp=kn(2,nxmin,j,k) ; jym=kn(3,nxmin,j,k) ; jyp=kn(4,nxmin,j,k) + jzm=kn(5,nxmin,j,k) ; jzp=kn(6,nxmin,j,k) + jym_p=0 ; jyp_p=0 ; jzm_p=0 ; jzp_p=0 + if(nxmin < nx) then + jym_p=kn(3,nxmin+1,j,k) ; jyp_p=kn(4,nxmin+1,j,k) + jzm_p=kn(5,nxmin+1,j,k) ; jzp_p=kn(6,nxmin+1,j,k) + endif + A(:ng,:ng+1)=0.0 + LLR(:ng,:14*ng)=0.0 + if((iqf1 > 0).or.(iqf1 == -1)) then + ! physical albedo + Lambda(:ng,:ng)=0.0 + do ig=1,ng + Lambda(ig,ig)=qfr(1,nxmin,j,k,ig) + enddo + LLR(:ng,:14*ng)=matmul(Lambda(:ng,:ng),Lx(:ng,:14*ng,nxmin,j,k)) + A(:ng,:ng)=-real(LLR(:ng,ng+1:2*ng),4) + do ig=1,ng + A(ig,ig)=-1.0+A(ig,ig) + enddo + else if(iqf1 == -2) then + ! zero net current + do ig=1,ng + A(ig,ig)=1.0 + enddo + else if(iqf1 == -3) then + ! zero flux + LLR(:ng,:14*ng)=Lx(:ng,:14*ng,nxmin,j,k) + A(:ng,:ng)=real(-LLR(:ng,ng+1:2*ng),4) + else if(iqf1 == -4) then + call XABORT('NSSANM3: SYME boundary condition is not supported.(1)') + else + call XABORT('NSSANM3: illegal left X-boundary condition.') + endif + if(iqf1 /= -2) then + A(:ng,ng+1)=real(matmul(LLR(:ng,:ng),savg(ind1,:ng)),4) + do ig=1,ng + do jg=1,ng + if(jym /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,3*ng+jg)*savg(7*ll4f+ll4x+jym,jg),4) + if(jym_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,4*ng+jg)*savg(7*ll4f+ll4x+jym_p,jg),4) + if(jyp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,6*ng+jg)*savg(7*ll4f+ll4x+jyp,jg),4) + if(jyp_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,7*ng+jg)*savg(7*ll4f+ll4x+jyp_p,jg),4) + ! + if(jzm /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,9*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzm,jg),4) + if(jzm_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,10*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzm_p,jg),4) + if(jzp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,12*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzp,jg),4) + if(jzp_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,13*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzp_p,jg),4) + enddo + enddo + endif + call ALSB(ng,1,A,ier,ng) + if(ier /= 0) call XABORT('NSSANM3: singular matrix.(1)') + if(jxm /= 0) savg(7*ll4f+jxm,:ng)=A(:ng,ng+1) + ! + ! two-node relations + do i=nxmin,nxmax-1 + ind1=idl(i,j,k) + if(ind1 == 0) call XABORT('NSSANM3: invalid idl index.(2)') + ind2=idl(i+1,j,k) + if(ind2 == 0) call XABORT('NSSANM3: invalid idl index.(3)') + if(kn(1,i+1,j,k) /= kn(2,i,j,k)) call XABORT('NSSANM3: invalid kn index.(1)') + if(iqfr(2,i,j,k) /= 0) call XABORT('NSSANM3: invalid iqfr index.(1)') + if(iqfr(1,i+1,j,k) /= 0) call XABORT('NSSANM3: invalid iqfr index.(2)') + jxm=kn(1,i,j,k) ; jxp=kn(2,i,j,k) ; jym=kn(3,i,j,k) ; jyp=kn(4,i,j,k) + jzm=kn(5,i,j,k) ; jzp=kn(6,i,j,k) + jym_m=0 ; jyp_m=0 ; jym_pp=0 ; jyp_pp=0 + jzm_m=0 ; jzp_m=0 ; jzm_pp=0 ; jzp_pp=0 + if((i == 1).and.(iqfr(1,1,j,k) == -2)) then + jym_m=kn(3,1,j,k) ; jyp_m=kn(4,1,j,k) + jzm_m=kn(5,1,j,k) ; jzp_m=kn(6,1,j,k) + else if(i > 1) then + jym_m=kn(3,i-1,j,k) ; jyp_m=kn(4,i-1,j,k) + jzm_m=kn(5,i-1,j,k) ; jzp_m=kn(6,i-1,j,k) + endif + jym_p=kn(3,i+1,j,k) ; jyp_p=kn(4,i+1,j,k) + jzm_p=kn(5,i+1,j,k) ; jzp_p=kn(6,i+1,j,k) + if((i == nx-1).and.(iqfr(2,nx,j,k) == -2)) then + jym_pp=kn(3,nx,j,k) ; jyp_pp=kn(4,nx,j,k) + jzm_pp=kn(5,nx,j,k) ; jzp_pp=kn(6,nx,j,k) + else if(i < nx-1) then + jym_pp=kn(3,i+2,j,k) ; jyp_pp=kn(4,i+2,j,k) + jzm_pp=kn(5,i+2,j,k) ; jzp_pp=kn(6,i+2,j,k) + endif + ! + A(:ng,:ng+1)=0.0 + ! node i + LLR(:ng,:14*ng)=matmul(fd(mat(i,j,k),2,:ng,:ng),Rx(:ng,:14*ng,i,j,k)) + do ig=1,ng + A(:ng,ig)=A(:ng,ig)+real(LLR(:ng,ng+ig),4) + do jg=1,ng + A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,jg)*savg(ind1,jg),4) + if(jym_m /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,2*ng+jg)*savg(7*ll4f+ll4x+jym_m,jg),4) + if(jym /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,3*ng+jg)*savg(7*ll4f+ll4x+jym,jg),4) + if(jym_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,4*ng+jg)*savg(7*ll4f+ll4x+jym_p,jg),4) + if(jyp_m /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,5*ng+jg)*savg(7*ll4f+ll4x+jyp_m,jg),4) + if(jyp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,6*ng+jg)*savg(7*ll4f+ll4x+jyp,jg),4) + if(jyp_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,7*ng+jg)*savg(7*ll4f+ll4x+jyp_p,jg),4) + ! + if(jzm_m /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,8*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzm_m,jg),4) + if(jzm /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,9*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzm,jg),4) + if(jzm_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,10*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzm_p,jg),4) + if(jzp_m /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,11*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzp_m,jg),4) + if(jzp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,12*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzp,jg),4) + if(jzp_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,13*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzp_p,jg),4) + enddo + enddo + ! node i+1 + LLR(:ng,:14*ng)=matmul(fd(mat(i+1,j,k),1,:ng,:ng),Lx(:ng,:14*ng,i+1,j,k)) + do ig=1,ng + A(:ng,ig)=A(:ng,ig)+real(-LLR(:ng,ng+ig),4) + do jg=1,ng + A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,jg)*savg(ind2,jg),4) + if(jym /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,2*ng+jg)*savg(7*ll4f+ll4x+jym,jg),4) + if(jym_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,3*ng+jg)*savg(7*ll4f+ll4x+jym_p,jg),4) + if(jym_pp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,4*ng+jg)*savg(7*ll4f+ll4x+jym_pp,jg),4) + if(jyp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,5*ng+jg)*savg(7*ll4f+ll4x+jyp,jg),4) + if(jyp_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,6*ng+jg)*savg(7*ll4f+ll4x+jyp_p,jg),4) + if(jyp_pp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,7*ng+jg)*savg(7*ll4f+ll4x+jyp_pp,jg),4) + ! + if(jzm /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,8*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzm,jg),4) + if(jzm_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,9*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzm_p,jg),4) + if(jzm_pp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,10*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzm_pp,jg),4) + if(jzp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,11*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzp,jg),4) + if(jzp_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,12*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzp_p,jg),4) + if(jzp_pp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,13*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzp_pp,jg),4) + enddo + enddo + call ALSB(ng,1,A,ier,ng) + if(ier /= 0) call XABORT('NSSANM3: singular matrix.(2)') + if(jxp /= 0) savg(7*ll4f+jxp,:ng)=A(:ng,ng+1) + enddo + ! + ! one-node relation at right + ind1=idl(nxmax,j,k) + if(ind1 == 0) call XABORT('NSSANM3: invalid idl index.(4)') + iqf2=iqfr(2,nxmax,j,k) + jxm=kn(1,nxmax,j,k) ; jxp=kn(2,nxmax,j,k) ; jym=kn(3,nxmax,j,k) ; jyp=kn(4,nxmax,j,k) + jzm=kn(5,nxmax,j,k) ; jzp=kn(6,nxmax,j,k) + jym_m=0 ; jyp_m=0 ; jzm_m=0 ; jzp_m=0 + if(nxmax > 1) then + jym_m=kn(3,nxmax-1,j,k) ; jyp_m=kn(4,nxmax-1,j,k) + jzm_m=kn(5,nxmax-1,j,k) ; jzp_m=kn(6,nxmax-1,j,k) + endif + A(:ng,:ng+1)=0.0 + LLR(:ng,:14*ng)=0.0 + if((iqf2 > 0).or.(iqf2 == -1)) then + ! physical albedo + Lambda(:ng,:ng)=0.0 + do ig=1,ng + Lambda(ig,ig)=qfr(2,nxmax,j,k,ig) + enddo + LLR(:ng,:14*ng)=matmul(Lambda(:ng,:ng),Rx(:ng,:14*ng,nxmax,j,k)) + A(:ng,:ng)=real(LLR(:ng,ng+1:2*ng),4) + do ig=1,ng + A(ig,ig)=-1.0+A(ig,ig) + enddo + else if(iqf2 == -2) then + ! zero net current + do ig=1,ng + A(ig,ig)=1.0 + enddo + else if(iqf2 == -3) then + ! zero flux + LLR(:ng,:14*ng)=Rx(:ng,:14*ng,nxmax,j,k) + A(:ng,:ng)=real(LLR(:ng,ng+1:2*ng),4) + else if(iqf2 == -4) then + call XABORT('NSSANM3: SYME boundary condition is not supported.(2)') + else + call XABORT('NSSANM3: illegal right X-boundary condition.') + endif + if(iqf2 /= -2) then + A(:ng,ng+1)=real(matmul(-LLR(:ng,:ng),savg(ind1,:ng)),4) + do ig=1,ng + do jg=1,ng + if(jym_m /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,2*ng+jg)*savg(7*ll4f+ll4x+jym_m,jg),4) + if(jym /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,3*ng+jg)*savg(7*ll4f+ll4x+jym,jg),4) + if(jyp_m /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,5*ng+jg)*savg(7*ll4f+ll4x+jyp_m,jg),4) + if(jyp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,6*ng+jg)*savg(7*ll4f+ll4x+jyp,jg),4) + ! + if(jzm_m /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,8*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzm_m,jg),4) + if(jzm /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,9*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzm,jg),4) + if(jzp_m /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,11*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzp_m,jg),4) + if(jzp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,12*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzp,jg),4) + enddo + enddo + endif + call ALSB(ng,1,A,ier,ng) + if(ier /= 0) call XABORT('NSSANM3: singular matrix.(3)') + if(jxp /= 0) savg(7*ll4f+jxp,:ng)=A(:ng,ng+1) + enddo + enddo + !---- + ! one- and two-node relations along Y axis + !---- + do i=1,nx + do k=1,nz + nymin=1 + do j=1,ny + if(mat(i,j,k) > 0) exit + nymin=j+1 + enddo + if(nymin > ny) cycle + nymax=ny + do j=ny,1,-1 + if(mat(i,j,k) > 0) exit + nymax=j-1 + enddo + ! one-node relation at left + ind1=idl(i,nymin,k) + if(ind1 == 0) call XABORT('NSSANM3: invalid idl index.(5)') + iqf3=iqfr(3,i,nymin,k) + jxm=kn(1,i,nymin,k) ; jxp=kn(2,i,nymin,k) ; jym=kn(3,i,nymin,k) ; jyp=kn(4,i,nymin,k) + jzm=kn(5,i,nymin,k) ; jzp=kn(6,i,nymin,k) + jxm_p=0 ; jxp_p=0 ; jzm_p=0 ; jzp_p=0 + if(nymin < ny) then + jxm_p=kn(1,i,nymin+1,k) ; jxp_p=kn(2,i,nymin+1,k) + jzm_p=kn(5,i,nymin+1,k) ; jzp_p=kn(6,i,nymin+1,k) + endif + A(:ng,:ng+1)=0.0 + LLR(:ng,:14*ng)=0.0 + if((iqf3 > 0).or.(iqf3 == -1)) then + ! physical albedo + Lambda(:ng,:ng)=0.0 + do ig=1,ng + Lambda(ig,ig)=qfr(3,i,nymin,k,ig) + enddo + LLR(:ng,:14*ng)=matmul(Lambda(:ng,:ng),Ly(:ng,:14*ng,i,nymin,k)) + A(:ng,:ng)=-real(LLR(:ng,ng+1:2*ng),4) + do ig=1,ng + A(ig,ig)=-1.0+A(ig,ig) + enddo + else if(iqf3 == -2) then + ! zero net current + do ig=1,ng + A(ig,ig)=1.0 + enddo + else if(iqf3 == -3) then + ! zero flux + LLR(:ng,:14*ng)=Ly(:ng,:14*ng,i,nymin,k) + A(:ng,:ng)=real(-LLR(:ng,ng+1:2*ng),4) + else if(iqf3 == -4) then + call XABORT('NSSANM3: SYME boundary condition is not supported.(3)') + else + call XABORT('NSSANM3: illegal left Y-boundary condition.') + endif + if(iqf3 /= -2) then + A(:ng,ng+1)=real(matmul(LLR(:ng,:ng),savg(ind1,:ng)),4) + do ig=1,ng + do jg=1,ng + if(jzm /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,3*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzm,jg),4) + if(jzm_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,4*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzm_p,jg),4) + if(jzp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,6*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzp,jg),4) + if(jzp_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,7*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzp_p,jg),4) + ! + if(jxm /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,9*ng+jg)*savg(7*ll4f+jxm,jg),4) + if(jxm_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,10*ng+jg)*savg(7*ll4f+jxm_p,jg),4) + if(jxp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,12*ng+jg)*savg(7*ll4f+jxp,jg),4) + if(jxp_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,13*ng+jg)*savg(7*ll4f+jxp_p,jg),4) + enddo + enddo + endif + call ALSB(ng,1,A,ier,ng) + if(ier /= 0) call XABORT('NSSANM3: singular matrix.(4)') + if(jym /= 0) savg(7*ll4f+ll4x+jym,:ng)=A(:ng,ng+1) + ! + ! two-node relations + do j=nymin,nymax-1 + ind1=idl(i,j,k) + if(ind1 == 0) call XABORT('NSSANM3: invalid idl index.(6)') + ind2=idl(i,j+1,k) + if(ind2 == 0) call XABORT('NSSANM3: invalid idl index.(7)') + if(kn(3,i,j+1,k) /= kn(4,i,j,k)) call XABORT('NSSANM3: invalid kn index.(2)') + if(iqfr(4,i,j,k) /= 0) call XABORT('NSSANM3: invalid iqfr index.(3)') + if(iqfr(3,i,j+1,k) /= 0) call XABORT('NSSANM3: invalid iqfr index.(4)') + jxm=kn(1,i,j,k) ; jxp=kn(2,i,j,k) ; jym=kn(3,i,j,k) ; jyp=kn(4,i,j,k) + jzm=kn(5,i,j,k) ; jzp=kn(6,i,j,k) + jxm_m=0 ; jxp_m=0 ; jxm_pp=0 ; jxp_pp=0 + jzm_m=0 ; jzp_m=0 ; jzm_pp=0 ; jzp_pp=0 + if((j == 1).and.(iqfr(3,i,1,k) == -2)) then + jxm_m=kn(1,i,1,k) ; jxp_m=kn(2,i,1,k) + jzm_m=kn(5,i,1,k) ; jzp_m=kn(6,i,1,k) + else if(j > 1) then + jxm_m=kn(1,i,j-1,k) ; jxp_m=kn(2,i,j-1,k) + jzm_m=kn(5,i,j-1,k) ; jzp_m=kn(6,i,j-1,k) + endif + jxm_p=kn(1,i,j+1,k) ; jxp_p=kn(2,i,j+1,k) + jzm_p=kn(5,i,j+1,k) ; jzp_p=kn(6,i,j+1,k) + if((j == ny-1).and.(iqfr(4,i,ny,k) == -2)) then + jxm_pp=kn(1,i,ny,k) ; jxp_pp=kn(2,i,ny,k) + jzm_pp=kn(5,i,ny,k) ; jzp_pp=kn(6,i,ny,k) + else if(j < ny-1) then + jxm_pp=kn(1,i,j+2,k) ; jxp_pp=kn(2,i,j+2,k) + jzm_pp=kn(5,i,j+2,k) ; jzp_pp=kn(6,i,j+2,k) + endif + ! + A(:ng,:ng+1)=0.0 + ! node j + LLR(:ng,:14*ng)=matmul(fd(mat(i,j,k),4,:ng,:ng),Ry(:ng,:14*ng,i,j,k)) + do ig=1,ng + A(:ng,ig)=A(:ng,ig)+real(LLR(:ng,ng+ig),4) + do jg=1,ng + A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,jg)*savg(ind1,jg),4) + if(jzm_m /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,2*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzm_m,jg),4) + if(jzm /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,3*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzm,jg),4) + if(jzm_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,4*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzm_p,jg),4) + if(jzp_m /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,5*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzp_m,jg),4) + if(jzp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,6*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzp,jg),4) + if(jzp_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,7*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzp_p,jg),4) + ! + if(jxm_m /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,8*ng+jg)*savg(7*ll4f+jxm_m,jg),4) + if(jxm /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,9*ng+jg)*savg(7*ll4f+jxm,jg),4) + if(jxm_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,10*ng+jg)*savg(7*ll4f+jxm_p,jg),4) + if(jxp_m /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,11*ng+jg)*savg(7*ll4f+jxp_m,jg),4) + if(jxp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,12*ng+jg)*savg(7*ll4f+jxp,jg),4) + if(jxp_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,13*ng+jg)*savg(7*ll4f+jxp_p,jg),4) + enddo + enddo + ! node j+1 + LLR(:ng,:14*ng)=matmul(fd(mat(i,j+1,k),3,:ng,:ng),Ly(:ng,:14*ng,i,j+1,k)) + do ig=1,ng + A(:ng,ig)=A(:ng,ig)+real(-LLR(:ng,ng+ig),4) + do jg=1,ng + A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,jg)*savg(ind2,jg),4) + if(jzm /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,2*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzm,jg),4) + if(jzm_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,3*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzm_p,jg),4) + if(jzm_pp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,4*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzm_pp,jg),4) + if(jzp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,5*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzp,jg),4) + if(jzp_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,6*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzp_p,jg),4) + if(jzp_pp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,7*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzp_pp,jg),4) + ! + if(jxm /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,8*ng+jg)*savg(7*ll4f+jxm,jg),4) + if(jxm_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,9*ng+jg)*savg(7*ll4f+jxm_p,jg),4) + if(jxm_pp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,10*ng+jg)*savg(7*ll4f+jxm_pp,jg),4) + if(jxp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,11*ng+jg)*savg(7*ll4f+jxp,jg),4) + if(jxp_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,12*ng+jg)*savg(7*ll4f+jxp_p,jg),4) + if(jxp_pp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,13*ng+jg)*savg(7*ll4f+jxp_pp,jg),4) + enddo + enddo + call ALSB(ng,1,A,ier,ng) + if(ier /= 0) call XABORT('NSSANM3: singular matrix.(5)') + if(jyp /= 0) savg(7*ll4f+ll4x+jyp,:ng)=A(:ng,ng+1) + enddo + ! + ! one-node relation at right + ind1=idl(i,nymax,k) + if(ind1 == 0) call XABORT('NSSANM3: invalid idl index.(8)') + iqf4=iqfr(4,i,nymax,k) + jxm=kn(1,i,nymax,k) ; jxp=kn(2,i,nymax,k) ; jym=kn(3,i,nymax,k) ; jyp=kn(4,i,nymax,k) + jzm=kn(5,i,nymax,k) ; jzp=kn(6,i,nymax,k) + jxm_m=0 ; jxp_m=0 ; jzm_m=0 ; jzp_m=0 + if(nymax > 1) then + jxm_m=kn(1,i,nymax-1,k) ; jxp_m=kn(2,i,nymax-1,k) + jzm_m=kn(5,i,nymax-1,k) ; jzp_m=kn(6,i,nymax-1,k) + endif + A(:ng,:ng+1)=0.0 + LLR(:ng,:14*ng)=0.0 + if((iqf4 > 0).or.(iqf4 == -1)) then + ! physical albedo + Lambda(:ng,:ng)=0.0 + do ig=1,ng + Lambda(ig,ig)=qfr(4,i,nymax,k,ig) + enddo + LLR(:ng,:14*ng)=matmul(Lambda(:ng,:ng),Ry(:ng,:14*ng,i,nymax,k)) + A(:ng,:ng)=real(LLR(:ng,ng+1:2*ng),4) + do ig=1,ng + A(ig,ig)=-1.0+A(ig,ig) + enddo + else if(iqf4 == -2) then + ! zero net current + do ig=1,ng + A(ig,ig)=1.0 + enddo + else if(iqf4 == -3) then + ! zero flux + LLR(:ng,:14*ng)=Ry(:ng,:14*ng,i,nymax,k) + A(:ng,:ng)=real(LLR(:ng,ng+1:2*ng),4) + else if(iqf4 == -4) then + call XABORT('NSSANM3: SYME boundary condition is not supported.(4)') + else + call XABORT('NSSANM3: illegal right Y-boundary condition.') + endif + if(iqf4 /= -2) then + A(:ng,ng+1)=real(matmul(-LLR(:ng,:ng),savg(ind1,:ng)),4) + do ig=1,ng + do jg=1,ng + if(jzm_m /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,2*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzm_m,jg),4) + if(jzm /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,3*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzm,jg),4) + if(jzp_m /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,5*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzp_m,jg),4) + if(jzp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,6*ng+jg)*savg(7*ll4f+ll4x+ll4y+jzp,jg),4) + ! + if(jxm_m /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,8*ng+jg)*savg(7*ll4f+jxm_m,jg),4) + if(jxm /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,9*ng+jg)*savg(7*ll4f+jxm,jg),4) + if(jxp_m /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,11*ng+jg)*savg(7*ll4f+jxp_m,jg),4) + if(jxp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,12*ng+jg)*savg(7*ll4f+jxp,jg),4) + enddo + enddo + endif + call ALSB(ng,1,A,ier,ng) + if(ier /= 0) call XABORT('NSSANM3: singular matrix.(6)') + if(jyp /= 0) savg(7*ll4f+ll4x+jyp,:ng)=A(:ng,ng+1) + enddo + enddo + !---- + ! one- and two-node relations along Z axis + !---- + do j=1,ny + do i=1,nx + nzmin=1 + do k=1,nz + if(mat(i,j,k) > 0) exit + nzmin=k+1 + enddo + if(nzmin > nz) cycle + nzmax=nz + do k=nz,1,-1 + if(mat(i,j,k) > 0) exit + nzmax=k-1 + enddo + ! one-node relation at left + ind1=idl(i,j,nzmin) + if(ind1 == 0) call XABORT('NSSANM3: invalid idl index.(9)') + iqf5=iqfr(5,i,j,nzmin) + jxm=kn(1,i,j,nzmin) ; jxp=kn(2,i,j,nzmin) ; jym=kn(3,i,j,nzmin) ; jyp=kn(4,i,j,nzmin) + jzm=kn(5,i,j,nzmin) ; jzp=kn(6,i,j,nzmin) + jxm_p=0 ; jxp_p=0 ; jym_p=0 ; jyp_p=0 + if(nzmin < nz) then + jxm_p=kn(1,i,j,nzmin+1) ; jxp_p=kn(2,i,j,nzmin+1) + jym_p=kn(3,i,j,nzmin+1) ; jyp_p=kn(4,i,j,nzmin+1) + endif + A(:ng,:ng+1)=0.0 + LLR(:ng,:14*ng)=0.0 + if((iqf5 > 0).or.(iqf5 == -1)) then + ! physical albedo + Lambda(:ng,:ng)=0.0 + do ig=1,ng + Lambda(ig,ig)=qfr(5,i,j,nzmin,ig) + enddo + LLR(:ng,:14*ng)=matmul(Lambda(:ng,:ng),Lz(:ng,:14*ng,i,j,nzmin)) + A(:ng,:ng)=-real(LLR(:ng,ng+1:2*ng),4) + do ig=1,ng + A(ig,ig)=-1.0+A(ig,ig) + enddo + else if(iqf5 == -2) then + ! zero net current + do ig=1,ng + A(ig,ig)=1.0 + enddo + else if(iqf5 == -3) then + ! zero flux + LLR(:ng,:14*ng)=Lz(:ng,:14*ng,i,j,nzmin) + A(:ng,:ng)=real(-LLR(:ng,ng+1:2*ng),4) + else if(iqf5 == -4) then + call XABORT('NSSANM3: SYME boundary condition is not supported.(5)') + else + call XABORT('NSSANM3: illegal left Z-boundary condition.') + endif + if(iqf5 /= -2) then + A(:ng,ng+1)=real(matmul(LLR(:ng,:ng),savg(ind1,:ng)),4) + do ig=1,ng + do jg=1,ng + if(jxm /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,3*ng+jg)*savg(7*ll4f+jxm,jg),4) + if(jxm_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,4*ng+jg)*savg(7*ll4f+jxm_p,jg),4) + if(jxp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,6*ng+jg)*savg(7*ll4f+jxp,jg),4) + if(jxp_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,7*ng+jg)*savg(7*ll4f+jxp_p,jg),4) + ! + if(jym /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,9*ng+jg)*savg(7*ll4f+ll4x+jym,jg),4) + if(jym_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,10*ng+jg)*savg(7*ll4f+ll4x+jym_p,jg),4) + if(jyp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,12*ng+jg)*savg(7*ll4f+ll4x+jyp,jg),4) + if(jyp_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,13*ng+jg)*savg(7*ll4f+ll4x+jyp_p,jg),4) + enddo + enddo + endif + call ALSB(ng,1,A,ier,ng) + if(ier /= 0) call XABORT('NSSANM3: singular matrix.(7)') + if(jzm /= 0) savg(7*ll4f+ll4x+ll4y+jzm,:ng)=A(:ng,ng+1) + ! + ! two-node relations + do k=nzmin,nzmax-1 + ind1=idl(i,j,k) + if(ind1 == 0) call XABORT('NSSANM3: invalid idl index.(10)') + ind2=idl(i,j,k+1) + if(ind2 == 0) call XABORT('NSSANM3: invalid idl index.(11)') + if(kn(5,i,j,k+1) /= kn(6,i,j,k)) call XABORT('NSSANM3: invalid kn index.(3)') + if(iqfr(6,i,j,k) /= 0) call XABORT('NSSANM3: invalid iqfr index.(5)') + if(iqfr(5,i,j,k+1) /= 0) call XABORT('NSSANM3: invalid iqfr index.(6)') + jxm=kn(1,i,j,k) ; jxp=kn(2,i,j,k) ; jym=kn(3,i,j,k) ; jyp=kn(4,i,j,k) + jzm=kn(5,i,j,k) ; jzp=kn(6,i,j,k) + jxm_m=0 ; jxp_m=0 ; jxm_pp=0 ; jxp_pp=0 + jym_m=0 ; jyp_m=0 ; jym_pp=0 ; jyp_pp=0 + if((k == 1).and.(iqfr(5,i,j,1) == -2)) then + jxm_m=kn(1,i,j,1) ; jxp_m=kn(2,i,j,1) + jym_m=kn(3,i,j,1) ; jyp_m=kn(4,i,j,1) + else if(k > 1) then + jxm_m=kn(1,i,j,k-1) ; jxp_m=kn(2,i,j,k-1) + jym_m=kn(3,i,j,k-1) ; jyp_m=kn(4,i,j,k-1) + endif + jxm_p=kn(1,i,j,k+1) ; jxp_p=kn(2,i,j,k+1) + jym_p=kn(3,i,j,k+1) ; jyp_p=kn(4,i,j,k+1) + if((k == nz-1).and.(iqfr(6,i,j,nz) == -2)) then + jxm_pp=kn(1,i,j,nz) ; jxp_pp=kn(2,i,j,nz) + jym_pp=kn(3,i,j,nz) ; jyp_pp=kn(4,i,j,nz) + else if(k < nz-1) then + jxm_pp=kn(1,i,j,k+2) ; jxp_pp=kn(2,i,j,k+2) + jym_pp=kn(3,i,j,k+2) ; jyp_pp=kn(4,i,j,k+2) + endif + ! + A(:ng,:ng+1)=0.0 + ! node i + LLR(:ng,:14*ng)=matmul(fd(mat(i,j,k),6,:ng,:ng),Rz(:ng,:14*ng,i,j,k)) + do ig=1,ng + A(:ng,ig)=A(:ng,ig)+real(LLR(:ng,ng+ig),4) + do jg=1,ng + A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,jg)*savg(ind1,jg),4) + if(jxm_m /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,2*ng+jg)*savg(7*ll4f+jxm_m,jg),4) + if(jxm /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,3*ng+jg)*savg(7*ll4f+jxm,jg),4) + if(jxm_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,4*ng+jg)*savg(7*ll4f+jxm_p,jg),4) + if(jxp_m /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,5*ng+jg)*savg(7*ll4f+jxp_m,jg),4) + if(jxp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,6*ng+jg)*savg(7*ll4f+jxp,jg),4) + if(jxp_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,7*ng+jg)*savg(7*ll4f+jxp_p,jg),4) + ! + if(jym_m /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,8*ng+jg)*savg(7*ll4f+ll4x+jym_m,jg),4) + if(jym /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,9*ng+jg)*savg(7*ll4f+ll4x+jym,jg),4) + if(jym_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,10*ng+jg)*savg(7*ll4f+ll4x+jym_p,jg),4) + if(jyp_m /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,11*ng+jg)*savg(7*ll4f+ll4x+jyp_m,jg),4) + if(jyp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,12*ng+jg)*savg(7*ll4f+ll4x+jyp,jg),4) + if(jyp_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,13*ng+jg)*savg(7*ll4f+ll4x+jyp_p,jg),4) + enddo + enddo + ! node i+1 + LLR(:ng,:14*ng)=matmul(fd(mat(i,j,k+1),5,:ng,:ng),Lz(:ng,:14*ng,i,j,k+1)) + do ig=1,ng + A(:ng,ig)=A(:ng,ig)+real(-LLR(:ng,ng+ig),4) + do jg=1,ng + A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,jg)*savg(ind2,jg),4) + if(jxm /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,2*ng+jg)*savg(7*ll4f+jxm,jg),4) + if(jxm_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,3*ng+jg)*savg(7*ll4f+jxm_p,jg),4) + if(jxm_pp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,4*ng+jg)*savg(7*ll4f+jxm_pp,jg),4) + if(jxp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,5*ng+jg)*savg(7*ll4f+jxp,jg),4) + if(jxp_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,6*ng+jg)*savg(7*ll4f+jxp_p,jg),4) + if(jxp_pp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,7*ng+jg)*savg(7*ll4f+jxp_pp,jg),4) + ! + if(jym /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,8*ng+jg)*savg(7*ll4f+ll4x+jym,jg),4) + if(jym_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,9*ng+jg)*savg(7*ll4f+ll4x+jym_p,jg),4) + if(jym_pp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,10*ng+jg)*savg(7*ll4f+ll4x+jym_pp,jg),4) + if(jyp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,11*ng+jg)*savg(7*ll4f+ll4x+jyp,jg),4) + if(jyp_p /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,12*ng+jg)*savg(7*ll4f+ll4x+jyp_p,jg),4) + if(jyp_pp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(LLR(ig,13*ng+jg)*savg(7*ll4f+ll4x+jyp_pp,jg),4) + enddo + enddo + call ALSB(ng,1,A,ier,ng) + if(ier /= 0) call XABORT('NSSANM3: singular matrix.(8)') + if(jzp /= 0) savg(7*ll4f+ll4x+ll4y+jzp,:ng)=A(:ng,ng+1) + enddo + ! + ! one-node relation at right + ind1=idl(i,j,nzmax) + if(ind1 == 0) call XABORT('NSSANM3: invalid idl index.(12)') + iqf6=iqfr(6,i,j,nzmax) + jxm=kn(1,i,j,nzmax) ; jxp=kn(2,i,j,nzmax) ; jym=kn(3,i,j,nzmax) ; jyp=kn(4,i,j,nzmax) + jzm=kn(5,i,j,nzmax) ; jzp=kn(6,i,j,nzmax) + jxm_m=0 ; jxp_m=0 ; jym_m=0 ; jyp_m=0 + if(nzmax > 1) then + jxm_m=kn(1,i,j,nzmax-1) ; jxp_m=kn(2,i,j,nzmax-1) + jym_m=kn(3,i,j,nzmax-1) ; jyp_m=kn(4,i,j,nzmax-1) + endif + A(:ng,:ng+1)=0.0 + LLR(:ng,:14*ng)=0.0 + if((iqf6 > 0).or.(iqf6 == -1)) then + ! physical albedo + Lambda(:ng,:ng)=0.0 + do ig=1,ng + Lambda(ig,ig)=qfr(6,i,j,nzmax,ig) + enddo + LLR(:ng,:14*ng)=matmul(Lambda(:ng,:ng),Rz(:ng,:14*ng,i,j,nzmax)) + A(:ng,:ng)=real(LLR(:ng,ng+1:2*ng),4) + do ig=1,ng + A(ig,ig)=-1.0+A(ig,ig) + enddo + else if(iqf6 == -2) then + ! zero net current + do ig=1,ng + A(ig,ig)=1.0 + enddo + else if(iqf6 == -3) then + ! zero flux + LLR(:ng,:14*ng)=Rz(:ng,:14*ng,i,j,nzmax) + A(:ng,:ng)=real(LLR(:ng,ng+1:2*ng),4) + else if(iqf6 == -4) then + call XABORT('NSSANM3: SYME boundary condition is not supported.(6)') + else + call XABORT('NSSANM3: illegal right Z-boundary condition.') + endif + if(iqf6 /= -2) then + A(:ng,ng+1)=real(matmul(-LLR(:ng,:ng),savg(ind1,:ng)),4) + do ig=1,ng + do jg=1,ng + if(jxm_m /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,2*ng+jg)*savg(7*ll4f+jxm_m,jg),4) + if(jxm /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,3*ng+jg)*savg(7*ll4f+jxm,jg),4) + if(jxp_m /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,5*ng+jg)*savg(7*ll4f+jxp_m,jg),4) + if(jxp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,6*ng+jg)*savg(7*ll4f+jxp,jg),4) + ! + if(jym_m /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,8*ng+jg)*savg(7*ll4f+ll4x+jym_m,jg),4) + if(jym /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,9*ng+jg)*savg(7*ll4f+ll4x+jym,jg),4) + if(jyp_m /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,11*ng+jg)*savg(7*ll4f+ll4x+jyp_m,jg),4) + if(jyp /= 0) A(ig,ng+1)=A(ig,ng+1)+real(-LLR(ig,12*ng+jg)*savg(7*ll4f+ll4x+jyp,jg),4) + enddo + enddo + endif + call ALSB(ng,1,A,ier,ng) + if(ier /= 0) call XABORT('NSSANM3: singular matrix.(9)') + if(jzp /= 0) savg(7*ll4f+ll4x+ll4y+jzp,:ng)=A(:ng,ng+1) + enddo + enddo + !---- + ! end of transverse current iterations + !---- + enddo + !---- + ! compute boundary fluxes + !---- + do k=1,nz + do j=1,ny + do i=1,nx + ind1=idl(i,j,k) + if(ind1 == 0) cycle + jxm=kn(1,i,j,k) ; jxp=kn(2,i,j,k) ; jym=kn(3,i,j,k) ; jyp=kn(4,i,j,k) + jzm=kn(5,i,j,k) ; jzp=kn(6,i,j,k) + ! + jym_m=0 ; jyp_m=0 ; jym_p=0 ; jyp_p=0 + jzm_m=0 ; jzp_m=0 ; jzm_p=0 ; jzp_p=0 + if((i == 1).and.(iqfr(1,1,j,k) == -2)) then + jym_m=kn(3,1,j,k) ; jyp_m=kn(4,1,j,k) + jzm_m=kn(5,1,j,k) ; jzp_m=kn(6,1,j,k) + else if(i > 1) then + jym_m=kn(3,i-1,j,k) ; jyp_m=kn(4,i-1,j,k) + jzm_m=kn(5,i-1,j,k) ; jzp_m=kn(6,i-1,j,k) + endif + if((i == nx).and.(iqfr(2,nx,j,k) == -2)) then + jym_p=kn(3,nx,j,k) ; jyp_p=kn(4,nx,j,k) + jzm_p=kn(5,nx,j,k) ; jzp_p=kn(6,nx,j,k) + else if(i < nx) then + jym_p=kn(3,i+1,j,k) ; jyp_p=kn(4,i+1,j,k) + jzm_p=kn(5,i+1,j,k) ; jzp_p=kn(6,i+1,j,k) + endif + ! x- relations + savg(ll4f+ind1,:ng)=real(matmul(Lx(:ng,:ng,i,j,k),savg(ind1,:ng)),4) + if(jxm /= 0) savg(ll4f+ind1,:ng)=savg(ll4f+ind1,:ng)+ & + & real(matmul(Lx(:ng,ng+1:2*ng,i,j,k),savg(7*ll4f+jxm,:ng)),4) + ! + if(jym_m /= 0) savg(ll4f+ind1,:ng)=savg(ll4f+ind1,:ng)+ & + & real(matmul(Lx(:ng,2*ng+1:3*ng,i,j,k),savg(7*ll4f+ll4x+jym_m,:ng)),4) + if(jym /= 0) savg(ll4f+ind1,:ng)=savg(ll4f+ind1,:ng)+ & + & real(matmul(Lx(:ng,3*ng+1:4*ng,i,j,k),savg(7*ll4f+ll4x+jym,:ng)),4) + if(jym_p /= 0) savg(ll4f+ind1,:ng)=savg(ll4f+ind1,:ng)+ & + & real(matmul(Lx(:ng,4*ng+1:5*ng,i,j,k),savg(7*ll4f+ll4x+jym_p,:ng)),4) + if(jyp_m /= 0) savg(ll4f+ind1,:ng)=savg(ll4f+ind1,:ng)+ & + & real(matmul(Lx(:ng,5*ng+1:6*ng,i,j,k),savg(7*ll4f+ll4x+jyp_m,:ng)),4) + if(jyp /= 0) savg(ll4f+ind1,:ng)=savg(ll4f+ind1,:ng)+ & + & real(matmul(Lx(:ng,6*ng+1:7*ng,i,j,k),savg(7*ll4f+ll4x+jyp,:ng)),4) + if(jyp_p /= 0) savg(ll4f+ind1,:ng)=savg(ll4f+ind1,:ng)+ & + & real(matmul(Lx(:ng,7*ng+1:8*ng,i,j,k),savg(7*ll4f+ll4x+jyp_p,:ng)),4) + ! + if(jzm_m /= 0) savg(ll4f+ind1,:ng)=savg(ll4f+ind1,:ng)+ & + & real(matmul(Lx(:ng,8*ng+1:9*ng,i,j,k),savg(7*ll4f+ll4x+ll4y+jzm_m,:ng)),4) + if(jzm /= 0) savg(ll4f+ind1,:ng)=savg(ll4f+ind1,:ng)+ & + & real(matmul(Lx(:ng,9*ng+1:10*ng,i,j,k),savg(7*ll4f+ll4x+ll4y+jzm,:ng)),4) + if(jzm_p /= 0) savg(ll4f+ind1,:ng)=savg(ll4f+ind1,:ng)+ & + & real(matmul(Lx(:ng,10*ng+1:11*ng,i,j,k),savg(7*ll4f+ll4x+ll4y+jzm_p,:ng)),4) + if(jzp_m /= 0) savg(ll4f+ind1,:ng)=savg(ll4f+ind1,:ng)+ & + & real(matmul(Lx(:ng,11*ng+1:12*ng,i,j,k),savg(7*ll4f+ll4x+ll4y+jzp_m,:ng)),4) + if(jzp /= 0) savg(ll4f+ind1,:ng)=savg(ll4f+ind1,:ng)+ & + & real(matmul(Lx(:ng,12*ng+1:13*ng,i,j,k),savg(7*ll4f+ll4x+ll4y+jzp,:ng)),4) + if(jzp_p /= 0) savg(ll4f+ind1,:ng)=savg(ll4f+ind1,:ng)+ & + & real(matmul(Lx(:ng,13*ng+1:14*ng,i,j,k),savg(7*ll4f+ll4x+ll4y+jzp_p,:ng)),4) + ! + ! x+ relations + savg(2*ll4f+ind1,:ng)=real(matmul(Rx(:ng,:ng,i,j,k),savg(ind1,:ng)),4) + if(jxp /= 0) savg(2*ll4f+ind1,:ng)=savg(2*ll4f+ind1,:ng)+ & + & real(matmul(Rx(:ng,ng+1:2*ng,i,j,k),savg(7*ll4f+jxp,:ng)),4) + ! + if(jym_m /= 0) savg(2*ll4f+ind1,:ng)=savg(2*ll4f+ind1,:ng)+ & + & real(matmul(Rx(:ng,2*ng+1:3*ng,i,j,k),savg(7*ll4f+ll4x+jym_m,:ng)),4) + if(jym /= 0) savg(2*ll4f+ind1,:ng)=savg(2*ll4f+ind1,:ng)+ & + & real(matmul(Rx(:ng,3*ng+1:4*ng,i,j,k),savg(7*ll4f+ll4x+jym,:ng)),4) + if(jym_p /= 0) savg(2*ll4f+ind1,:ng)=savg(2*ll4f+ind1,:ng)+ & + & real(matmul(Rx(:ng,4*ng+1:5*ng,i,j,k),savg(7*ll4f+ll4x+jym_p,:ng)),4) + if(jyp_m /= 0) savg(2*ll4f+ind1,:ng)=savg(2*ll4f+ind1,:ng)+ & + & real(matmul(Rx(:ng,5*ng+1:6*ng,i,j,k),savg(7*ll4f+ll4x+jyp_m,:ng)),4) + if(jyp /= 0) savg(2*ll4f+ind1,:ng)=savg(2*ll4f+ind1,:ng)+ & + & real(matmul(Rx(:ng,6*ng+1:7*ng,i,j,k),savg(7*ll4f+ll4x+jyp,:ng)),4) + if(jyp_p /= 0) savg(2*ll4f+ind1,:ng)=savg(2*ll4f+ind1,:ng)+ & + & real(matmul(Rx(:ng,7*ng+1:8*ng,i,j,k),savg(7*ll4f+ll4x+jyp_p,:ng)),4) + ! + if(jzm_m /= 0) savg(2*ll4f+ind1,:ng)=savg(2*ll4f+ind1,:ng)+ & + & real(matmul(Rx(:ng,8*ng+1:9*ng,i,j,k),savg(7*ll4f+ll4x+ll4y+jzm_m,:ng)),4) + if(jzm /= 0) savg(2*ll4f+ind1,:ng)=savg(2*ll4f+ind1,:ng)+ & + & real(matmul(Rx(:ng,9*ng+1:10*ng,i,j,k),savg(7*ll4f+ll4x+ll4y+jzm,:ng)),4) + if(jzm_p /= 0) savg(2*ll4f+ind1,:ng)=savg(2*ll4f+ind1,:ng)+ & + & real(matmul(Rx(:ng,10*ng+1:11*ng,i,j,k),savg(7*ll4f+ll4x+ll4y+jzm_p,:ng)),4) + if(jzp_m /= 0) savg(2*ll4f+ind1,:ng)=savg(2*ll4f+ind1,:ng)+ & + & real(matmul(Rx(:ng,11*ng+1:12*ng,i,j,k),savg(7*ll4f+ll4x+ll4y+jzp_m,:ng)),4) + if(jzp /= 0) savg(2*ll4f+ind1,:ng)=savg(2*ll4f+ind1,:ng)+ & + & real(matmul(Rx(:ng,12*ng+1:13*ng,i,j,k),savg(7*ll4f+ll4x+ll4y+jzp,:ng)),4) + if(jzp_p /= 0) savg(2*ll4f+ind1,:ng)=savg(2*ll4f+ind1,:ng)+ & + & real(matmul(Rx(:ng,13*ng+1:14*ng,i,j,k),savg(7*ll4f+ll4x+ll4y+jzp_p,:ng)),4) + ! + jxm_m=0 ; jxp_m=0 ; jxm_p=0 ; jxp_p=0 + jzm_m=0 ; jzp_m=0 ; jzm_p=0 ; jzp_p=0 + jxm=kn(1,i,j,k) ; jxp=kn(2,i,j,k) ; jym=kn(3,i,j,k) ; jyp=kn(4,i,j,k) + jzm=kn(5,i,j,k) ; jzp=kn(6,i,j,k) + if((j == 1).and.(iqfr(3,i,1,k) == -2)) then + jxm_m=kn(1,i,1,k) ; jxp_m=kn(2,i,1,k) + jzm_m=kn(5,i,1,k) ; jzp_m=kn(6,i,1,k) + else if(j > 1) then + jxm_m=kn(1,i,j-1,k) ; jxp_m=kn(2,i,j-1,k) + jzm_m=kn(5,i,j-1,k) ; jzp_m=kn(6,i,j-1,k) + endif + if((j == ny).and.(iqfr(4,i,ny,k) == -2)) then + jxm_p=kn(1,i,ny,k) ; jxp_p=kn(2,i,ny,k) + jzm_p=kn(5,i,ny,k) ; jzp_p=kn(6,i,ny,k) + else if(j < ny) then + jxm_p=kn(1,i,j+1,k) ; jxp_p=kn(2,i,j+1,k) + jzm_p=kn(5,i,j+1,k) ; jzp_p=kn(6,i,j+1,k) + endif + ! y- relations + savg(3*ll4f+ind1,:ng)=real(matmul(Ly(:ng,:ng,i,j,k),savg(ind1,:ng)),4) + if(jym /= 0) savg(3*ll4f+ind1,:ng)=savg(3*ll4f+ind1,:ng)+ & + & real(matmul(Ly(:ng,ng+1:2*ng,i,j,k),savg(7*ll4f+ll4x+jym,:ng)),4) + ! + if(jzm_m /= 0) savg(3*ll4f+ind1,:ng)=savg(3*ll4f+ind1,:ng)+ & + & real(matmul(Ly(:ng,2*ng+1:3*ng,i,j,k),savg(7*ll4f+ll4x+ll4y+jzm_m,:ng)),4) + if(jzm /= 0) savg(3*ll4f+ind1,:ng)=savg(3*ll4f+ind1,:ng)+ & + & real(matmul(Ly(:ng,3*ng+1:4*ng,i,j,k),savg(7*ll4f+ll4x+ll4y+jzm,:ng)),4) + if(jzm_p /= 0) savg(3*ll4f+ind1,:ng)=savg(3*ll4f+ind1,:ng)+ & + & real(matmul(Ly(:ng,4*ng+1:5*ng,i,j,k),savg(7*ll4f+ll4x+ll4y+jzm_p,:ng)),4) + if(jzp_m /= 0) savg(3*ll4f+ind1,:ng)=savg(3*ll4f+ind1,:ng)+ & + & real(matmul(Ly(:ng,5*ng+1:6*ng,i,j,k),savg(7*ll4f+ll4x+ll4y+jzp_m,:ng)),4) + if(jzp /= 0) savg(3*ll4f+ind1,:ng)=savg(3*ll4f+ind1,:ng)+ & + & real(matmul(Ly(:ng,6*ng+1:7*ng,i,j,k),savg(7*ll4f+ll4x+ll4y+jzp,:ng)),4) + if(jzp_p /= 0) savg(3*ll4f+ind1,:ng)=savg(3*ll4f+ind1,:ng)+ & + & real(matmul(Ly(:ng,7*ng+1:8*ng,i,j,k),savg(7*ll4f+ll4x+ll4y+jzp_p,:ng)),4) + ! + if(jxm_m /= 0) savg(3*ll4f+ind1,:ng)=savg(3*ll4f+ind1,:ng)+ & + & real(matmul(Ly(:ng,8*ng+1:9*ng,i,j,k),savg(7*ll4f+jxm_m,:ng)),4) + if(jxm /= 0) savg(3*ll4f+ind1,:ng)=savg(3*ll4f+ind1,:ng)+ & + & real(matmul(Ly(:ng,9*ng+1:10*ng,i,j,k),savg(7*ll4f+jxm,:ng)),4) + if(jxm_p /= 0) savg(3*ll4f+ind1,:ng)=savg(3*ll4f+ind1,:ng)+ & + & real(matmul(Ly(:ng,10*ng+1:11*ng,i,j,k),savg(7*ll4f+jxm_p,:ng)),4) + if(jxp_m /= 0) savg(3*ll4f+ind1,:ng)=savg(3*ll4f+ind1,:ng)+ & + & real(matmul(Ly(:ng,11*ng+1:12*ng,i,j,k),savg(7*ll4f+jxp_m,:ng)),4) + if(jxp /= 0) savg(3*ll4f+ind1,:ng)=savg(3*ll4f+ind1,:ng)+ & + & real(matmul(Ly(:ng,12*ng+1:13*ng,i,j,k),savg(7*ll4f+jxp,:ng)),4) + if(jxp_p /= 0) savg(3*ll4f+ind1,:ng)=savg(3*ll4f+ind1,:ng)+ & + & real(matmul(Ly(:ng,13*ng+1:14*ng,i,j,k),savg(7*ll4f+jxp_p,:ng)),4) + ! + ! y+ relations + savg(4*ll4f+ind1,:ng)=real(matmul(Ry(:ng,:ng,i,j,k),savg(ind1,:ng)),4) + if(jyp /= 0) savg(4*ll4f+ind1,:ng)=savg(4*ll4f+ind1,:ng)+ & + & real(matmul(Ry(:ng,ng+1:2*ng,i,j,k),savg(7*ll4f+ll4x+jyp,:ng)),4) + ! + if(jzm_m /= 0) savg(4*ll4f+ind1,:ng)=savg(4*ll4f+ind1,:ng)+ & + & real(matmul(Ry(:ng,2*ng+1:3*ng,i,j,k),savg(7*ll4f+ll4x+ll4y+jzm_m,:ng)),4) + if(jzm /= 0) savg(4*ll4f+ind1,:ng)=savg(4*ll4f+ind1,:ng)+ & + & real(matmul(Ry(:ng,3*ng+1:4*ng,i,j,k),savg(7*ll4f+ll4x+ll4y+jzm,:ng)),4) + if(jzm_p /= 0) savg(4*ll4f+ind1,:ng)=savg(4*ll4f+ind1,:ng)+ & + & real(matmul(Ry(:ng,4*ng+1:5*ng,i,j,k),savg(7*ll4f+ll4x+ll4y+jzm_p,:ng)),4) + if(jzp_m /= 0) savg(4*ll4f+ind1,:ng)=savg(4*ll4f+ind1,:ng)+ & + & real(matmul(Ry(:ng,5*ng+1:6*ng,i,j,k),savg(7*ll4f+ll4x+ll4y+jzp_m,:ng)),4) + if(jzp /= 0) savg(4*ll4f+ind1,:ng)=savg(4*ll4f+ind1,:ng)+ & + & real(matmul(Ry(:ng,6*ng+1:7*ng,i,j,k),savg(7*ll4f+ll4x+ll4y+jzp,:ng)),4) + if(jzp_p /= 0) savg(4*ll4f+ind1,:ng)=savg(4*ll4f+ind1,:ng)+ & + & real(matmul(Ry(:ng,7*ng+1:8*ng,i,j,k),savg(7*ll4f+ll4x+ll4y+jzp_p,:ng)),4) + ! + if(jxm_m /= 0) savg(4*ll4f+ind1,:ng)=savg(4*ll4f+ind1,:ng)+ & + & real(matmul(Ry(:ng,8*ng+1:9*ng,i,j,k),savg(7*ll4f+jxm_m,:ng)),4) + if(jxm /= 0) savg(4*ll4f+ind1,:ng)=savg(4*ll4f+ind1,:ng)+ & + & real(matmul(Ry(:ng,9*ng+1:10*ng,i,j,k),savg(7*ll4f+jxm,:ng)),4) + if(jxm_p /= 0) savg(4*ll4f+ind1,:ng)=savg(4*ll4f+ind1,:ng)+ & + & real(matmul(Ry(:ng,10*ng+1:11*ng,i,j,k),savg(7*ll4f+jxm_p,:ng)),4) + if(jxp_m /= 0) savg(4*ll4f+ind1,:ng)=savg(4*ll4f+ind1,:ng)+ & + & real(matmul(Ry(:ng,11*ng+1:12*ng,i,j,k),savg(7*ll4f+jxp_m,:ng)),4) + if(jxp /= 0) savg(4*ll4f+ind1,:ng)=savg(4*ll4f+ind1,:ng)+ & + & real(matmul(Ry(:ng,12*ng+1:13*ng,i,j,k),savg(7*ll4f+jxp,:ng)),4) + if(jxp_p /= 0) savg(4*ll4f+ind1,:ng)=savg(4*ll4f+ind1,:ng)+ & + & real(matmul(Ry(:ng,13*ng+1:14*ng,i,j,k),savg(7*ll4f+jxp_p,:ng)),4) + ! + jxm_m=0 ; jxp_m=0 ; jxm_p=0 ; jxp_p=0 + jym_m=0 ; jyp_m=0 ; jym_p=0 ; jyp_p=0 + if((k == 1).and.(iqfr(5,i,j,1) == -2)) then + jxm_m=kn(1,i,j,1) ; jxp_m=kn(2,i,j,1) + jym_m=kn(3,i,j,1) ; jyp_m=kn(4,i,j,1) + else if(k > 1) then + jxm_m=kn(1,i,j,k-1) ; jxp_m=kn(2,i,j,k-1) + jym_m=kn(3,i,j,k-1) ; jyp_m=kn(4,i,j,k-1) + endif + if((k == nz).and.(iqfr(6,i,j,nz) == -2)) then + jxm_p=kn(1,i,j,nz) ; jxp_p=kn(2,i,j,nz) + jym_p=kn(3,i,j,nz) ; jyp_p=kn(4,i,j,nz) + else if(k < nz) then + jxm_p=kn(1,i,j,k+1) ; jxp_p=kn(2,i,j,k+1) + jym_p=kn(3,i,j,k+1) ; jyp_p=kn(4,i,j,k+1) + endif + ! z- relations + savg(5*ll4f+ind1,:ng)=real(matmul(Lz(:ng,:ng,i,j,k),savg(ind1,:ng)),4) + if(jzm /= 0) savg(5*ll4f+ind1,:ng)=savg(5*ll4f+ind1,:ng)+ & + & real(matmul(Lz(:ng,ng+1:2*ng,i,j,k),savg(7*ll4f+ll4x+ll4y+jzm,:ng)),4) + ! + if(jxm_m /= 0) savg(5*ll4f+ind1,:ng)=savg(5*ll4f+ind1,:ng)+ & + & real(matmul(Lz(:ng,2*ng+1:3*ng,i,j,k),savg(7*ll4f+jxm_m,:ng)),4) + if(jxm /= 0) savg(5*ll4f+ind1,:ng)=savg(5*ll4f+ind1,:ng)+ & + & real(matmul(Lz(:ng,3*ng+1:4*ng,i,j,k),savg(7*ll4f+jxm,:ng)),4) + if(jxm_p /= 0) savg(5*ll4f+ind1,:ng)=savg(5*ll4f+ind1,:ng)+ & + & real(matmul(Lz(:ng,4*ng+1:5*ng,i,j,k),savg(7*ll4f+jxm_p,:ng)),4) + if(jxp_m /= 0) savg(5*ll4f+ind1,:ng)=savg(5*ll4f+ind1,:ng)+ & + & real(matmul(Lz(:ng,5*ng+1:6*ng,i,j,k),savg(7*ll4f+jxp_m,:ng)),4) + if(jxp /= 0) savg(5*ll4f+ind1,:ng)=savg(5*ll4f+ind1,:ng)+ & + & real(matmul(Lz(:ng,6*ng+1:7*ng,i,j,k),savg(7*ll4f+jxp,:ng)),4) + if(jxp_p /= 0) savg(5*ll4f+ind1,:ng)=savg(5*ll4f+ind1,:ng)+ & + & real(matmul(Lz(:ng,7*ng+1:8*ng,i,j,k),savg(7*ll4f+jxp_p,:ng)),4) + ! + if(jym_m /= 0) savg(5*ll4f+ind1,:ng)=savg(5*ll4f+ind1,:ng)+ & + & real(matmul(Lz(:ng,8*ng+1:9*ng,i,j,k),savg(7*ll4f+ll4x+jym_m,:ng)),4) + if(jym /= 0) savg(5*ll4f+ind1,:ng)=savg(5*ll4f+ind1,:ng)+ & + & real(matmul(Lz(:ng,9*ng+1:10*ng,i,j,k),savg(7*ll4f+ll4x+jym,:ng)),4) + if(jym_p /= 0) savg(5*ll4f+ind1,:ng)=savg(5*ll4f+ind1,:ng)+ & + & real(matmul(Lz(:ng,10*ng+1:11*ng,i,j,k),savg(7*ll4f+ll4x+jym_p,:ng)),4) + if(jyp_m /= 0) savg(5*ll4f+ind1,:ng)=savg(5*ll4f+ind1,:ng)+ & + & real(matmul(Lz(:ng,11*ng+1:12*ng,i,j,k),savg(7*ll4f+ll4x+jyp_m,:ng)),4) + if(jyp /= 0) savg(5*ll4f+ind1,:ng)=savg(5*ll4f+ind1,:ng)+ & + & real(matmul(Lz(:ng,12*ng+1:13*ng,i,j,k),savg(7*ll4f+ll4x+jyp,:ng)),4) + if(jyp_p /= 0) savg(5*ll4f+ind1,:ng)=savg(5*ll4f+ind1,:ng)+ & + & real(matmul(Lz(:ng,13*ng+1:14*ng,i,j,k),savg(7*ll4f+ll4x+jyp_p,:ng)),4) + ! + ! z+ relations + savg(6*ll4f+ind1,:ng)=real(matmul(Rz(:ng,:ng,i,j,k),savg(ind1,:ng)),4) + if(jzp /= 0) savg(6*ll4f+ind1,:ng)=savg(6*ll4f+ind1,:ng)+ & + & real(matmul(Rz(:ng,ng+1:2*ng,i,j,k),savg(7*ll4f+ll4x+ll4y+jzp,:ng)),4) + ! + if(jxm_m /= 0) savg(6*ll4f+ind1,:ng)=savg(6*ll4f+ind1,:ng)+ & + & real(matmul(Rz(:ng,2*ng+1:3*ng,i,j,k),savg(7*ll4f+jxm_m,:ng)),4) + if(jxm /= 0) savg(6*ll4f+ind1,:ng)=savg(6*ll4f+ind1,:ng)+ & + & real(matmul(Rz(:ng,3*ng+1:4*ng,i,j,k),savg(7*ll4f+jxm,:ng)),4) + if(jxm_p /= 0) savg(6*ll4f+ind1,:ng)=savg(6*ll4f+ind1,:ng)+ & + & real(matmul(Rz(:ng,4*ng+1:5*ng,i,j,k),savg(7*ll4f+jxm_p,:ng)),4) + if(jxp_m /= 0) savg(6*ll4f+ind1,:ng)=savg(6*ll4f+ind1,:ng)+ & + & real(matmul(Rz(:ng,5*ng+1:6*ng,i,j,k),savg(7*ll4f+jxp_m,:ng)),4) + if(jxp /= 0) savg(6*ll4f+ind1,:ng)=savg(6*ll4f+ind1,:ng)+ & + & real(matmul(Rz(:ng,6*ng+1:7*ng,i,j,k),savg(7*ll4f+jxp,:ng)),4) + if(jxp_p /= 0) savg(6*ll4f+ind1,:ng)=savg(6*ll4f+ind1,:ng)+ & + & real(matmul(Rz(:ng,7*ng+1:8*ng,i,j,k),savg(7*ll4f+jxp_p,:ng)),4) + ! + if(jym_m /= 0) savg(6*ll4f+ind1,:ng)=savg(6*ll4f+ind1,:ng)+ & + & real(matmul(Rz(:ng,8*ng+1:9*ng,i,j,k),savg(7*ll4f+ll4x+jym_m,:ng)),4) + if(jym /= 0) savg(6*ll4f+ind1,:ng)=savg(6*ll4f+ind1,:ng)+ & + & real(matmul(Rz(:ng,9*ng+1:10*ng,i,j,k),savg(7*ll4f+ll4x+jym,:ng)),4) + if(jym_p /= 0) savg(6*ll4f+ind1,:ng)=savg(6*ll4f+ind1,:ng)+ & + & real(matmul(Rz(:ng,10*ng+1:11*ng,i,j,k),savg(7*ll4f+ll4x+jym_p,:ng)),4) + if(jyp_m /= 0) savg(6*ll4f+ind1,:ng)=savg(6*ll4f+ind1,:ng)+ & + & real(matmul(Rz(:ng,11*ng+1:12*ng,i,j,k),savg(7*ll4f+ll4x+jyp_m,:ng)),4) + if(jyp /= 0) savg(6*ll4f+ind1,:ng)=savg(6*ll4f+ind1,:ng)+ & + & real(matmul(Rz(:ng,12*ng+1:13*ng,i,j,k),savg(7*ll4f+ll4x+jyp,:ng)),4) + if(jyp_p /= 0) savg(6*ll4f+ind1,:ng)=savg(6*ll4f+ind1,:ng)+ & + & real(matmul(Rz(:ng,13*ng+1:14*ng,i,j,k),savg(7*ll4f+ll4x+jyp_p,:ng)),4) + enddo + enddo + enddo + !---- + ! scratch storage deallocation + !---- + deallocate(Rz,Lz,Ry,Ly,Rx,Lx) + deallocate(work5,work4,work3,work2,work1) + deallocate(LLR,Lambda,A) +end subroutine NSSANM3 diff --git a/Trivac/src/NSSCO.f b/Trivac/src/NSSCO.f new file mode 100755 index 0000000..de8ff40 --- /dev/null +++ b/Trivac/src/NSSCO.f @@ -0,0 +1,149 @@ +*DECK NSSCO + SUBROUTINE NSSCO(NX,NY,NZ,NMIX,I,J,K,MAT,XX,YY,ZZ,DIFF,IQFR,QFR, + 1 COEF) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the mesh centered finite difference coefficients. +* +*Copyright: +* Copyright (C) 2023 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NX number of X-directed nodes. +* NY number of Y-directed nodes. +* NZ number of Z-directed nodes. +* NMIX number of material mixtures. +* I X-index of node under consideration. +* J Y-index of node under consideration. +* K Z-index of node under consideration. +* MAT mixture index assigned to each node. +* DIF diffusion coefficients. +* XX X-directed mesh spacings. +* YY Y-directed mesh spacings. +* ZZ Z-directed mesh spacings. +* IQFR node-ordered unknown list: +* =0: neighbour exists; +* =-1: void/albedo boundary condition; +* =-2: reflection boundary condition; +* =-3: ZERO flux boundary condition; +* =-4: SYME boundary condition (axial symmetry). +* QFR element-ordered boundary conditions. +* +*Parameters: output +* COEF mesh centered finite difference coefficients. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NX,NY,NZ,I,J,K,MAT(NX,NY,NZ),IQFR(6) + REAL DIFF(NMIX),XX(NX,NY,NZ),YY(NX,NY,NZ),ZZ(NX,NY,NZ),QFR(6), + 1 COEF(6) +*---- +* LOCAL VARIABLES +*---- + DHARM(X1,X2,DIF1,DIF2)=2.0*DIF1*DIF2/(X1*DIF2+X2*DIF1) +* + IBM=MAT(I,J,K) + DX=XX(I,J,K) + DY=YY(I,J,K) + DZ=ZZ(I,J,K) + KK1=IQFR(1) + KK2=IQFR(2) + KK3=IQFR(3) + KK4=IQFR(4) + KK5=IQFR(5) + KK6=IQFR(6) + COEF(:6)=0. + ! x- side: + IF(KK1 == 0) THEN + COEF(1)=DHARM(DX,XX(I-1,J,K),DIFF(IBM),DIFF(MAT(I-1,J,K))) + ELSE IF((KK1 > 0).OR.(KK1 == -1)) THEN + COEF(1)=DHARM(DX,DX,DIFF(IBM),DX*QFR(1)/2.0) + ELSE IF(KK1 == -2) THEN + COEF(1)=0.0 + ELSE IF(KK1 == -3) THEN + COEF(1)=2.0*DHARM(DX,DX,DIFF(IBM),DIFF(IBM)) + ENDIF + ! x+ side: + IF(KK2 == 0) THEN + COEF(2)=DHARM(DX,XX(I+1,J,K),DIFF(IBM),DIFF(MAT(I+1,J,K))) + ELSE IF((KK2 > 0).OR.(KK2 == -1)) THEN + COEF(2)=DHARM(DX,DX,DIFF(IBM),DX*QFR(2)/2.0) + ELSE IF(KK2 == -2) THEN + COEF(2)=0.0 + ELSE IF(KK2 == -3) THEN + COEF(2)=2.0*DHARM(DX,DX,DIFF(IBM),DIFF(IBM)) + ELSE IF(KK2 == -4) THEN + IF(KK1 == -4) CALL XABORT('NSSCO: INCONSISTENT SYME (1).') + COEF(2)=COEF(1) + ENDIF + IF(KK1 == -4) THEN + IF(KK2 == -4) CALL XABORT('NSSCO: INCONSISTENT SYME (2).') + COEF(1)=COEF(2) + ENDIF + ! y- side: + IF(KK3 == 0) THEN + COEF(3)=DHARM(DY,YY(I,J-1,K),DIFF(IBM),DIFF(MAT(I,J-1,K))) + ELSE IF((KK3 > 0).OR.(KK3 == -1)) THEN + COEF(3)=DHARM(DY,DY,DIFF(IBM),DY*QFR(3)/2.0) + ELSE IF(KK3 == -2) THEN + COEF(3)=0.0 + ELSE IF(KK3 == -3) THEN + COEF(3)=2.0*DHARM(DY,DY,DIFF(IBM),DIFF(IBM)) + ENDIF + ! y+ side: + IF(KK4 == 0) THEN + COEF(4)=DHARM(DY,YY(I,J+1,K),DIFF(IBM),DIFF(MAT(I,J+1,K))) + ELSE IF((KK4 > 0).OR.(KK4 == -1)) THEN + COEF(4)=DHARM(DY,DY,DIFF(IBM),DY*QFR(4)/2.0) + ELSE IF(KK4 == -2) THEN + COEF(4)=0.0 + ELSE IF(KK4 == -3) THEN + COEF(4)=2.0*DHARM(DY,DY,DIFF(IBM),DIFF(IBM)) + ELSE IF(KK4 == -4) THEN + IF(KK3 == -4) CALL XABORT('NSSCO: INCONSISTENT SYME (3).') + COEF(4)=COEF(3) + ENDIF + IF(KK3 == -4) THEN + IF(KK4 == -4) CALL XABORT('NSSCO: INCONSISTENT SYME (4).') + COEF(3)=COEF(4) + ENDIF + ! z- side: + IF(KK5 == 0) THEN + COEF(5)=DHARM(DZ,ZZ(I,J,K-1),DIFF(IBM),DIFF(MAT(I,J,K-1))) + ELSE IF((KK5 > 0).OR.(KK5 == -1)) THEN + COEF(5)=DHARM(DZ,DZ,DIFF(IBM),DZ*QFR(5)/2.0) + ELSE IF(KK5 == -2) THEN + COEF(5)=0.0 + ELSE IF(KK5 == -3) THEN + COEF(5)=2.0*DHARM(DZ,DZ,DIFF(IBM),DIFF(IBM)) + ENDIF + ! z+ side: + IF(KK6 == 0) THEN + COEF(6)=DHARM(DZ,ZZ(I,J,K+1),DIFF(IBM),DIFF(MAT(I,J,K+1))) + ELSE IF((KK6 > 0).OR.(KK6 == -1)) THEN + COEF(6)=DHARM(DZ,DZ,DIFF(IBM),DZ*QFR(6)/2.0) + ELSE IF(KK6 == -2) THEN + COEF(6)=0.0 + ELSE IF(KK6 == -3) THEN + COEF(6)=2.0*DHARM(DZ,DZ,DIFF(IBM),DIFF(IBM)) + ELSE IF(KK6 == -4) THEN + IF(KK5 == -4) CALL XABORT('NSSCO: INCONSISTENT SYME (5).') + COEF(6)=COEF(5) + ENDIF + IF(KK5 == -4) THEN + IF(KK6 == -4) CALL XABORT('NSSCO: INCONSISTENT SYME (6).') + COEF(5)=COEF(6) + ENDIF + RETURN + END diff --git a/Trivac/src/NSSDFC.f b/Trivac/src/NSSDFC.f new file mode 100755 index 0000000..1c910be --- /dev/null +++ b/Trivac/src/NSSDFC.f @@ -0,0 +1,485 @@ +*DECK NSSDFC + SUBROUTINE NSSDFC(IMPX,IDIM,NX,NY,NZ,NCODE,ICODE,ZCODE,MAT,XXX, + 1 YYY,ZZZ,LL4F,LL4X,LL4Y,LL4Z,VOL,XX,YY,ZZ,IDL,KN,QFR,IQFR,MUX, + 2 MUY,MUZ,IMAX,IMAY,IMAZ,IPY,IPZ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Numbering corresponding to a coarse mesh finite difference (NEM +* type) in a 3-D geometry. +* +*Copyright: +* Copyright (C) 2022 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IMPX print parameter. +* IDIM number of Cartesian dimensions. +* NX number of elements along the X axis. +* NY number of elements along the Y axis. +* NZ number of elements along the Z axis. +* NCODE type of boundary condition applied on each side: +* I=1: X-; I=2: X+; I=3: Y-; I=4: Y+; I=5: Z-; I=6: Z+; +* NCODE(I)=1: VOID; NCODE(I)=2: REFL; NCODE(I)=4: TRAN; +* NCODE(I)=7: ZERO. +* ICODE physical albedo index on each side of the domain. +* ZCODE albedo corresponding to boundary condition 'VOID' on each +* side (ZCODE(i)=0.0 by default). +* MAT mixture index assigned to each element. +* XXX Cartesian coordinates along the X axis. +* YYY Cartesian coordinates along the Y axis. +* ZZZ Cartesian coordinates along the Z axis. +* LL4F total number of averaged flux unknown per energy group. +* +*Parameters: output +* LL4X total number of X-direccted interface net currents. +* LL4Y total number of Y-direccted interface net currents. +* LL4Z total number of Z-direccted interface net currents. +* VOL volume of each element. +* XX X-directed mesh spacings. +* YY Y-directed mesh spacings. +* ZZ Z-directed mesh spacings. +* IDL position of averaged fluxes in unknown vector. +* KN element-ordered interface net current unknown list. +* QFR element-ordered boundary conditions. +* IQFR element-ordered physical albedo indices. +* MUX X-oriented compressed storage mode indices. +* MUY Y-oriented compressed storage mode indices. +* MUZ Z-oriented compressed storage mode indices. +* IMAX X-oriented position of each first non-zero column element. +* IMAY Y-oriented position of each first non-zero column element. +* IMAZ Z-oriented position of each first non-zero column element. +* IPY Y-oriented permutation matrices. +* IPZ Z-oriented permutation matrices. +* +*----------------------------------------------------------------------- +* + INTEGER IMPX,IDIM,NX,NY,NZ,NCODE(6),ICODE(6),MAT(NX,NY,NZ),LL4F, + 1 LL4X,LL4Y,LL4Z,IDL(NX,NY,NZ),KN(6,NX,NY,NZ),IQFR(6,NX,NY,NZ), + 2 MUX(LL4F),MUY(LL4F),MUZ(LL4F),IMAX(LL4F),IMAY(LL4F),IMAZ(LL4F), + 3 IPY(LL4F),IPZ(LL4F) + REAL ZCODE(6),XXX(NX+1),YYY(NY+1),ZZZ(NZ+1),VOL(NX,NY,NZ), + 1 XX(NX,NY,NZ),YY(NX,NY,NZ),ZZ(NX,NY,NZ),QFR(6,NX,NY,NZ) +*---- +* LOCAL VARIABLES +*---- + LOGICAL LL1,LALB + INTEGER, ALLOCATABLE, DIMENSION(:) :: JPX,JPY,JPZ +* + ALB(X)=0.5*(1.0-X)/(1.0+X) +*---- +* IDENTIFICATION OF THE NON VIRTUAL NODES +*---- + IF(IMPX.GT.0) WRITE(6,700) NX,NY,NZ + ALLOCATE(JPX((NX+1)*NY*NZ),JPY((NY+1)*NX*NZ),JPZ((NZ+1)*NX*NY)) + JPX(:)=0 + JPY(:)=0 + JPZ(:)=0 + IND=0 + DO K0=1,NZ + DO K1=1,NY + DO K2=1,NX + IDL(K2,K1,K0)=0 + KN(:6,K2,K1,K0)=0 + IF(MAT(K2,K1,K0).EQ.0) CYCLE + IND=IND+1 + IDL(K2,K1,K0)=IND + KN(1,K2,K1,K0)=K2 +(NX+1)*(K1-1)+(NX+1)*NY*(K0-1) + KN(2,K2,K1,K0)=(K2+1)+(NX+1)*(K1-1)+(NX+1)*NY*(K0-1) + KN(3,K2,K1,K0)=K1 +(NY+1)*(K0-1)+(NY+1)*NZ*(K2-1) + KN(4,K2,K1,K0)=(K1+1)+(NY+1)*(K0-1)+(NY+1)*NZ*(K2-1) + KN(5,K2,K1,K0)=K0 +(NZ+1)*(K2-1)+(NZ+1)*NX*(K1-1) + KN(6,K2,K1,K0)=(K0+1)+(NZ+1)*(K2-1)+(NZ+1)*NX*(K1-1) + JPX(KN(1:2,K2,K1,K0))=1 + JPY(KN(3:4,K2,K1,K0))=1 + JPZ(KN(5:6,K2,K1,K0))=1 + ENDDO + ENDDO + ENDDO + IF(IND.NE.LL4F) CALL XABORT('NSSDFC: WRONG VALUE OF LL4F.') + LL4X=0 + DO I=1,(NX+1)*NY*NZ + IF(JPX(I).EQ.1) THEN + LL4X=LL4X+1 + JPX(I)=LL4X + ENDIF + ENDDO + LL4Y=0 + DO I=1,(NY+1)*NX*NZ + IF(JPY(I).EQ.1) THEN + LL4Y=LL4Y+1 + JPY(I)=LL4Y + ENDIF + ENDDO + LL4Z=0 + DO I=1,(NZ+1)*NX*NY + IF(JPZ(I).EQ.1) THEN + LL4Z=LL4Z+1 + JPZ(I)=LL4Z + ENDIF + ENDDO + DO K0=1,NZ + DO K1=1,NY + DO K2=1,NX + IF(MAT(K2,K1,K0).EQ.0) CYCLE + KN(1:2,K2,K1,K0)=JPX(KN(1:2,K2,K1,K0)) + KN(3:4,K2,K1,K0)=JPY(KN(3:4,K2,K1,K0)) + KN(5:6,K2,K1,K0)=JPZ(KN(5:6,K2,K1,K0)) + ENDDO + ENDDO + ENDDO + DEALLOCATE(JPZ,JPY,JPX) +*---- +* IDENTIFICATION OF THE GEOMETRY. MAIN LOOP OVER THE NODES +*---- + QFR(:6,:NX,:NY,:NZ)=0.0 + IQFR(:6,:NX,:NY,:NZ)=-99 + DO K0=1,NZ + DO K1=1,NY + DO K2=1,NX + XX(K2,K1,K0)=0.0 + YY(K2,K1,K0)=0.0 + ZZ(K2,K1,K0)=0.0 + VOL(K2,K1,K0)=0.0 + IF(MAT(K2,K1,K0).LE.0) CYCLE + XX(K2,K1,K0)=XXX(K2+1)-XXX(K2) + YY(K2,K1,K0)=YYY(K1+1)-YYY(K1) + ZZ(K2,K1,K0)=ZZZ(K0+1)-ZZZ(K0) +*---- +* VOID, REFL OR ZERO BOUNDARY CONTITION +*---- + IQFR(:2,K2,K1,K0)=0 + IF(K2.EQ.1) THEN + LL1=.TRUE. + ELSE + LL1=(MAT(K2-1,K1,K0).EQ.0) + ENDIF + IF(LL1) THEN + LALB=(NCODE(1).EQ.1).OR.(NCODE(1).EQ.6) + IF(LALB.AND.(ICODE(1).EQ.0)) THEN + QFR(1,K2,K1,K0)=ALB(ZCODE(1)) + IQFR(1,K2,K1,K0)=-1 + ELSE IF(LALB) THEN + QFR(1,K2,K1,K0)=1.0 + IQFR(1,K2,K1,K0)=ICODE(1) + ELSE IF(NCODE(1).EQ.2) THEN + IQFR(1,K2,K1,K0)=-2 + ELSE IF(NCODE(1).EQ.7) THEN + IQFR(1,K2,K1,K0)=-3 + ELSE IF(NCODE(1).EQ.5) THEN + CALL XABORT('NSSDFC: SYME NOT IMPLEMENTED(1).') + ENDIF + ENDIF +* + IF(K2.EQ.NX) THEN + LL1=.TRUE. + ELSE + LL1=(MAT(K2+1,K1,K0).EQ.0) + ENDIF + IF(LL1) THEN + LALB=(NCODE(2).EQ.1).OR.(NCODE(2).EQ.6) + IF(LALB.AND.(ICODE(2).EQ.0)) THEN + QFR(2,K2,K1,K0)=ALB(ZCODE(2)) + IQFR(2,K2,K1,K0)=-1 + ELSE IF(LALB) THEN + QFR(2,K2,K1,K0)=1.0 + IQFR(2,K2,K1,K0)=ICODE(2) + ELSE IF(NCODE(2).EQ.2) THEN + IQFR(2,K2,K1,K0)=-2 + ELSE IF(NCODE(2).EQ.7) THEN + IQFR(2,K2,K1,K0)=-3 + ELSE IF(NCODE(1).EQ.5) THEN + CALL XABORT('NSSDFC: SYME NOT IMPLEMENTED(2).') + ENDIF + ENDIF +* + IF(IDIM == 1) GO TO 100 + IQFR(3:4,K2,K1,K0)=0 + IF(K1.EQ.1) THEN + LL1=.TRUE. + ELSE + LL1=(MAT(K2,K1-1,K0).EQ.0) + ENDIF + IF(LL1) THEN + LALB=(NCODE(3).EQ.1).OR.(NCODE(3).EQ.6) + IF(LALB.AND.(ICODE(3).EQ.0)) THEN + QFR(3,K2,K1,K0)=ALB(ZCODE(3)) + IQFR(3,K2,K1,K0)=-1 + ELSE IF(LALB) THEN + QFR(3,K2,K1,K0)=1.0 + IQFR(3,K2,K1,K0)=ICODE(3) + ELSE IF(NCODE(3).EQ.2) THEN + IQFR(3,K2,K1,K0)=-2 + ELSE IF(NCODE(3).EQ.7) THEN + IQFR(3,K2,K1,K0)=-3 + ELSE IF(NCODE(1).EQ.5) THEN + CALL XABORT('NSSDFC: SYME NOT IMPLEMENTED(3).') + ENDIF + ENDIF +* + IF(K1.EQ.NY) THEN + LL1=.TRUE. + ELSE + LL1=(MAT(K2,K1+1,K0).EQ.0) + ENDIF + IF(LL1) THEN + LALB=(NCODE(4).EQ.1).OR.(NCODE(4).EQ.6) + IF(LALB.AND.(ICODE(4).EQ.0)) THEN + QFR(4,K2,K1,K0)=ALB(ZCODE(4)) + IQFR(4,K2,K1,K0)=-1 + ELSE IF(LALB) THEN + QFR(4,K2,K1,K0)=1.0 + IQFR(4,K2,K1,K0)=ICODE(4) + ELSE IF(NCODE(4).EQ.2) THEN + IQFR(4,K2,K1,K0)=-2 + ELSE IF(NCODE(4).EQ.7) THEN + IQFR(4,K2,K1,K0)=-3 + ELSE IF(NCODE(1).EQ.5) THEN + CALL XABORT('NSSDFC: SYME NOT IMPLEMENTED(4).') + ENDIF + ENDIF +* + IF(IDIM == 2) GO TO 100 + IQFR(5:6,K2,K1,K0)=0 + IF(K0.EQ.1) THEN + LL1=.TRUE. + ELSE + LL1=(MAT(K2,K1,K0-1).EQ.0) + ENDIF + IF(LL1) THEN + LALB=(NCODE(5).EQ.1).OR.(NCODE(5).EQ.6) + IF(LALB.AND.(ICODE(5).EQ.0)) THEN + QFR(5,K2,K1,K0)=ALB(ZCODE(5)) + IQFR(5,K2,K1,K0)=-1 + ELSE IF(LALB) THEN + QFR(5,K2,K1,K0)=1.0 + IQFR(5,K2,K1,K0)=ICODE(5) + ELSE IF(NCODE(5).EQ.2) THEN + IQFR(5,K2,K1,K0)=-2 + ELSE IF(NCODE(5).EQ.7) THEN + IQFR(5,K2,K1,K0)=-3 + ELSE IF(NCODE(1).EQ.5) THEN + CALL XABORT('NSSDFC: SYME NOT IMPLEMENTED(5).') + ENDIF + ENDIF +* + IF(K0.EQ.NZ) THEN + LL1=.TRUE. + ELSE + LL1=(MAT(K2,K1,K0+1).EQ.0) + ENDIF + IF(LL1) THEN + LALB=(NCODE(6).EQ.1).OR.(NCODE(6).EQ.6) + IF(LALB.AND.(ICODE(6).EQ.0)) THEN + QFR(6,K2,K1,K0)=ALB(ZCODE(6)) + IQFR(6,K2,K1,K0)=-1 + ELSE IF(LALB) THEN + QFR(6,K2,K1,K0)=1.0 + IQFR(6,K2,K1,K0)=ICODE(6) + ELSE IF(NCODE(6).EQ.2) THEN + IQFR(6,K2,K1,K0)=-2 + ELSE IF(NCODE(6).EQ.7) THEN + IQFR(6,K2,K1,K0)=-3 + ELSE IF(NCODE(1).EQ.5) THEN + CALL XABORT('NSSDFC: SYME NOT IMPLEMENTED(6).') + ENDIF + ENDIF +*---- +* TRAN BOUNDARY CONDITION +*---- + 100 IF((K2.EQ.1).AND.(NCODE(1).EQ.4)) THEN + KN(1,K2,K1,K0)=KN(2,NX,K1,K0) + ENDIF + IF((K2.EQ.NX).AND.(NCODE(2).EQ.4)) THEN + KN(2,K2,K1,K0)=KN(1,1,K1,K0) + ENDIF + IF((K1.EQ.1).AND.(NCODE(3).EQ.4)) THEN + KN(3,K2,K1,K0)=KN(2,K2,NY,K0) + ENDIF + IF((K1.EQ.NY).AND.(NCODE(4).EQ.4)) THEN + KN(4,K2,K1,K0)=KN(1,K2,1,K0) + ENDIF + IF((K0.EQ.1).AND.(NCODE(5).EQ.4)) THEN + KN(5,K2,K1,K0)=KN(6,K2,K1,NZ) + ENDIF + IF((K0.EQ.NZ).AND.(NCODE(6).EQ.4)) THEN + KN(6,K2,K1,K0)=KN(5,K2,K1,1) + ENDIF +* + VOL(K2,K1,K0)=XX(K2,K1,K0)*YY(K2,K1,K0)*ZZ(K2,K1,K0) + ENDDO + ENDDO + ENDDO +* END OF THE MAIN LOOP OVER NODES. +* + IF(IMPX.GE.2) THEN + WRITE(6,720) VOL(:NX,:NY,:NZ) + WRITE(6,750) + DO K0=1,NZ + DO K1=1,NY + DO K2=1,NX + IF(MAT(K2,K1,K0).LE.0) CYCLE + KEL=(K0-1)*NX*NY+(K1-1)*NX+K2 + WRITE (6,760) KEL,(KN(I,K2,K1,K0),I=1,6), + 1 (QFR(I,K2,K1,K0),I=1,6),(IQFR(I,K2,K1,K0),I=1,6) + ENDDO + ENDDO + ENDDO + ENDIF +*---- +* COMPUTE THE PERMUTATION VECTORS IPY AND IPZ +*---- + IF(IDIM.GE.2) THEN + INX1=0 + DO K2=1,NX + DO K0=1,NZ + DO K1=1,NY + INX2=IDL(K2,K1,K0) + IF(INX2.LE.0) CYCLE + INX1=INX1+1 + IPY(INX2)=INX1 + ENDDO + ENDDO + ENDDO + IF(INX1.NE.IND) CALL XABORT('NSSDFC: FAILURE OF THE RENUMBERI' + 1 //'NG ALGORITHM(1)') + IF(IDIM.EQ.3) THEN + INX1=0 + DO K1=1,NY + DO K2=1,NX + DO K0=1,NZ + INX2=IDL(K2,K1,K0) + IF(INX2.LE.0) CYCLE + INX1=INX1+1 + IPZ(INX2)=INX1 + ENDDO + ENDDO + ENDDO + IF(INX1.NE.IND) CALL XABORT('NSSDFC: FAILURE OF THE RENUMB' + 1 //'ERING ALGORITHM(2)') + ENDIF + ENDIF +*---- +* COMPUTE VECTOR MUX +*---- + MUX(:LL4F)=1 + DO K0=1,NZ + DO K1=1,NY +* X- SIDE: + DO K2=2,NX + KEL=IDL(K2,K1,K0) + IF(KEL.EQ.0) CYCLE + KK1=IDL(K2-1,K1,K0) + IF(KK1.GT.0) MUX(KEL)=MAX0(MUX(KEL),KEL-KK1+1) + ENDDO +* X+ SIDE: + DO K2=1,NX-1 + KEL=IDL(K2,K1,K0) + IF(KEL.EQ.0) CYCLE + KK2=IDL(K2+1,K1,K0) + IF(KK2.GT.0) MUX(KEL)=MAX0(MUX(KEL),KEL-KK2+1) + ENDDO + ENDDO + ENDDO +*---- +* COMPUTE VECTOR MUY +*---- + IF(IDIM.GE.2) THEN + MUY(:LL4F)=1 + DO K2=1,NX + DO K0=1,NZ +* Y- SIDE: + DO K1=2,NY + KEL=IDL(K2,K1,K0) + IF(KEL.EQ.0) CYCLE + INY1=IPY(KEL) + KK3=IDL(K2,K1-1,K0) + IF(KK3.GT.0) MUY(INY1)=MAX0(MUY(INY1),INY1-IPY(KK3)+1) + ENDDO +* Y- SIDE: + DO K1=1,NY-1 + KEL=IDL(K2,K1,K0) + IF(KEL.EQ.0) CYCLE + INY1=IPY(KEL) + KK4=IDL(K2,K1+1,K0) + IF(KK4.GT.0) MUY(INY1)=MAX0(MUY(INY1),INY1-IPY(KK4)+1) + ENDDO + ENDDO + ENDDO + ELSE + MUY(:LL4F)=0 + ENDIF +*---- +* COMPUTE VECTOR MUZ +*---- + IF(IDIM.EQ.3) THEN + MUZ(:LL4F)=1 + DO K1=1,NY + DO K2=1,NX +* Z- SIDE: + DO K0=2,NZ + KEL=IDL(K2,K1,K0) + IF(KEL.EQ.0) CYCLE + INZ1=IPZ(KEL) + KK5=IDL(K2,K1,K0-1) + IF(KK5.GT.0) MUZ(INZ1)=MAX0(MUZ(INZ1),INZ1-IPZ(KK5)+1) + ENDDO +* Z+ SIDE: + DO K0=1,NZ-1 + KEL=IDL(K2,K1,K0) + IF(KEL.EQ.0) CYCLE + INZ1=IPZ(KEL) + KK6=IDL(K2,K1,K0+1) + IF(KK6.GT.0) MUZ(INZ1)=MAX0(MUZ(INZ1),INZ1-IPZ(KK6)+1) + ENDDO + ENDDO + ENDDO + ELSE + MUZ(:LL4F)=0 + ENDIF +* + MUXMAX=0 + MUYMAX=0 + MUZMAX=0 + IIMAXX=0 + IIMAXY=0 + IIMAXZ=0 + DO I=1,LL4F + MUXMAX=MAX(MUXMAX,MUX(I)) + MUYMAX=MAX(MUYMAX,MUY(I)) + MUZMAX=MAX(MUZMAX,MUZ(I)) + IBAND=MUX(I) + IIMAXX=IIMAXX+IBAND + MUX(I)=IIMAXX + IIMAXX=IIMAXX+IBAND-1 + IMAX(I)=IIMAXX + IBAND=MUY(I) + IIMAXY=IIMAXY+IBAND + MUY(I)=IIMAXY + IIMAXY=IIMAXY+IBAND-1 + IMAY(I)=IIMAXY + IBAND=MUZ(I) + IIMAXZ=IIMAXZ+IBAND + MUZ(I)=IIMAXZ + IIMAXZ=IIMAXZ+IBAND-1 + IMAZ(I)=IIMAXZ + ENDDO + IF(IMPX.GT.0) WRITE (6,770) MUXMAX,MUYMAX,MUZMAX + RETURN +* + 700 FORMAT(/46H NSSDFC: COARSE MESH FINITE DIFFERENCE METHOD.//3H NU, + 1 28HMBER OF NODES ALONG X AXIS =,I3/17X,14HALONG Y AXIS =,I3/ + 2 17X,14HALONG Z AXIS =,I3) + 720 FORMAT(/17H VOLUMES PER NODE/(1X,1P,10E13.4)) + 750 FORMAT(/22H NUMBERING OF UNKNOWNS/1X,21(1H-)//4X,4HNODE,5X,3HINT, + 1 26HERFACE NET CURRENT INDICES,28X,23HVOID BOUNDARY CONDITION) + 760 FORMAT(1X,I6,7X,6I8,6X,6F9.2/68X,6I9) + 770 FORMAT(/41H NSSDFC: MAXIMUM BANDWIDTH ALONG X AXIS =,I5/ + 1 27X,14HALONG Y AXIS =,I5/27X,14HALONG Z AXIS =,I5) + END diff --git a/Trivac/src/NSSDRV.f b/Trivac/src/NSSDRV.f new file mode 100755 index 0000000..4504051 --- /dev/null +++ b/Trivac/src/NSSDRV.f @@ -0,0 +1,343 @@ +*DECK NSSDRV + SUBROUTINE NSSDRV(IPTRK,IPMAC,IPFLX,ICHX,IDIM,NUN,NG,NEL,NMIX, + 1 ITRIAL,ICL1,ICL2,NADI,EPSNOD,MAXNOD,EPSTHR,MAXTHR,EPSOUT,MAXOUT, + 2 LNODF,BNDTL,NPASS,BB2,IPRINT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Driver for the flux calculation with the nodal expansion method. +* +*Copyright: +* Copyright (C) 2021 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK nodal tracking. +* IPMAC nodal macrolib. +* IPFLX nodal flux. +* ICHX solution flag (=4.:CMFD; =5: NEM; =6: ANM). +* IDIM number of dimensions (1, 2 or 3). +* NUN number of unknowns per energy group. +* NG number of energy groups. +* NEL number of nodes in the nodal calculation. +* NMIX number of mixtures in the nodal calculation. +* ITRIAL type of expansion functions in the nodal calculation +* (=1: polynomial; =2: hyperbolic). +* ICL1 number of free iterations in one cycle of the inverse power +* method (used for thermal iterations). +* ICL2 number of accelerated iterations in one cycle. +* NADI number of inner ADI iterations. +* EPSNOD nodal correction epsilon. +* MAXNOD maximum number of nodal correction iterations. +* EPSTHR thermal iteration epsilon. +* MAXTHR maximum number of thermal iterations. +* EPSOUT convergence epsilon for the power method. +* MAXOUT maximum number of iterations for the power method. +* LNODF flag set to .true. to force discontinuity factors to one. +* BNDTL set to 'flat', 'linear' or 'quadratic' in 2D cases. +* BB2 imposed leakage used in non-regression tests. +* NPASS number of transverse current iterations. +* IPRINT edition flag. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPMAC,IPFLX + INTEGER ICHX,IDIM,NUN,NG,NEL,NMIX,ITRIAL(NMIX,NG),ICL1,ICL2, + > MAXNOD,NADI,MAXTHR,MAXOUT,NPASS,IPRINT + REAL EPSNOD,EPSTHR,EPSOUT,BB2 + LOGICAL LNODF + CHARACTER*12 BNDTL +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + INTEGER ISTATE(NSTATE),ICODE(6) + TYPE(C_PTR) JPMAC,KPMAC + CHARACTER HSMG*131 + CHARACTER(LEN=8) HADF(6) + CHARACTER(LEN=72) TITLE +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MAT,IJJ,NJJ,IPOS,IDL,MUX, + 1 MUY,MUZ,IMAX,IMAY,IMAZ,IPY,IPZ + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: KN,IQFR + REAL, ALLOCATABLE, DIMENSION(:) :: XX,YY,ZZ,XXX,YYY,ZZZ,WORK,VOL + REAL, ALLOCATABLE, DIMENSION(:,:) :: DIFF,SIGR,CHI,SIGF,QFR,ALBP, + 1 GAR2,GAR3 + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: BETA,SCAT,FDXM,FDXP,GAR4 + REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: FD +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(MAT(NEL),IDL(NEL),KN(6,NEL),IQFR(6,NEL)) + ALLOCATE(XX(NEL),YY(NEL),ZZ(NEL),VOL(NEL),DIFF(NMIX,NG), + 1 SIGR(NMIX,NG),CHI(NMIX,NG),SIGF(NMIX,NG),SCAT(NMIX,NG,NG), + 2 QFR(6,NEL),FD(NMIX,2*IDIM,NG,NG)) +*---- +* RECOVER TRACKING INFORMATION +*---- + TITLE=' ' + CALL LCMLEN(IPTRK,'TITLE',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + CALL LCMGTC(IPTRK,'TITLE',72,TITLE) + IF(IPRINT.GT.0) WRITE(6,'(/9H NSSDRV: ,A72)') TITLE + ENDIF + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + NX=ISTATE(14) + NY=ISTATE(15) + NZ=ISTATE(16) + LL4F=ISTATE(25) + LL4X=ISTATE(27) + LL4Y=ISTATE(28) + LL4Z=ISTATE(29) + ALLOCATE(MUX(LL4F),MUY(LL4F),MUZ(LL4F),IMAX(LL4F),IMAY(LL4F), + 1 IMAZ(LL4F),IPY(LL4F),IPZ(LL4F)) + CALL LCMGET(IPTRK,'ICODE',ICODE) + CALL LCMGET(IPTRK,'MATCOD',MAT) + CALL LCMGET(IPTRK,'KEYFLX',IDL) + CALL LCMGET(IPTRK,'VOLUME',VOL) + CALL LCMGET(IPTRK,'XX',XX) + CALL LCMGET(IPTRK,'KN',KN) + IF(IDIM.GE.2) CALL LCMGET(IPTRK,'YY',YY) + IF(IDIM.EQ.3) CALL LCMGET(IPTRK,'ZZ',ZZ) + CALL LCMGET(IPTRK,'QFR',QFR) + CALL LCMGET(IPTRK,'IQFR',IQFR) + ALLOCATE(XXX(NX+1),YYY(NY+1),ZZZ(NZ+1)) + CALL LCMGET(IPTRK,'XXX',XXX) + CALL LCMGET(IPTRK,'MUX',MUX) + CALL LCMGET(IPTRK,'IMAX',IMAX) + IF(IDIM.GE.2) THEN + CALL LCMGET(IPTRK,'YYY',YYY) + CALL LCMGET(IPTRK,'MUY',MUY) + CALL LCMGET(IPTRK,'IMAY',IMAY) + CALL LCMGET(IPTRK,'IPY',IPY) + ENDIF + IF(IDIM.EQ.3) THEN + CALL LCMGET(IPTRK,'ZZZ',ZZZ) + CALL LCMGET(IPTRK,'MUZ',MUZ) + CALL LCMGET(IPTRK,'IMAZ',IMAZ) + CALL LCMGET(IPTRK,'IPZ',IPZ) + ENDIF +*---- +* RECOVER MACROLIB INFORMATION +*---- + IF(BB2.NE.0.0) THEN + IF(IPRINT.GT.0) WRITE(6,'(/32H NSSDRV: INCLUDE LEAKAGE IN THE , + > 13HMACROLIB (B2=,1P,E12.5,2H).)') BB2 + ENDIF + CALL LCMGET(IPMAC,'STATE-VECTOR',ISTATE) + NALB=ISTATE(8) ! number of physical albedos + JPMAC=LCMGID(IPMAC,'GROUP') + ALLOCATE(WORK(NMIX*NG),IJJ(NMIX),NJJ(NMIX),IPOS(NMIX)) + DO IGR=1,NG + KPMAC=LCMGIL(JPMAC,IGR) + CALL LCMGET(KPMAC,'NTOT0',SIGR(1,IGR)) + CALL LCMGET(KPMAC,'DIFF',DIFF(1,IGR)) + CALL LCMGET(KPMAC,'CHI',CHI(1,IGR)) + CALL LCMGET(KPMAC,'NUSIGF',SIGF(1,IGR)) + CALL LCMGET(KPMAC,'IJJS00',IJJ) + CALL LCMGET(KPMAC,'NJJS00',NJJ) + CALL LCMGET(KPMAC,'IPOS00',IPOS) + CALL LCMGET(KPMAC,'SCAT00',WORK) + DO IBM=1,NMIX + SCAT(IBM,IGR,:)=0.0 + IPOSDE=IPOS(IBM)-1 + DO JGR=IJJ(IBM),IJJ(IBM)-NJJ(IBM)+1,-1 + IPOSDE=IPOSDE+1 + IF(IPOSDE.GT.NMIX*NG) CALL XABORT('NSSDRV: SCAT OVERFLOW.') + SCAT(IBM,IGR,JGR)=WORK(IPOSDE) ! IGR <-- JGR + ENDDO + SIGR(IBM,IGR)=SIGR(IBM,IGR)-SCAT(IBM,IGR,IGR) + ENDDO + IF(BB2.NE.0.0) THEN + DO IBM=1,NMIX + SIGR(IBM,IGR)=SIGR(IBM,IGR)+BB2*DIFF(IBM,IGR) + ENDDO + ENDIF + DO IBM=1,NMIX + IF(SIGR(IBM,IGR).LE.0.0) CALL XABORT('NSSDRV: SIGR<=0.') + ENDDO + ENDDO + DEALLOCATE(IPOS,NJJ,IJJ,WORK) + ALLOCATE(FDXM(NMIX,NG,NG),FDXP(NMIX,NG,NG),BETA(NALB,NG,NG), + > GAR2(NMIX,NG),GAR3(NMIX,NG),GAR4(NMIX,NG,NG)) + IF(NALB.GT.0) THEN + CALL LCMLEN(IPMAC,'ALBEDO',ILONG,ITYLCM) + IF(ILONG.EQ.NALB*NG) THEN + ALLOCATE(ALBP(NALB,NG)) + CALL LCMGET(IPMAC,'ALBEDO',ALBP) + BETA(:,:,:)=1.0 + DO IGR=1,NG + BETA(:NALB,IGR,IGR)=ALBP(:NALB,IGR) + ENDDO + DEALLOCATE(ALBP) + ELSE IF(ILONG.EQ.NALB*NG*NG) THEN + CALL LCMGET(IPMAC,'ALBEDO',BETA) + ELSE + CALL XABORT('NSSDRV: INVALID ALBEDO LENGTH.') + ENDIF + IF(IPRINT.GT.1) THEN + DO IALB=1,NALB + WRITE(6,'(/35H NSSDRV: PHYSICAL ALBEDO MATRIX ID=,I4)') IALB + DO IGR=1,NG + WRITE(6,'(5X,1P,10E12.4)') BETA(IALB,IGR,:) + ENDDO + ENDDO + ENDIF + ENDIF + FD(:,:,:,:)=0.0 + IF(LNODF.OR.ISTATE(12).EQ.0) THEN + DO IGR=1,NG + FD(:NMIX,:2*IDIM,IGR,IGR)=1.0 + ENDDO + ELSE IF(ISTATE(12).EQ.2) then + CALL LCMSIX(IPMAC,'ADF',1) + CALL LCMGET(IPMAC,'NTYPE',NSURFD) + CALL LCMGET(IPMAC,'AVG_FLUX',GAR3) + CALL LCMGTC(IPMAC,'HADF',8,NSURFD,HADF) + IF(NSURFD.EQ.1) THEN + CALL LCMGET(IPMAC,HADF(1),GAR2) + DO IBM=1,NMIX + DO IGR=1,NG + FD(IBM,:2*IDIM,IGR,IGR)=GAR2(IBM,IGR)/GAR3(IBM,IGR) + ENDDO + ENDDO + ELSE IF(NSURFD.EQ.2*IDIM) THEN + DO I=1,NSURFD + IF(HADF(I)(1:3).NE.'FD_') THEN + WRITE(HSMG,'(7HNSSDRV:,A,28H FOUND; FD_ PREFIX EXPECTED.) + 1 ') TRIM(HADF(I)) + CALL XABORT(HSMG) + ENDIF + CALL LCMGET(IPMAC,HADF(I),GAR2) + DO IGR=1,NG + FD(:NMIX,I,IGR,IGR)=GAR2(:NMIX,IGR)/GAR3(:NMIX,IGR) + ENDDO + ENDDO + ELSE + WRITE(HSMG,'(12HNSSDRV: 1 OR,I3,25HDISCONTINUITY FACTORS EXP, + 1 6HECTED.)') 2*IDIM + CALL XABORT(HSMG) + ENDIF + CALL LCMSIX(IPMAC,' ',2) + ELSE IF(ISTATE(12).EQ.3) THEN + CALL LCMSIX(IPMAC,'ADF',1) + CALL LCMGET(IPMAC,'NTYPE',NSURFD) + CALL LCMGTC(IPMAC,'HADF',8,NSURFD,HADF) + IF(NSURFD.EQ.1) THEN + CALL LCMGET(IPMAC,HADF(1),GAR2) + DO IBM=1,NMIX + DO IGR=1,NG + FD(IBM,:2*IDIM,IGR,IGR)=GAR2(IBM,IGR) + ENDDO + ENDDO + ELSE IF(NSURFD.EQ.2*IDIM) THEN + DO I=1,NSURFD + IF(HADF(I)(1:3).NE.'FD_') THEN + WRITE(HSMG,'(7HNSSDRV:,A,28H FOUND; FD_ PREFIX EXPECTED.) + 1 ') TRIM(HADF(I)) + CALL XABORT(HSMG) + ENDIF + CALL LCMGET(IPMAC,HADF(I),GAR2) + DO IGR=1,NG + FD(:NMIX,I,IGR,IGR)=GAR2(:NMIX,IGR) + ENDDO + ENDDO + ELSE + WRITE(HSMG,'(12HNSSDRV: 1 OR,I3,25HDISCONTINUITY FACTORS EXP, + 1 6HECTED.)') 2*IDIM + CALL XABORT(HSMG) + ENDIF + CALL LCMSIX(IPMAC,' ',2) + ELSE IF(ISTATE(12).EQ.4) THEN + ! matrix discontinuity factors + CALL LCMSIX(IPMAC,'ADF',1) + CALL LCMGET(IPMAC,'NTYPE',NSURFD) + IF(NSURFD.NE.2*IDIM) THEN + WRITE(HSMG,'(7HNSSDRV:,I3,30HDISCONTINUITY FACTORS EXPECTED)' + 1 ) 2*IDIM + CALL XABORT(HSMG) + ENDIF + CALL LCMGTC(IPMAC,'HADF',8,NSURFD,HADF) + DO I=1,NSURFD + IF((HADF(I)(1:4).NE.'ERM_').AND.(HADF(I)(1:3).NE.'FD_')) THEN + WRITE(HSMG,'(7HNSSDRV:,A,30H FOUND; ERM_ OR FD_ PREFIX EXP, + 1 6HECTED.)') TRIM(HADF(I)) + CALL XABORT(HSMG) + ENDIF + CALL LCMGET(IPMAC,HADF(I),GAR4) + DO JGR=1,NG + DO IGR=1,NG + FD(:NMIX,I,IGR,JGR)=GAR4(:NMIX,IGR,JGR) + ENDDO + ENDDO + ENDDO + CALL LCMSIX(IPMAC,' ',2) + ELSE + WRITE(6,'(13H NSSDRV: IDF=,I3)') ISTATE(12) + CALL XABORT('NSSDRV: FLUX/CURRENT INFORMATION NOT SUPPORTED.') + ENDIF + IF(IPRINT.GT.3) THEN + DO I=1,NSURFD + WRITE(6,'(/31H NSSDRV: discontinuity factors ,A8)') HADF(I) + DO IBM=1,NMIX + DO IGR=1,NG + WRITE(6,'(4H FD(,2I4,2H)=,1p,12E12.4/(8X,12E12.4))') + 1 IBM,IGR,FD(IBM,:,IGR,IGR) + ENDDO + ENDDO + ENDDO + ENDIF + DEALLOCATE(GAR4,GAR3,GAR2,FDXP,FDXM) +*---- +* COMPUTE THE FLUX AND STORE NODAL SOLUTION IN IPFLX +*---- + IF(ICHX.EQ.5) THEN ! NEM + CALL NSSFL1(IPFLX,NUN,NG,NEL,NMIX,NALB,ITRIAL,EPSOUT,MAXOUT, + 1 MAT,XX,IQFR,QFR,DIFF,SIGR,CHI,SIGF,SCAT,BETA,FD,IPRINT) + ELSE IF(ICHX.EQ.4) THEN ! CMFD + CALL NSSFL2(IPFLX,NUN,NG,NEL,NMIX,NALB,EPSOUT,MAXOUT,MAT,XX, + 1 IQFR,QFR,DIFF,SIGR,CHI,SIGF,SCAT,BETA,FD,IPRINT) + ELSE IF((ICHX.EQ.6).AND.(IDIM.EQ.1)) THEN ! ANM-1D + CALL NSSFL3(IPFLX,NUN,NG,NEL,NMIX,NALB,EPSNOD,MAXNOD,EPSOUT, + 1 MAXOUT,MAT,XX,XXX,IDL,IQFR,QFR,DIFF,SIGR,CHI,SIGF,SCAT,BETA, + 2 FD,IPRINT) + ELSE IF((ICHX.EQ.6).AND.(IDIM.EQ.2)) THEN ! ANM-2D + CALL NSSFL4(IPFLX,NUN,NG,NX,NY,LL4F,LL4X,LL4Y,NMIX,NALB,ICL1, + 1 ICL2,NADI,EPSNOD,MAXNOD,EPSTHR,MAXTHR,EPSOUT,MAXOUT,MAT,XX,YY, + 2 XXX,YYY,IDL,VOL,KN,IQFR,QFR,DIFF,SIGR,CHI,SIGF,SCAT,BETA,FD, + 3 BNDTL,NPASS,MUX,MUY,IMAX,IMAY,IPY,IPRINT) + ELSE IF((ICHX.EQ.6).AND.(IDIM.EQ.3)) THEN ! ANM-3D + CALL NSSFL5(IPFLX,NUN,NG,NX,NY,NZ,LL4F,LL4X,LL4Y,LL4Z,NMIX,NALB, + 1 ICL1,ICL2,NADI,EPSNOD,MAXNOD,EPSTHR,MAXTHR,EPSOUT,MAXOUT,MAT,XX, + 2 YY,ZZ,XXX,YYY,ZZZ,IDL,VOL,KN,IQFR,QFR,DIFF,SIGR,CHI,SIGF,SCAT, + 3 BETA,FD,BNDTL,NPASS,MUX,MUY,MUZ,IMAX,IMAY,IMAZ,IPY,IPZ,IPRINT) + ELSE + CALL XABORT('NSSDRV: OPTION NOT AVAILABLE.') + ENDIF + ISTATE(:)=0 + ISTATE(1)=NG + ISTATE(2)=NUN + ISTATE(6)=2 + CALL LCMPUT(IPFLX,'STATE-VECTOR',NSTATE,1,ISTATE) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IPZ,IPY,IMAZ,IMAY,IMAX,MUZ,MUY,MUX) + DEALLOCATE(BETA) + DEALLOCATE(ZZZ,YYY,XXX) + DEALLOCATE(FD,QFR,SCAT,SIGF,CHI,SIGR,DIFF,VOL,ZZ,YY,XX) + DEALLOCATE(IQFR,KN,IDL,MAT) + RETURN + END diff --git a/Trivac/src/NSSEIG.f b/Trivac/src/NSSEIG.f new file mode 100755 index 0000000..b82fba8 --- /dev/null +++ b/Trivac/src/NSSEIG.f @@ -0,0 +1,572 @@ +*DECK NSSEIG + SUBROUTINE NSSEIG(NMAX,NMAY,NMAZ,LL4F,NDIM,NEL,NMIX,NG,MAT,IDL, + > VOL,MUX,MUY,MUZ,IMAX,IMAY,IMAZ,IPY,IPZ,CHI,SIGF,SCAT,A11X,A11Y, + > A11Z,EPSTHR,MAXTHR,NADI,EPSOUT,MAXOUT,ICL1,ICL2,ITER,EVECT, + > FKEFF,IMPX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Solution of a multigroup eigenvalue system for the calculation of the +* direct neutron flux in Trivac. Use the preconditioned power method +* with a two-parameter SVAT acceleration technique. CMFD solution. +* +*Copyright: +* Copyright (C) 2023 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NMAX first dimension of array A11X. +* NMAY first dimension of array A11Y. +* NMAZ first dimension of array A11Z. +* LL4F number of unknowns per energy group. +* NDIM number of dimensions (1, 2 or 3). +* NEL number of nodes. +* NMIX number of mixtures in the nodal calculation. +* NG number of energy groups. +* MAT material mixtures. +* IDL position of averaged fluxes in unknown vector. +* VOL node volumes. +* MUX X-oriented compressed storage mode indices. +* MUY Y-oriented compressed storage mode indices. +* MUZ Z-oriented compressed storage mode indices. +* IMAX X-oriented position of each first non-zero column element. +* IMAY Y-oriented position of each first non-zero column element. +* IMAZ Z-oriented position of each first non-zero column element. +* IPY Y-oriented permutation matrices. +* IPZ Z-oriented permutation matrices. +* CHI fission spectra. +* SIGF nu times fission cross section. +* SCAT scattering cross section. +* A11X X-oriented sparse coefficient matrix. +* A11Y Y-oriented sparse coefficient matrix. +* A11Z Z-oriented sparse coefficient matrix. +* EPSTHR thermal iteration epsilon. +* MAXTHR maximum number of thermal iterations. +* NADI number of inner ADI iterations. +* EPSOUT convergence epsilon for the power method. +* MAXOUT maximum number of iterations for the power method. +* ICL1 number of free iretations in one cycle of the up-scattering +* iterations. +* ICL2 number of accelerated up-scattering iterations in one cycle. +* EVECT initial estimate of fundamental eigenvalue. +* IMPX print parameter. +* FKEFF initial estimate of fundamental eigenvalue. +* +*Parameters: output +* ITER number of iterations. +* EVECT corresponding eigenvector. +* FKEFF fundamental eigenvalue. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER, INTENT(IN) :: NMAX,NMAY,NMAZ,LL4F,NDIM,NEL,NMIX,NG, + > MAT(NEL),IDL(NEL),MUX(LL4F),MUY(LL4F),MUZ(LL4F),IMAX(LL4F), + > IMAY(LL4F),IMAZ(LL4F),IPY(LL4F),IPZ(LL4F),MAXTHR,NADI,MAXOUT, + > ICL1,ICL2,IMPX + REAL, INTENT(IN) :: VOL(NEL),CHI(NMIX,NG),SIGF(NMIX,NG), + > SCAT(NMIX,NG,NG),A11X(NMAX,NG),A11Y(NMAY,NG),A11Z(NMAZ,NG) + INTEGER, INTENT(OUT) :: ITER + REAL, INTENT(IN) :: EPSTHR,EPSOUT + REAL, INTENT(INOUT) :: EVECT(LL4F,NG),FKEFF +*---- +* LOCAL VARIABLES +*---- + REAL, PARAMETER :: EPS1=1.0E-5 + REAL(KIND=8), PARAMETER :: ALP_TAB(24) = (/ 0.2, 0.4, 0.6, + 1 0.8, 1.0, 1.2, 1.5, 2.0, 10.0, 15.0, 20.0, 25.0, 30.0, 35.0, + 2 40.0, 45.0, 50.0, 55.0, 60.0, 65.0, 70.0, 75.0, 80.0, 85.0 /) + REAL(KIND=8), PARAMETER :: BET_TAB(11) = (/ -1.0, -0.8, -0.6, + 1 -0.4, -0.2, 0.0, 0.2, 0.4, 0.6, 0.8, 1.0 /) + REAL(KIND=8) :: AEAE,AEAG,AEAH,AGAG,AGAH,AHAH,BEBE,BEBG,BEBH, + 1 BGBG,BGBH,BHBH,AEBE,AEBG,AEBH,AGBE,AGBG,AGBH,AHBE,AHBG,AHBH, + 2 X,DXDA,DXDB,Y,DYDA,DYDB,Z,DZDA,DZDB,F,D2F(2,3),EVAL,ALP,BET, + 3 FMIN,VVV + LOGICAL LOGTES + CHARACTER(LEN=3) :: TEXT3 +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: S2,F1,GARM1,GARM2 + REAL, ALLOCATABLE, DIMENSION(:,:) :: S,GRAD1,GRAD2,GAR1,GAR2, + 1 GAR3,GAF1,GAF2,GAF3 + REAL, ALLOCATABLE, DIMENSION(:,:) :: IA11X,IA11Y,IA11Z + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: WORK +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(S2(LL4F),S(LL4F,NG),GRAD1(LL4F,NG),GRAD2(LL4F,NG), + > GAR1(LL4F,NG),GAR2(LL4F,NG),GAR3(LL4F,NG),GAF1(LL4F,NG), + > GAF2(LL4F,NG),GAF3(LL4F,NG),WORK(LL4F,NG,3),IA11X(NMAX,NG), + > IA11Y(NMAY,NG),IA11Z(NMAZ,NG)) +*---- +* LU MATRIX FACTORIZATION +*---- + IA11X(:NMAX,:NG)=A11X(:NMAX,:NG) + DO IG=1,NG + CALL ALLUF(LL4F,IA11X(1,IG),MUX,IMAX) + ENDDO + IF(NDIM.GT.1) THEN + IA11Y(:NMAY,:NG)=A11Y(:NMAY,:NG) + DO IG=1,NG + CALL ALLUF(LL4F,IA11Y(1,IG),MUY,IMAY) + ENDDO + ENDIF + IF(NDIM.EQ.3) THEN + IA11Z(:NMAZ,:NG)=A11Z(:NMAZ,:NG) + DO IG=1,NG + CALL ALLUF(LL4F,IA11Z(1,IG),MUZ,IMAZ) + ENDDO + ENDIF +*---- +* POWER METHOD +*---- + NCTOT=ICL1+ICL2 + IF(ICL2.EQ.0) THEN + NCPTM=NCTOT+1 + ELSE + NCPTM=ICL1 + ENDIF + EVAL=1.0D0/FKEFF + VVV=0.0D0 + ISTART=1 + NNADI=NADI + TEST=0.0 + IF(IMPX.GE.2) WRITE (6,600) NADI + ITER=0 + DO + ITER=ITER+1 + IF(ITER > MAXOUT) CALL XABORT('NSSEIG: OUTER ITER. FAILURE.') +*---- +* EIGENVALUE EVALUATION +*---- + CALL NSSMPA(NMAX,NMAY,NMAZ,LL4F,NDIM,NEL,NMIX,NG,MAT,IDL, + > VOL,MUX,MUY,MUZ,IMAX,IMAY,IMAZ,IPY,IPZ,SCAT,A11X,A11Y,A11Z, + > EVECT,WORK(1,1,1)) + CALL NSSMPB(LL4F,NEL,NMIX,NG,MAT,IDL,VOL,CHI,SIGF,EVECT, + > WORK(1,1,2)) + AEBE=0.0D0 + BEBE=0.0D0 + DO IG=1,NG + DO I=1,LL4F + AEBE=AEBE+WORK(I,IG,1)*WORK(I,IG,2) + BEBE=BEBE+WORK(I,IG,2)**2 + ENDDO + ENDDO + EVAL=AEBE/BEBE + S(:LL4F,:NG)=REAL(EVAL)*WORK(:LL4F,:NG,2)-WORK(:LL4F,:NG,1) +*---- +* PERFORM THERMAL (UP-SCATTERING) ITERATIONS +*---- + WORK(:LL4F,:NG,:3)=0.0D0 + IGDEB=1 + TEXT3='NO ' + JTER=1 + ALLOCATE(F1(LL4F),GARM1(LL4F),GARM2(LL4F)) + DO + WORK(:LL4F,:NG,1)=WORK(:LL4F,:NG,2) + WORK(:LL4F,:NG,2)=WORK(:LL4F,:NG,3) + WORK(:LL4F,:NG,3)=0.0D0 + GRAD1(:LL4F,:NG)=0.0D0 + DO IG=IGDEB,NG + S2(:LL4F)=S(:LL4F,IG) + DO JG=1,NG + IF(JG.EQ.IG) CYCLE + DO IEL=1,NEL + IBM=MAT(IEL) + IF(IBM.LE.0) CYCLE + IND=IDL(IEL) + IF(IND.EQ.0) CYCLE + S2(IND)=S2(IND)+VOL(IEL)*SCAT(IBM,IG,JG)*GRAD1(IND,JG) + ENDDO + ENDDO +* + WORK(:LL4F,IG,3)=0.0 + DO IADI=1,NNADI + IF(IADI.EQ.1) THEN + F1(:LL4F)=S2(:LL4F) + ELSE +* scalar multiplication for a x-oriented matrix. + CALL ALLUM(LL4F,A11X(1,IG),WORK(1,IG,3),F1(1),MUX, + 1 IMAX,1) + IF(NDIM.GE.2) THEN +* scalar multiplication for a y-oriented matrix. + GARM1(IPY(:LL4F))=WORK(:LL4F,IG,3) + GARM2(IPY(:LL4F))=F1(:LL4F) + CALL ALLUM(LL4F,A11Y(1,IG),GARM1(1),GARM2(1),MUY, + 1 IMAY,2) + F1(:LL4F)=GARM2(IPY(:LL4F)) + ENDIF + IF(NDIM.EQ.3) THEN +* scalar multiplication for a z-oriented matrix. + GARM1(IPZ(:LL4F))=WORK(:LL4F,IG,3) + GARM2(IPZ(:LL4F))=F1(:LL4F) + CALL ALLUM(LL4F,A11Z(1,IG),GARM1(1),GARM2(1),MUZ, + 1 IMAZ,2) + F1(:LL4F)=GARM2(IPZ(:LL4F)) + ENDIF + F1(:LL4F)=S2(:LL4F)-F1(:LL4F) + ENDIF +* scalar solution for a x-oriented linear system. + CALL ALLUS(LL4F,MUX,IMAX,IA11X(1,IG),F1) + IF(NDIM.GE.2) THEN +* scalar solution for a y-oriented linear system. + DO I=1,LL4F + II=IPY(I) + GARM1(II)=F1(I)*A11Y(MUY(II),IG) + ENDDO + CALL ALLUS(LL4F,MUY,IMAY,IA11Y(1,IG),GARM1) + F1(:LL4F)=GARM1(IPY(:LL4F)) + ENDIF + IF(NDIM.EQ.3) THEN +* scalar solution for a z-oriented linear system. + DO I=1,LL4F + II=IPZ(I) + GARM1(II)=F1(I)*A11Z(MUZ(II),IG) + ENDDO + CALL ALLUS(LL4F,MUZ,IMAZ,IA11Z(1,IG),GARM1) + F1(:LL4F)=GARM1(IPZ(:LL4F)) + ENDIF + WORK(:LL4F,IG,3)=WORK(:LL4F,IG,3)+F1(:LL4F) + GRAD1(:LL4F,IG)=WORK(:LL4F,IG,3) + ENDDO + + ENDDO + IF(MAXTHR.EQ.0) EXIT + IF(MOD(JTER-1,NCTOT).GE.NCPTM) THEN + CALL NSS2AC(NG,LL4F,IGDEB,WORK,ZMU) + ELSE + ZMU=1.0D0 + ENDIF + IGDEBO=IGDEB + DO IG=IGDEBO,NG + GINN=0.0D0 + FINN=0.0D0 + DO I=1,LL4F + GINN=MAX(GINN,ABS(WORK(I,IG,2)-WORK(I,IG,3))) + FINN=MAX(FINN,ABS(WORK(I,IG,3))) + ENDDO + GINN=GINN/FINN + IF((GINN.LT.EPSTHR).AND.(IGDEB.EQ.IG)) IGDEB=IGDEB+1 + ENDDO + IF(GINN.LT.EPSTHR) TEXT3='YES' + IF(IMPX.GT.2) WRITE(6,610) JTER,GINN,EPSTHR,IGDEB,ZMU,TEXT3 + IF((GINN.LT.EPSTHR).OR.(JTER.EQ.MAXTHR)) EXIT + JTER=JTER+1 + ENDDO + DEALLOCATE(GARM2,GARM1,F1) +*---- +* DISPLACEMENT EVALUATION +*---- + F=0.0D0 + DELS=ABS(REAL((EVAL-VVV)/EVAL)) + VVV=EVAL +*---- +* EVALUATION OF THE TWO ACCELERATION PARAMETERS ALP AND BET +*---- + ALP=1.0D0 + BET=0.0D0 + N=0 + AEAE=0.0D0 + AEAG=0.0D0 + AEAH=0.0D0 + AGAG=0.0D0 + AGAH=0.0D0 + AHAH=0.0D0 + BEBG=0.0D0 + BEBH=0.0D0 + BGBG=0.0D0 + BGBH=0.0D0 + BHBH=0.0D0 + AEBG=0.0D0 + AEBH=0.0D0 + AGBE=0.0D0 + AGBG=0.0D0 + AGBH=0.0D0 + AHBE=0.0D0 + AHBG=0.0D0 + AHBH=0.0D0 + CALL NSSMPA(NMAX,NMAY,NMAZ,LL4F,NDIM,NEL,NMIX,NG,MAT,IDL,VOL, + > MUX,MUY,MUZ,IMAX,IMAY,IMAZ,IPY,IPZ,SCAT,A11X,A11Y,A11Z,EVECT, + > GAR1) + CALL NSSMPA(NMAX,NMAY,NMAZ,LL4F,NDIM,NEL,NMIX,NG,MAT,IDL,VOL, + > MUX,MUY,MUZ,IMAX,IMAY,IMAZ,IPY,IPZ,SCAT,A11X,A11Y,A11Z,GRAD1, + > GAR2) + IF(1+MOD(ITER-ISTART,ICL1+ICL2).GT.ICL1) THEN + CALL NSSMPB(LL4F,NEL,NMIX,NG,MAT,IDL,VOL,CHI,SIGF,EVECT,GAF1) + CALL NSSMPB(LL4F,NEL,NMIX,NG,MAT,IDL,VOL,CHI,SIGF,GRAD1,GAF2) + CALL NSSMPB(LL4F,NEL,NMIX,NG,MAT,IDL,VOL,CHI,SIGF,GRAD2,GAF3) + DO IG=1,NG + DO I=1,LL4F +* COMPUTE (A ,A ) + AEAE=AEAE+GAR1(I,IG)**2 + AEAG=AEAG+GAR1(I,IG)*GAR2(I,IG) + AEAH=AEAH+GAR1(I,IG)*GAR3(I,IG) + AGAG=AGAG+GAR2(I,IG)**2 + AGAH=AGAH+GAR2(I,IG)*GAR3(I,IG) + AHAH=AHAH+GAR3(I,IG)**2 +* COMPUTE (B ,B ) + BEBG=BEBG+GAF1(I,IG)*GAF2(I,IG) + BEBH=BEBH+GAF1(I,IG)*GAF3(I,IG) + BGBG=BGBG+GAF2(I,IG)**2 + BGBH=BGBH+GAF2(I,IG)*GAF3(I,IG) + BHBH=BHBH+GAF3(I,IG)**2 +* COMPUTE (A ,B ) + AEBG=AEBG+GAR1(I,IG)*GAF2(I,IG) + AEBH=AEBH+GAR1(I,IG)*GAF3(I,IG) + AGBE=AGBE+GAR2(I,IG)*GAF1(I,IG) + AGBG=AGBG+GAR2(I,IG)*GAF2(I,IG) + AGBH=AGBH+GAR2(I,IG)*GAF3(I,IG) + AHBE=AHBE+GAR3(I,IG)*GAF1(I,IG) + AHBG=AHBG+GAR3(I,IG)*GAF2(I,IG) + AHBH=AHBH+GAR3(I,IG)*GAF3(I,IG) + ENDDO + ENDDO +* + 210 N=N+1 + IF(N.GT.10) GO TO 215 +* COMPUTE X(ITER+1) + X=BEBE+ALP*ALP*BGBG+BET*BET*BHBH+2.0D0*(ALP*BEBG+BET*BEBH + > +ALP*BET*BGBH) + DXDA=2.0D0*(BEBG+ALP*BGBG+BET*BGBH) + DXDB=2.0D0*(BEBH+ALP*BGBH+BET*BHBH) +* COMPUTE Y(ITER+1) + Y=AEAE+ALP*ALP*AGAG+BET*BET*AHAH+2.0D0*(ALP*AEAG+BET*AEAH + > +ALP*BET*AGAH) + DYDA=2.0D0*(AEAG+ALP*AGAG+BET*AGAH) + DYDB=2.0D0*(AEAH+ALP*AGAH+BET*AHAH) +* COMPUTE Z(ITER+1) + Z=AEBE+ALP*ALP*AGBG+BET*BET*AHBH+ALP*(AEBG+AGBE) + > +BET*(AEBH+AHBE)+ALP*BET*(AGBH+AHBG) + DZDA=AEBG+AGBE+2.0D0*ALP*AGBG+BET*(AGBH+AHBG) + DZDB=AEBH+AHBE+ALP*(AGBH+AHBG)+2.0D0*BET*AHBH +* COMPUTE F(ITER+1) + F=X*Y-Z*Z + D2F(1,1)=2.0D0*(BGBG*Y+DXDA*DYDA+X*AGAG-DZDA**2-2.0D0*Z*AGBG) + D2F(1,2)=2.0D0*BGBH*Y+DXDA*DYDB+DXDB*DYDA+2.0D0*X*AGAH + > -2.0D0*DZDA*DZDB-2.0D0*Z*(AGBH+AHBG) + D2F(2,2)=2.0D0*(BHBH*Y+DXDB*DYDB+X*AHAH-DZDB**2-2.0D0*Z*AHBH) + D2F(2,1)=D2F(1,2) + D2F(1,3)=DXDA*Y+X*DYDA-2.0D0*Z*DZDA + D2F(2,3)=DXDB*Y+X*DYDB-2.0D0*Z*DZDB +* SOLUTION OF A LINEAR SYSTEM. + CALL ALSBD(2,1,D2F,IER,2) + IF(IER.NE.0) GO TO 215 + ALP=ALP-D2F(1,3) + BET=BET-D2F(2,3) + IF(ALP.GT.100.0D0) GO TO 215 + IF((ABS(D2F(1,3)).LE.1.0D-4).AND.(ABS(D2F(2,3)).LE.1.0D-4)) + > GO TO 220 + GO TO 210 +* +* alternative algorithm in case of Newton-Raphton failure + 215 IF(IMPX.GT.0) WRITE(6,'(/30H NSSEIG: FAILURE OF THE NEWTON, + > 55H-RAPHTON ALGORIHTHM FOR COMPUTING THE OVERRELAXATION PA, + > 9HRAMETERS.)') + IAMIN=999 + IBMIN=999 + FMIN=HUGE(FMIN) + DO IA=1,SIZE(ALP_TAB) + ALP=ALP_TAB(IA) + DO IB=1,SIZE(BET_TAB) + BET=BET_TAB(IB) +* COMPUTE X + X=BEBE+ALP*ALP*BGBG+BET*BET*BHBH+2.0D0*(ALP*BEBG+BET*BEBH + > +ALP*BET*BGBH) +* COMPUTE Y + Y=AEAE+ALP*ALP*AGAG+BET*BET*AHAH+2.0D0*(ALP*AEAG+BET*AEAH + > +ALP*BET*AGAH) +* COMPUTE Z + Z=AEBE+ALP*ALP*AGBG+BET*BET*AHBH+ALP*(AEBG+AGBE) + > +BET*(AEBH+AHBE)+ALP*BET*(AGBH+AHBG) +* COMPUTE F + F=X*Y-Z*Z + IF(F.LT.FMIN) THEN + IAMIN=IA + IBMIN=IB + FMIN=F + ENDIF + ENDDO + ENDDO + ALP=ALP_TAB(IAMIN) + BET=BET_TAB(IBMIN) + 220 BET=BET/ALP + IF((ALP.LT.1.0D0).AND.(ALP.GT.0.0D0)) THEN + ALP=1.0D0 + BET=0.0D0 + ELSE IF(ALP.LE.0.0D0) THEN + ISTART=ITER+1 + ALP=1.0D0 + BET=0.0D0 + ENDIF + DO IG=1,NG + DO I=1,LL4F + GRAD1(I,IG)=REAL(ALP)*(GRAD1(I,IG)+REAL(BET)*GRAD2(I,IG)) + GAR2(I,IG)=REAL(ALP)*(GAR2(I,IG)+REAL(BET)*GAR3(I,IG)) + ENDDO + ENDDO + ENDIF +* + LOGTES=(ITER.LT.ICL1).OR.(MOD(ITER-ISTART,ICL1+ICL2).EQ.ICL1-1) + DELT=0.0D0 + IF(LOGTES.AND.(DELS.LE.EPS1)) THEN + CALL NSSMPB(LL4F,NEL,NMIX,NG,MAT,IDL,VOL,CHI,SIGF,EVECT,GAF1) + CALL NSSMPB(LL4F,NEL,NMIX,NG,MAT,IDL,VOL,CHI,SIGF,GRAD1,GAF2) + DO IG=1,NG + DELN=0.0D0 + DELD=0.0D0 + DO I=1,LL4F + EVECT(I,IG)=EVECT(I,IG)+GRAD1(I,IG) + GAR1(I,IG)=GAR1(I,IG)+GAR2(I,IG) + GRAD2(I,IG)=GRAD1(I,IG) + GAR3(I,IG)=GAR2(I,IG) + DELN=MAX(DELN,ABS(GAF2(I,IG))) + DELD=MAX(DELD,ABS(GAF1(I,IG))) + ENDDO + IF(DELD.NE.0.0D0) DELT=MAX(DELT,DELN/DELD) + ENDDO + IF(IMPX.GE.2) WRITE (6,620) ITER,AEAE,AEAG,AEAH,AGAG,AGAH, + > AHAH,BEBE,ALP,BET,EVAL,F,DELS,DELT,N,BEBG,BEBH,BGBG,BGBH, + > BHBH,AEBE,AEBG,AEBH,AGBE,AGBG,AGBH,AHBE,AHBG,AHBH + IF(DELT.LE.EPSOUT) EXIT + ELSE + DO IG=1,NG + DO I=1,LL4F + EVECT(I,IG)=EVECT(I,IG)+GRAD1(I,IG) + GAR1(I,IG)=GAR1(I,IG)+GAR2(I,IG) + GRAD2(I,IG)=GRAD1(I,IG) + GAR3(I,IG)=GAR2(I,IG) + ENDDO + ENDDO + IF(IMPX.GE.2) WRITE (6,620) ITER,AEAE,AEAG,AEAH,AGAG,AGAH, + > AHAH,BEBE,ALP,BET,EVAL,F,DELS,DELT,N,BEBG,BEBH,BGBG,BGBH, + > BHBH,AEBE,AEBG,AEBH,AGBE,AGBG,AGBH,AHBE,AHBG,AHBH + ENDIF +* + IF(ITER.EQ.1) TEST=DELS + IF((ITER.GT.5).AND.(DELS.GT.TEST)) CALL XABORT('NSSEIG: CONVER' + > //'GENCE FAILURE.') + IF(ITER.GE.MAXOUT) THEN + WRITE (6,630) + EXIT + ENDIF + IF(MOD(ITER,36).EQ.0) THEN + ISTART=ITER+1 + NNADI=NNADI+1 + IF(IMPX.GE.1) WRITE (6,650) NNADI + ENDIF + ENDDO +*---- +* FLUX NORMALIZATION +*---- + FMAX=MAXVAL(EVECT(:LL4F,:NG)) + EVECT(:LL4F,:NG)=EVECT(:LL4F,:NG)/FMAX +*---- +* SOLUTION EDITION +*---- + FKEFF=REAL(1.0D0/EVAL) + IF(IMPX.GE.1) WRITE (6,640) ITER,FKEFF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IA11Z,IA11Y,IA11X) + DEALLOCATE(WORK,GAF3,GAF2,GAF1,GAR3,GAR2,GAR1,GRAD2,GRAD1,S,S2) + RETURN +*---- +* FORMATS +*---- + 600 FORMAT(1H1/50H NSSEIG: ITERATIVE PROCEDURE BASED ON PRECONDITION, + > 17HED POWER METHOD (,I2,37H ADI ITERATIONS PER OUTER ITERATION)./ + > 9X,16HDIRECT EQUATION.) + 610 FORMAT (10X,3HIN(,I3,6H) FLX:,5H PRC=,1P,E9.2,5H TAR=,E9.2, + > 7H IGDEB=, I13,6H ACCE=,0P,F12.5,12H CONVERGED=,A3) + 620 FORMAT(1X,I3,1P,7E9.1,0P,2F8.3,E14.6,3E10.2,I4/(4X,1P,7E9.1)) + 630 FORMAT(/53H NSSEIG: ***WARNING*** THE MAXIMUM NUMBER OF OUTER IT, + > 20HERATIONS IS REACHED.) + 640 FORMAT(/23H NSSEIG: CONVERGENCE IN,I4,12H ITERATIONS.// + > 42H NSSEIG: EFFECTIVE MULTIPLICATION FACTOR =,1P,E17.10/) + 650 FORMAT(/53H NSSEIG: INCREASING THE NUMBER OF INNER ITERATIONS TO, + 1 I3,36H ADI ITERATIONS PER OUTER ITERATION./) + ! + CONTAINS + SUBROUTINE NSSMPA(NMAX,NMAY,NMAZ,LL4F,NDIM,NEL,NMIX,NG,MAT,IDL, + > VOL,MUX,MUY,MUZ,IMAX,IMAY,IMAZ,IPY,IPZ,SCAT,A11X,A11Y,A11Z, + > EVECT,S2) + ! + ! A*EVECT MULTIPLICATION + ! + INTEGER, INTENT(IN) :: NMAX,NMAY,NMAZ,LL4F,NDIM,NEL,NMIX,NG, + > MAT(NEL),IDL(NEL),MUX(LL4F),MUY(LL4F),MUZ(LL4F),IMAX(LL4F), + > IMAY(LL4F),IMAZ(LL4F),IPY(LL4F),IPZ(LL4F) + REAL, INTENT(IN) :: VOL(NEL),SCAT(NMIX,NG,NG) + REAL, INTENT(IN) :: EVECT(LL4F,NG),A11X(NMAX,NG),A11Y(NMAY,NG), + > A11Z(NMAZ,NG) + REAL, INTENT(OUT) :: S2(LL4F,NG) + REAL, ALLOCATABLE, DIMENSION(:) :: GAR1,GAR2 + ! + ALLOCATE(GAR1(LL4F),GAR2(LL4F)) + DO IG=1,NG +* scalar multiplication for a x-oriented matrix. + CALL ALLUM(LL4F,A11X(1,IG),EVECT(1,IG),S2(1,IG),MUX,IMAX,1) + IF(NDIM.GE.2) THEN +* scalar multiplication for a y-oriented matrix. + GAR1(IPY(:LL4F))=EVECT(:LL4F,IG) + GAR2(IPY(:LL4F))=S2(:LL4F,IG) + CALL ALLUM(LL4F,A11Y(1,IG),GAR1(1),GAR2(1),MUY,IMAY,2) + S2(:LL4F,IG)=GAR2(IPY(:LL4F)) + ENDIF + IF(NDIM.EQ.3) THEN +* scalar multiplication for a z-oriented matrix. + GAR1(IPZ(:LL4F))=EVECT(:LL4F,IG) + GAR2(IPZ(:LL4F))=S2(:LL4F,IG) + CALL ALLUM(LL4F,A11Z(1,IG),GAR1(1),GAR2(1),MUZ,IMAZ,2) + S2(:LL4F,IG)=GAR2(IPZ(:LL4F)) + ENDIF + DO JG=1,NG + IF(JG.EQ.IG) CYCLE + DO IEL=1,NEL + IBM=MAT(IEL) + IF(IBM.LE.0) CYCLE + IND=IDL(IEL) + IF(IND.EQ.0) CYCLE + S2(IND,IG)=S2(IND,IG)-VOL(IEL)*SCAT(IBM,IG,JG)* + > EVECT(IND,JG) + ENDDO + ENDDO + ENDDO + DEALLOCATE(GAR2,GAR1) + END SUBROUTINE NSSMPA + ! + SUBROUTINE NSSMPB(LL4F,NEL,NMIX,NG,MAT,IDL,VOL,CHI,SIGF,EVECT, + > S2) + ! + ! B*EVECT MULTIPLICATION + ! + INTEGER, INTENT(IN) :: LL4F,NEL,NMIX,NG,MAT(NEL),IDL(NEL) + REAL, INTENT(IN) :: VOL(NEL),CHI(NMIX,NG),SIGF(NMIX,NG) + REAL, INTENT(IN) :: EVECT(LL4F,NG) + REAL, INTENT(OUT) :: S2(LL4F,NG) + ! + S2(:LL4F,:NG)=0.0D0 + DO IG=1,NG + DO JG=1,NG ! IG <-- JG + DO IEL=1,NEL + IBM=MAT(IEL) + IF(IBM.LE.0) CYCLE + IND=IDL(IEL) + IF(IND.EQ.0) CYCLE + S2(IND,IG)=S2(IND,IG)+VOL(IEL)*CHI(IBM,IG)*SIGF(IBM,JG)* + > EVECT(IND,JG) + ENDDO + ENDDO + ENDDO + END SUBROUTINE NSSMPB + END SUBROUTINE NSSEIG diff --git a/Trivac/src/NSSF.f b/Trivac/src/NSSF.f new file mode 100755 index 0000000..1470e22 --- /dev/null +++ b/Trivac/src/NSSF.f @@ -0,0 +1,244 @@ +*DECK NSSF + SUBROUTINE NSSF(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Flux solution for a nodal method (NEM or ANM). +* +*Copyright: +* Copyright (C) 2021 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1): create type(L_FLUX) nodal flux; +* HENTRY(2): read-only type(L_TRACK) nodal tracking; +* HENTRY(3): read-only type(L_MACROLIB) nodal macrolib. +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + TYPE(C_PTR) IPFLX,IPTRK,IPMAC + CHARACTER HSIGN*12,TEXT4*4,TEXT12*12,HSMG*131,BNDTL*12 + LOGICAL LNODF + INTEGER ISTATE(NSTATE) + REAL REALIR + DOUBLE PRECISION DBLLIR + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ITRIAL +*---- +* PARAMETER VALIDATION. +*---- + IF(NENTRY.NE.3) CALL XABORT('NSSF: 3 PARAMETERS EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('NSSF: LCM' + 1 //' OBJECT EXPECTED AT LHS.') + DO IEN=2,3 + IF((IENTRY(IEN).NE.1).AND.(IENTRY(IEN).NE.2)) CALL XABORT('NSS' + 1 //'F: LCM OBJECT EXPECTED AT LHS.') + IF(JENTRY(IEN).NE.2) CALL XABORT('NSSF: ENTRY IN READ-ONLY MOD' + 1 //'E EXPECTED.') + CALL LCMGTC(KENTRY(IEN),'SIGNATURE',12,HSIGN) + TEXT12=HENTRY(IEN) + IF(IEN.EQ.2) THEN + IF(HSIGN.NE.'L_TRACK') THEN + CALL XABORT('NSSF: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_TRACK EXPECTED.') + ENDIF + IPTRK=KENTRY(2) + CALL LCMPTC(KENTRY(1),'LINK.TRACK',12,HENTRY(2)) + ELSE IF(IEN.EQ.3) THEN + IF(HSIGN.NE.'L_MACROLIB') THEN + CALL XABORT('NSSF: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_MACROLIB EXPECTED.') + ENDIF + IPMAC=KENTRY(3) + CALL LCMPTC(KENTRY(1),'LINK.MACRO',12,HENTRY(3)) + ENDIF + ENDDO + CALL LCMGTC(IPTRK,'TRACK-TYPE',12,TEXT12) + IF(TEXT12.NE.'TRIVAC') CALL XABORT('NSSF: TRIVAC TRACKING EXPECT' + 1 //'ED.') +*---- +* PROCESS MACROLIB AND TRACKING. +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + NEL=ISTATE(1) + NUN=ISTATE(2) + NMIX=ISTATE(4) + NADI=ISTATE(33) + IGMAX=ISTATE(39) + ICHX=ISTATE(12) + IF((ICHX.LT.4).OR.(ICHX.GT.6)) THEN + CALL XABORT('NSSF: CMFD, NEM OR ANM DISCRETIZATION EXPECTED.') + ENDIF + IF(ISTATE(6).EQ.2) THEN + IDIM=1 + ELSE IF((ISTATE(6).EQ.5).AND.(ICHX.EQ.6)) THEN + IDIM=2 + ELSE IF((ISTATE(6).EQ.7).AND.(ICHX.EQ.6)) THEN + IDIM=3 + ELSE + CALL XABORT('NSSF: 1D SLAB/2D-3D CARTESIAN GEOMETRY EXPECTED.') + ENDIF + IF(ISTATE(38).NE.0) CALL XABORT('NSSF: LUMP OPTION FORBIDDEN.') + CALL LCMGET(IPMAC,'STATE-VECTOR',ISTATE) + NG=ISTATE(1) + IF(ISTATE(2).NE.NMIX) THEN + WRITE(HSMG,'(39HNSSF: INVALID NUMBER OF MIXTURES (GEOM=,I5, + 1 10H MACROLIB=,I5,2H).)') NMIX,ISTATE(2) + CALL XABORT(HSMG) + ENDIF +*---- +* CREATE OR RECOVER THE FLUX. +*---- + IPFLX=KENTRY(1) + IF(JENTRY(1).EQ.0) THEN + HSIGN='L_FLUX' + CALL LCMPTC(IPFLX,'SIGNATURE',12,HSIGN) + ELSE IF(JENTRY(1).EQ.1) THEN + CALL LCMGTC(IPFLX,'SIGNATURE',12,HSIGN) + TEXT12=HENTRY(IEN) + IF(HSIGN.NE.'L_FLUX') THEN + CALL XABORT('NSSF: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_FLUX EXPECTED.') + ENDIF + CALL LCMGET(IPFLX,'STATE-VECTOR',ISTATE) + IF(ISTATE(1).NE.NG) THEN + WRITE(HSMG,'(41HNSSF: INVALID NUMBER OF GROUPS (MACROLIB=,I5, + 1 6H FLUX=,I5,2H).)') NG,ISTATE(1) + CALL XABORT(HSMG) + ELSE IF(ISTATE(2).NE.NUN) THEN + WRITE(HSMG,'(43HNSSF: INVALID NUMBER OF UNKNOWNS (TRACKING=, + 1 I10,6H FLUX=,I10,2H).)') NUN,ISTATE(2) + CALL XABORT(HSMG) + ENDIF + ELSE + CALL XABORT('NSSF: FLUX IN CREATE OR MODIFICATION MODE EXPECTE' + 1 //'D.') + ENDIF +*--- +* READ DATA +*--- + ALLOCATE(ITRIAL(NMIX,NG)) + IPRINT=1 + ICL1=3 + ICL2=3 + MAXNOD=300 + MAXTHR=0 + MAXOUT=100 + EPSNOD=1.0E-6 + EPSTHR=1.0E-6 + EPSOUT=1.0E-5 + LNODF=.FALSE. + BB2=0.0 + BNDTL='quadratic' + NPASS=3 + ITRIAL(:,:)=1 + 10 CALL REDGET(ITYPLU,INTLIR,REALIR,TEXT4,DBLLIR) + IF(ITYPLU.EQ.10) GO TO 100 + 20 IF(ITYPLU.NE.3) CALL XABORT('NSSF: READ ERROR - CHARACTER VARIAB' + > //'LE EXPECTED') + IF(TEXT4.EQ.';') THEN + GO TO 100 + ELSE IF(TEXT4.EQ.'EDIT') THEN + CALL REDGET(ITYPLU,IPRINT,REALIR,TEXT4,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('NSSF: INTEGER DATA EXPECTED(1).') + ELSE IF((TEXT4.EQ.'VAR1').OR.(TEXT4.EQ.'ACCE')) THEN + CALL REDGET(ITYPLU,ICL1,REALIR,TEXT4,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('NSSF: INTEGER DATA EXPECTED(2).') + CALL REDGET(ITYPLU,ICL2,REALIR,TEXT4,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('NSSF: INTEGER DATA EXPECTED(3).') + ELSE IF(TEXT4=='ADI') THEN + CALL REDGET(ITYPLU,NADI,REALIR,TEXT4,DBLLIR) + IF(ITYPLU.NE.1) CALL XABORT('NSSF: INTEGER DATA EXPECTED(5).') + ELSE IF(TEXT4=='NUPD') THEN + ! maximum number of nodal correction iterations + 30 CALL REDGET(ITYPLU,INTLIR,REALIR,TEXT4,DBLLIR) + IF(ITYPLU.EQ.1) THEN + MAXNOD=INTLIR + CALL REDGET(ITYPLU,INTLIR,REALIR,TEXT4,DBLLIR) + IF(ITYPLU.EQ.1) THEN + NPASS=INTLIR + GO TO 30 + ENDIF + ELSE IF(ITYPLU.EQ.2) THEN + EPSNOD=REALIR + ELSE + GO TO 20 + ENDIF + GO TO 30 + ELSE IF(TEXT4=='EXTE') THEN + ! maximum number and convergence criterion of Keff iterations + 40 CALL REDGET(ITYPLU,INTLIR,REALIR,TEXT4,DBLLIR) + IF(ITYPLU.EQ.1) THEN + MAXOUT=INTLIR + ELSE IF(ITYPLU.EQ.2) THEN + EPSOUT=REALIR + ELSE + GO TO 20 + ENDIF + GO TO 40 + ELSE IF(TEXT4=='THER') THEN + ! maximum number and convergence criterion of thermal iterations + 50 CALL REDGET(ITYPLU,INTLIR,REALIR,TEXT4,DBLLIR) + IF(ITYPLU.EQ.1) THEN + MAXTHR=INTLIR + ELSE IF(ITYPLU.EQ.2) THEN + EPSTHR=REALIR + ELSE + GO TO 20 + ENDIF + GO TO 50 + ELSE IF(TEXT4.EQ.'NODF') THEN + LNODF=.TRUE. + ELSE IF(TEXT4=='LEAK') THEN + CALL REDGET(ITYPLU,INTLIR,REALIR,BNDTL,DBLLIR) + IF(ITYPLU/=3) CALL XABORT('NSSF: READ ERROR - CHARACTER VARIAB' + > //'LE EXPECTED') + IF((BNDTL.NE.'flat').AND.(BNDTL.NE.'quadratic')) THEN + CALL XABORT('NSSF: flat OR quadratic KEYWORD EXPECTED') + ENDIF + ELSE IF(TEXT4.EQ.'BUCK') THEN + CALL REDGET(ITYPLU,INTLIR,BB2,TEXT4,DBLLIR) + IF(ITYPLU.NE.2) CALL XABORT('NSSF: READ ERROR - REAL VARIABLE ' + > //'EXPECTED') + ELSE + CALL XABORT('NSSF: ILLEGAL KEYWORD '//TEXT4) + ENDIF + GO TO 10 + 100 IF(IGMAX.GT.NG) CALL XABORT('NSSF: IGMAX>NG.') + IF(IPRINT.GT.0) THEN + WRITE(6,'(/47H NSSF: number of transverse current iterations=, + > I3)') NPASS + ENDIF + IF(IGMAX.GT.0) ITRIAL(:NMIX,IGMAX:NG)=2 + CALL NSSDRV(IPTRK,IPMAC,IPFLX,ICHX,IDIM,NUN,NG,NEL,NMIX,ITRIAL, + > ICL1,ICL2,NADI,EPSNOD,MAXNOD,EPSTHR,MAXTHR,EPSOUT,MAXOUT,LNODF, + > BNDTL,NPASS,BB2,IPRINT) + DEALLOCATE(ITRIAL) + RETURN + END diff --git a/Trivac/src/NSSFL1.f b/Trivac/src/NSSFL1.f new file mode 100755 index 0000000..838d2a3 --- /dev/null +++ b/Trivac/src/NSSFL1.f @@ -0,0 +1,220 @@ +*DECK NSSFL1 + SUBROUTINE NSSFL1(IPFLX,NUN,NG,NEL,NMIX,NALB,ITRIAL,EPSOUT,MAXOUT, + 1 MAT,XX,IQFR,QFR,DIFF,SIGR,CHI,SIGF,SCAT,BETA,FD,IPRINT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Flux calculation for the nodal expansion method in Cartesian 1D +* geometry. +* +*Copyright: +* Copyright (C) 2021 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPFLX nodal flux. +* NUN number of unknowns (=4*NEL+1). +* NG number of energy groups. +* NEL number of nodes in the nodal calculation. +* NMIX number of mixtures in the nodal calculation. +* NALB number of physical albedos. +* ITRIAL type of expansion functions in the nodal calculation +* (=1: polynomial; =2: hyperbolic). +* EPSOUT convergence epsilon for the power method. +* MAXOUT maximum number of iterations for the power method. +* MAT material mixtures. +* XX mesh spacings. +* IQFR boundary condition information. +* QFR albedo function information. +* DIFF diffusion coefficients +* SIGR removal cross sections. +* CHI fission spectra. +* SIGF nu times fission cross section. +* SCAT scattering cross section. +* BETA albedos. +* FD discontinuity factors. +* IPRINT edition flag. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPFLX + INTEGER NUN,NG,NEL,NMIX,NALB,ITRIAL(NMIX,NG),MAXOUT,IPRINT, + 1 MAT(NEL),IQFR(6,NEL) + REAL EPSOUT,XX(NEL),QFR(6,NEL),DIFF(NMIX,NG),SIGR(NMIX,NG), + 1 CHI(NMIX,NG),SIGF(NMIX,NG),SCAT(NMIX,NG,NG),BETA(NALB,NG,NG), + 2 FD(NMIX,2,NG,NG) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) :: JPFLX + INTEGER :: DIM + REAL :: KEFF + REAL, ALLOCATABLE, DIMENSION(:) :: WORK + REAL, ALLOCATABLE, DIMENSION(:,:) :: EVECT,A,B,AI,A11,QFR2,FUNKN +* + ALB(X)=0.5*(1.0-X)/(1.0+X) +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(EVECT(NUN,NG)) + DIM=5*NEL + ALLOCATE(FUNKN(DIM,NG),A(DIM*NG,DIM*NG),B(DIM*NG,DIM*NG)) + ALLOCATE(WORK(NMIX),A11(DIM,DIM),QFR2(6,NEL)) +*---- +* INITIALIZATIONS +*---- + CALL LCMLEN(IPFLX,'FLUX',ILONG,ITYLCM) + IF(ILONG == 0) THEN + JPFLX=LCMLID(IPFLX,'FLUX',NG) + EVECT(:NUN,:NG)=1.0 + KEFF=1.0 + ELSE + JPFLX=LCMGID(IPFLX,'FLUX') + DO IG=1,NG + CALL LCMLEL(JPFLX,IG,ILONG,ITYLCM) + IF(ILONG /= NUN) CALL XABORT('NSSFL3: INVALID FLUX.') + CALL LCMGDL(JPFLX,IG,EVECT(1,IG)) + ENDDO + CALL LCMGET(IPFLX,'K-EFFECTIVE',KEFF) + ENDIF + FUNKN(:,:)=0.0 + DO IEL=1,NEL + IOF=(IEL-1)*5 + FUNKN(IOF+1,:)=EVECT(IEL,:) + ENDDO +*---- +* COMPUTE NODAL SOLUTION +*---- + DIM=5*NEL + A(:DIM*NG,:DIM*NG)=0.0 + B(:DIM*NG,:DIM*NG)=0.0 + QFR2(:6,:NEL)=0.0 + DO J=1,NG + IOF1=(J-1)*DIM + DO I=1,NG + DO IQW=1,2 + DO IEL=1,NEL + IALB=IQFR(IQW,IEL) + IF(IALB.GT.0) THEN + IF(IALB.GT.NALB) CALL XABORT('NSSFL1: BETA OVERFLOW.') + QFR2(IQW,IEL)=QFR(IQW,IEL)*ALB(BETA(IALB,I,J)) + ELSE IF(I == J) THEN + QFR2(IQW,IEL)=QFR(IQW,IEL) + ELSE + QFR2(IQW,IEL)=0.0 + ENDIF + ENDDO + ENDDO + DO IBM=1,NMIX + WORK(IBM)=CHI(IBM,I)*SIGF(IBM,J) + ENDDO + IOF2=(I-1)*DIM + IF(I == J) THEN + CALL NSS1TR(ITRIAL(1,J),NEL,NMIX,MAT,XX,IQFR,QFR2,DIFF(:,I), + 1 SIGR(:,I),FD(:,:,I,J),A11) + A(IOF1+1:IOF1+DIM,IOF1+1:IOF1+DIM)=A11(:,:) + ELSE + CALL NSS2TR(ITRIAL(1,J),NEL,NMIX,MAT,XX,IQFR,QFR2,DIFF(:,J), + 1 SIGR(:,J),SCAT(:,I,J),FD(:,:,I,J),A11) + A(IOF2+1:IOF2+DIM,IOF1+1:IOF1+DIM)=-A11(:,:) + ENDIF + CALL NSS3TR(ITRIAL(1,J),NEL,NMIX,MAT,XX,DIFF(:,J),SIGR(:,J), + 1 WORK(:),A11) + B(IOF2+1:IOF2+DIM,IOF1+1:IOF1+DIM)=A11(:,:) + ENDDO + ENDDO + DEALLOCATE(QFR2,A11,WORK) +*---- +* SOLVE EIGENVALUE MATRIX SYSTEM +*---- + CALL ALINV(DIM*NG,A,DIM*NG,IER) + IF(IER.NE.0) CALL XABORT('NSSFL1: SINGULAR MATRIX') + ALLOCATE(AI(DIM*NG,DIM*NG)) + AI(:DIM*NG,:DIM*NG)=MATMUL(A(:DIM*NG,:DIM*NG),B(:DIM*NG,:DIM*NG)) + CALL AL1EIG(DIM*NG,AI,EPSOUT,MAXOUT,ITER,FUNKN,KEFF,IPRINT) + IF(IPRINT.GT.0) WRITE(6,10) KEFF,ITER + DEALLOCATE(AI,B,A) +*---- +* NORMALIZE THE FLUX +*---- + FLMAX=0.0 + DO IG=1,NG + NUM1=0 + DO IEL=1,NEL + IF(ABS(FUNKN(NUM1+1,IG)).GT.ABS(FLMAX)) FLMAX=FUNKN(NUM1+1,IG) + NUM1=NUM1+5 + ENDDO + ENDDO + FUNKN(:,:)=FUNKN(:,:)/FLMAX +*---- +* COMPUTE INTERFACE FLUXES AND CURRENTS +*---- + IOF1=NEL + IOF2=2*NEL + IOF3=3*NEL + IF(IOF3+NEL+1.NE.NUN) CALL XABORT('NSSFL1: NUN ERROR.') + DO IG=1,NG + DO KEL=1,NEL + IBM=MAT(KEL) + IOF=(KEL-1)*5 + EVECT(KEL,IG)=FUNKN(IOF+1,IG) + EVECT(IOF1+KEL,IG)=FUNKN(IOF+1,IG)+0.5*(-FUNKN(IOF+2,IG)+ + 1 FUNKN(IOF+3,IG)) + EVECT(IOF2+KEL,IG)=FUNKN(IOF+1,IG)+0.5*(FUNKN(IOF+2,IG)+ + 1 FUNKN(IOF+3,IG)) + IF(ITRIAL(IBM,IG).EQ.1) THEN + EVECT(IOF3+KEL,IG)=-(DIFF(IBM,IG)/XX(KEL))*(FUNKN(IOF+2,IG)- + 1 3.0*FUNKN(IOF+3,IG)+FUNKN(IOF+4,IG)/2.0-FUNKN(IOF+5,IG)/5.0) + ELSE + ETA=XX(KEL)*SQRT(SIGR(IBM,IG)/DIFF(IBM,IG)) + ALP1=ETA*COSH(ETA/2.0)-2.0*SINH(ETA/2.0) + EVECT(IOF1+KEL,IG)=EVECT(IOF1+KEL,IG)-FUNKN(IOF+4,IG)* + 1 SINH(ETA/2.0)+FUNKN(IOF+5,IG)*ALP1/ETA + EVECT(IOF2+KEL,IG)=EVECT(IOF2+KEL,IG)+FUNKN(IOF+4,IG)* + 1 SINH(ETA/2.0)+FUNKN(IOF+5,IG)*ALP1/ETA + EVECT(IOF3+KEL,IG)=-(DIFF(IBM,IG)/XX(KEL))*(FUNKN(IOF+2,IG)- + 1 3.0*FUNKN(IOF+3,IG)+FUNKN(IOF+4,IG)*ETA*COSH(ETA/2.0)- + 2 FUNKN(IOF+5,IG)*ETA*SINH(ETA/2.0)) + ENDIF + ENDDO + IBM=MAT(NEL) + IOF=(NEL-1)*5 + IF(ITRIAL(IBM,IG).EQ.1) THEN + EVECT(IOF3+NEL+1,IG)=-(DIFF(IBM,IG)/XX(NEL))*(FUNKN(IOF+2,IG)+ + 1 3.0*FUNKN(IOF+3,IG)+FUNKN(IOF+4,IG)/2.0+FUNKN(IOF+5,IG)/5.0) + ELSE + ETA=XX(NEL)*SQRT(SIGR(IBM,IG)/DIFF(IBM,IG)) + EVECT(IOF3+NEL+1,IG)=-(DIFF(IBM,IG)/XX(NEL))*(FUNKN(IOF+2,IG)+ + 1 3.0*FUNKN(IOF+3,IG)+FUNKN(IOF+4,IG)*ETA*COSH(ETA/2.0)+ + 2 FUNKN(IOF+5,IG)*ETA*SINH(ETA/2.0)) + ENDIF + IF(IPRINT.GT.2) THEN + WRITE(6,'(/33H NSSFL1: AVERAGED FLUXES IN GROUP,I5)') IG + WRITE(6,'(1P,10e12.4)') (EVECT(I,IG),I=1,NEL) + WRITE(6,'(/39H NSSFL1: SURFACIC NET CURRENTS IN GROUP,I5)') IG + WRITE(6,'(1P,10e12.4)') (EVECT(IOF3+I,IG),I=1,NEL+1) + ENDIF + ENDDO +*---- +* SAVE SOLUTION +*---- + JPFLX=LCMGID(IPFLX,'FLUX') + DO IG=1,NG + CALL LCMPDL(JPFLX,IG,NUN,2,EVECT(1,IG)) + ENDDO + CALL LCMPUT(IPFLX,'K-EFFECTIVE',1,2,KEFF) + DEALLOCATE(FUNKN,EVECT) + RETURN +* + 10 FORMAT(14H NSSFL1: KEFF=,F11.8,12H OBTAINED IN,I5,11H ITERATIONS) + END diff --git a/Trivac/src/NSSFL2.f b/Trivac/src/NSSFL2.f new file mode 100755 index 0000000..bdefaad --- /dev/null +++ b/Trivac/src/NSSFL2.f @@ -0,0 +1,201 @@ +*DECK NSSFL2 + SUBROUTINE NSSFL2(IPFLX,NUN,NG,NEL,NMIX,NALB,EPSOUT,MAXOUT,MAT, + 1 XX,IQFR,QFR,DIFF,SIGR,CHI,SIGF,SCAT,BETA,FD,IPRINT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Flux calculation for the coarse mesh finite differences method in +* Cartesian 1D geometry. +* +*Copyright: +* Copyright (C) 2021 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPFLX nodal flux. +* NUN number of unknowns (=4*NEL+1). +* NG number of energy groups. +* NEL number of nodes in the nodal calculation. +* NMIX number of mixtures in the nodal calculation. +* NALB number of physical albedos. +* EPSOUT convergence epsilon for the power method. +* MAXOUT maximum number of iterations for the power method. +* MAT material mixtures. +* XX mesh spacings. +* IQFR boundary condition information. +* QFR albedo function information. +* DIFF diffusion coefficients +* SIGR removal cross sections. +* CHI fission spectra. +* SIGF nu times fission cross section. +* SCAT scattering cross section. +* BETA albedos. +* FD discontinuity factors. +* IPRINT edition flag. +* +*Parameters: output +* KEFF effective multiplication factor +* EVECT neutron flux +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPFLX + INTEGER NUN,NG,NEL,NMIX,NALB,MAXOUT,IPRINT,MAT(NEL),IQFR(6,NEL) + REAL EPSOUT,XX(NEL),QFR(6,NEL),DIFF(NMIX,NG),SIGR(NMIX,NG), + 1 CHI(NMIX,NG),SIGF(NMIX,NG),SCAT(NMIX,NG,NG),BETA(NALB,NG,NG), + 2 FD(NMIX,2,NG,NG) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) :: JPFLX + INTEGER :: DIM + REAL :: KEFF + REAL, ALLOCATABLE, DIMENSION(:,:) :: EVECT,A,B,AI,A11,QFR2,FUNKN +* + ALB(X)=0.5*(1.0-X)/(1.0+X) +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(EVECT(NUN,NG)) + DIM=3*NEL + ALLOCATE(FUNKN(DIM,NG),A(DIM*NG,DIM*NG),B(DIM*NG,DIM*NG)) + ALLOCATE(A11(DIM,DIM),QFR2(6,NEL)) +*---- +* INITIALIZATIONS +*---- + CALL LCMLEN(IPFLX,'FLUX',ILONG,ITYLCM) + IF(ILONG == 0) THEN + JPFLX=LCMLID(IPFLX,'FLUX',NG) + EVECT(:NUN,:NG)=1.0 + KEFF=1.0 + ELSE + JPFLX=LCMGID(IPFLX,'FLUX') + DO IG=1,NG + CALL LCMLEL(JPFLX,IG,ILONG,ITYLCM) + IF(ILONG /= NUN) CALL XABORT('NSSFL3: INVALID FLUX.') + CALL LCMGDL(JPFLX,IG,EVECT(1,IG)) + ENDDO + CALL LCMGET(IPFLX,'K-EFFECTIVE',KEFF) + ENDIF + FUNKN(:,:)=0.0 + DO IEL=1,NEL + IOF=(IEL-1)*3 + FUNKN(IOF+1,:)=EVECT(IEL,:) + ENDDO +*---- +* COMPUTE NODAL SOLUTION +*---- + A(:DIM*NG,:DIM*NG)=0.0 + B(:DIM*NG,:DIM*NG)=0.0 + QFR2(:6,:NEL)=0.0 + DO J=1,NG + IOF1=(J-1)*DIM + DO I=1,NG + DO IQW=1,2 + DO IEL=1,NEL + IALB=IQFR(IQW,IEL) + IF(IALB.GT.0) THEN + IF(IALB.GT.NALB) CALL XABORT('NSSFL2: BETA OVERFLOW.') + QFR2(IQW,IEL)=QFR(IQW,IEL)*ALB(BETA(IALB,I,J)) + ELSE IF(I == J) THEN + QFR2(IQW,IEL)=QFR(IQW,IEL) + ELSE + QFR2(IQW,IEL)=0.0 + ENDIF + ENDDO + ENDDO + IOF2=(I-1)*DIM + IF(I == J) THEN + CALL NSS4TR(NEL,NMIX,MAT,XX,IQFR,QFR2,DIFF(:,I),SIGR(:,I), + 1 FD(:,:,I,J),A11) + A(IOF1+1:IOF1+DIM,IOF1+1:IOF1+DIM)=A11(:,:) + ELSE + CALL NSS5TR(NEL,NMIX,MAT,IQFR,QFR2,SCAT(:,I,J),FD(:,:,I,J), + 1 A11) + A(IOF2+1:IOF2+DIM,IOF1+1:IOF1+DIM)=-A11(:,:) + ENDIF + B(IOF2+1:IOF2+DIM,IOF1+1:IOF1+DIM)=0.0 + NUM1=0 + DO IEL=1,NEL + IBM=MAT(IEL) + B(IOF2+NUM1+1,IOF1+NUM1+1)=CHI(IBM,I)*SIGF(IBM,J) + NUM1=NUM1+3 + ENDDO + ENDDO + ENDDO + DEALLOCATE(QFR2,A11) +*---- +* SOLVE EIGENVALUE MATRIX SYSTEM +*---- + CALL ALINV(DIM*NG,A,DIM*NG,IER) + IF(IER.NE.0) CALL XABORT('NSSFL2: SINGULAR MATRIX') + ALLOCATE(AI(DIM*NG,DIM*NG)) + AI(:DIM*NG,:DIM*NG)=MATMUL(A(:DIM*NG,:DIM*NG),B(:DIM*NG,:DIM*NG)) + CALL AL1EIG(DIM*NG,AI,EPSOUT,MAXOUT,ITER,FUNKN,KEFF,IPRINT) + IF(IPRINT.GT.0) WRITE(6,10) KEFF,ITER + DEALLOCATE(AI,B,A) +*---- +* NORMALIZE THE FLUX +*---- + FLMAX=0.0 + DO IG=1,NG + NUM1=0 + DO IEL=1,NEL + IF(ABS(FUNKN(NUM1+1,IG)).GT.ABS(FLMAX)) FLMAX=FUNKN(NUM1+1,IG) + NUM1=NUM1+3 + ENDDO + ENDDO + FUNKN(:,:)=FUNKN(:,:)/FLMAX +*---- +* COMPUTE INTERFACE FLUXES AND CURRENTS +*---- + IOF1=NEL + IOF2=2*NEL + IOF3=3*NEL + IF(IOF3+NEL+1.NE.NUN) CALL XABORT('NSSFL2: NUN ERROR.') + DO IG=1,NG + DO KEL=1,NEL + IBM=MAT(KEL) + IOF=(KEL-1)*3 + EVECT(KEL,IG)=FUNKN(IOF+1,IG) + EVECT(IOF1+KEL,IG)=FUNKN(IOF+1,IG)+0.5*(-FUNKN(IOF+2,IG)+ + 1 FUNKN(IOF+3,IG)) + EVECT(IOF2+KEL,IG)=FUNKN(IOF+1,IG)+0.5*(FUNKN(IOF+2,IG)+ + 1 FUNKN(IOF+3,IG)) + EVECT(IOF3+KEL,IG)=-(DIFF(IBM,IG)/XX(KEL))*(FUNKN(IOF+2,IG)- + 1 3.0*FUNKN(IOF+3,IG)) + ENDDO + IBM=MAT(NEL) + IOF=(NEL-1)*3 + EVECT(IOF3+NEL+1,IG)=-(DIFF(IBM,IG)/XX(NEL))*(FUNKN(IOF+2,IG)+ + 1 3.0*FUNKN(IOF+3,IG)) + IF(IPRINT.GT.2) THEN + WRITE(6,'(/33H NSSFL2: AVERAGED FLUXES IN GROUP,I5)') IG + WRITE(6,'(1P,10e12.4)') (EVECT(I,IG),I=1,NEL) + WRITE(6,'(/39H NSSFL2: SURFACIC NET CURRENTS IN GROUP,I5)') IG + WRITE(6,'(1P,10e12.4)') (EVECT(IOF3+I,IG),I=1,NEL+1) + ENDIF + ENDDO +*---- +* SAVE SOLUTION +*---- + JPFLX=LCMGID(IPFLX,'FLUX') + DO IG=1,NG + CALL LCMPDL(JPFLX,IG,NUN,2,EVECT(1,IG)) + ENDDO + CALL LCMPUT(IPFLX,'K-EFFECTIVE',1,2,KEFF) + DEALLOCATE(FUNKN,EVECT) + RETURN +* + 10 FORMAT(14H NSSFL2: KEFF=,F11.8,12H OBTAINED IN,I5,11H ITERATIONS) + END diff --git a/Trivac/src/NSSFL3.f b/Trivac/src/NSSFL3.f new file mode 100755 index 0000000..61ed29c --- /dev/null +++ b/Trivac/src/NSSFL3.f @@ -0,0 +1,305 @@ +*DECK NSSFL3 + SUBROUTINE NSSFL3(IPFLX,NUN,NG,NEL,NMIX,NALB,EPSNOD,MAXNOD, + 1 EPSOUT,MAXOUT,MAT,XX,XXX,IDL,IQFR,QFR,DIFF,SIGR,CHI,SIGF,SCAT, + 2 BETA,FD,IMPX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Flux calculation for the analytic nodal method in Cartesian 1D +* geometry using the nodal correction iteration strategy. +* +*Copyright: +* Copyright (C) 2022 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPFLX nodal flux. +* NUN number of unknowns per energy group (=4*NEL+1). +* NG number of energy groups. +* NEL number of nodes in the nodal calculation. +* NMIX number of mixtures in the nodal calculation. +* NALB number of physical albedos. +* EPSNOD nodal correction epsilon. +* MAXNOD maximum number of nodal correction iterations. +* EPSOUT convergence epsilon for the power method. +* MAXOUT maximum number of iterations for the power method. +* MAT material mixtures. +* XX mesh spacings. +* XXX Cartesian coordinates along the X axis. +* IDL position of averaged fluxes in unknown vector. +* IQFR boundary condition information. +* QFR albedo function information. +* DIFF diffusion coefficients +* SIGR removal cross sections. +* CHI fission spectra. +* SIGF nu times fission cross section. +* SCAT scattering cross section. +* BETA albedos. +* FD discontinuity factors. +* IMPX edition flag. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPFLX + INTEGER NUN,NG,NEL,NMIX,NALB,MAXNOD,MAXOUT,IMPX,MAT(NEL),IDL(NEL), + 1 IQFR(6,NEL) + REAL EPSNOD,EPSOUT,XX(NEL),XXX(NEL+1),QFR(6,NEL),DIFF(NMIX,NG), + 1 SIGR(NMIX,NG),CHI(NMIX,NG),SIGF(NMIX,NG),SCAT(NMIX,NG,NG), + 2 BETA(NALB,NG,NG),FD(NMIX,2,NG,NG) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPFLX + INTEGER, PARAMETER :: NY=1,NZ=1,NDIM=1 + REAL :: COEF(6),CODR(6),KEFF,KEFF_OLD +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: YY,ZZ,EVECT + REAL, ALLOCATABLE, DIMENSION(:,:) :: A,SAVG + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: QFR2,DRIFT +* + ALB(X)=0.5*(1.0-X)/(1.0+X) +*---- +* SCRATCH STORAGE ALLOCATION +*---- + N=NEL*NG + ALLOCATE(QFR2(6,NEL,NG),YY(NEL),ZZ(NEL),A(N,2*N),EVECT(N)) + ALLOCATE(DRIFT(6,NEL,NG),SAVG(NUN,NG)) +*---- +* ALBEDO PROCESSING +*---- + QFR2(:6,:NEL,:NG)=0.0 + DO IG=1,NG + DO IQW=1,2 + DO IEL=1,NEL + IALB=IQFR(IQW,IEL) + IF(IALB > 0) THEN + IF(IALB.GT.NALB) CALL XABORT('NSSFL3: BETA OVERFLOW.') + QFR2(IQW,IEL,IG)=QFR(IQW,IEL)*ALB(BETA(IALB,IG,IG)) + ELSE + QFR2(IQW,IEL,IG)=QFR(IQW,IEL) + ENDIF + ENDDO + ENDDO + ENDDO +*---- +* INITIALIZATIONS +*---- + KEFF_OLD=0.0 + KEFF=1.0 + CALL LCMLEN(IPFLX,'FLUX',ILONG,ITYLCM) + IF(ILONG == 0) THEN + JPFLX=LCMLID(IPFLX,'FLUX',NG) + SAVG(:NUN,:NG)=1.0 + ELSE + JPFLX=LCMGID(IPFLX,'FLUX') + DO IG=1,NG + CALL LCMLEL(JPFLX,IG,ILONG,ITYLCM) + IF(ILONG /= NUN) CALL XABORT('NSSFL3: INVALID FLUX.') + CALL LCMGDL(JPFLX,IG,SAVG(1,IG)) + ENDDO + CALL LCMGET(IPFLX,'K-EFFECTIVE',KEFF) + ENDIF + CALL LCMLEN(IPFLX,'DRIFT',ILONG,ITYLCM) + IF(ILONG == 0) THEN + JPFLX=LCMLID(IPFLX,'DRIFT',6*NEL) + DRIFT(:6,:NEL,:NG)=0.0 + ELSE + JPFLX=LCMGID(IPFLX,'DRIFT') + DO IG=1,NG + CALL LCMLEL(JPFLX,IG,ILONG,ITYLCM) + IF(ILONG /= 6*NEL) CALL XABORT('NSSFL3: INVALID DRIFT.') + CALL LCMGDL(JPFLX,IG,DRIFT(1,1,IG)) + ENDDO + ENDIF + DO IEL=1,NEL + DO IG=1,NG + EVECT((IG-1)*NEL+IEL)=SAVG(IEL,IG) + ENDDO + ENDDO +*---- +* NODAL CORRECTION LOOP +*---- + YY(:NEL)=1.0 + ZZ(:NEL)=1.0 + JTER=0 + DO WHILE((ABS(KEFF_OLD-KEFF) >= EPSNOD).OR.(JTER==0)) + JTER=JTER+1 + IF(IMPX > 0) THEN + WRITE(6,'(36H NSSFL3: Nodal correction iteration=,I5)') + 1 JTER + ENDIF + IF(JTER > MAXNOD) THEN + WRITE(6,'(/22H ACCURACY AT ITERATION,I4,2H =,1P,E12.5)') + 1 JTER,ABS(KEFF_OLD-KEFF) + CALL XABORT('NSSFL3: NODAL ITERATION FAILURE') + ENDIF + ! + ! set CMFD matrix for x-directed couplings + A(:N,:2*N)=0.D0 + IOF=0 + DO IG=1,NG + DO IEL=1,NEL + IBM=MAT(IEL) + IF(IBM <= 0) CYCLE + KEL=IDL(IEL) + IF(KEL == 0) CYCLE + VOL0=XX(IEL) + CALL NSSCO(NX,NY,NZ,NMIX,IEL,1,1,MAT,XX,YY,ZZ,DIFF(1,IG), + > IQFR(1,IEL),QFR2(1,IEL,IG),COEF) + COEF(1:2)=COEF(1:2)*VOL0/XX(IEL) + CODR(1:2)=DRIFT(1:2,IEL,IG)*VOL0/XX(IEL) + KEL2=0 + KK1=IQFR(1,IEL) + IF(KK1 == -4) THEN + KEL2=IDL(NX) + ELSE IF(KK1 == 0) THEN + KEL2=IDL(IEL-1) + ENDIF + IF(KEL2 /= 0) THEN + A(IOF+KEL,IOF+KEL2)=A(IOF+KEL,IOF+KEL2)-COEF(1)+CODR(1) + ENDIF + KEL2=0 + KK2=IQFR(2,IEL) + IF(KK2 == -4) THEN + KEL2=IDL(1) + ELSE IF(KK2 == 0) THEN + KEL2=IDL(IEL+1) + ENDIF + IF(KEL2 /= 0) THEN + A(IOF+KEL,IOF+KEL2)=A(IOF+KEL,IOF+KEL2)-COEF(2)-CODR(2) + ENDIF + A(IOF+KEL,IOF+KEL)=A(IOF+KEL,IOF+KEL)+COEF(1)+CODR(1)+ + > COEF(2)-CODR(2) + A(IOF+KEL,IOF+KEL)=A(IOF+KEL,IOF+KEL)+SIGR(IBM,IG)*VOL0 + ENDDO + JOF=0 + DO JG=1,NG ! IG <-- JG + DO IEL=1,NEL + IBM=MAT(IEL) + IF(IBM <= 0) CYCLE + KEL=IDL(IEL) + IF(KEL == 0) CYCLE + IF(IG /= JG) A(IOF+KEL,JOF+KEL)=-XX(IEL)*SCAT(IBM,IG,JG) + A(IOF+KEL,N+JOF+KEL)=XX(IEL)*CHI(IBM,IG)*SIGF(IBM,JG) + ENDDO + JOF=JOF+NEL + ENDDO + IOF=IOF+NEL + ENDDO + CALL ALSB(N,N,A,IER,N) + IF(IER /= 0) CALL XABORT('NSSFL3: SINGULAR MATRIX.') + ! + ! CMFD power iteration (use double precision) + DELTA=ABS(KEFF_OLD-KEFF) + KEFF_OLD=KEFF + CALL AL1EIG(N,A(1,N+1),EPSOUT,MAXOUT,ITER,EVECT,KEFF,IMPX) +*---- +* FLUX NORMALIZATION +*---- + FMAX=MAXVAL(EVECT(:N)) + EVECT(:N)=EVECT(:N)/FMAX + IF(IMPX > 0) WRITE(6,10) JTER,KEFF,ITER,DELTA + IF(IMPX > 2) THEN + WRITE(6,'(1X,A)') 'NSSFL3: EVECT=' + IOF=0 + DO IG=1,NG + WRITE(6,'(1X,1P,14E12.4)') EVECT(IOF+1:IOF+NEL) + IOF=IOF+NEL + ENDDO + ENDIF + ! + ! begin construct SAVG + IF(NUN /= 4*NEL+1) CALL XABORT('NSSFL3: INVALID NUN.') + SAVG(:NUN,:NG)=0.0 + DO IEL=1,NEL + DO IG=1,NG + SAVG(IEL,IG)=EVECT((IG-1)*NEL+IEL) + ENDDO + ENDDO + ! + ! one- and two-node anm relations + CALL NSSANM1(NEL,NG,NMIX,IQFR,QFR2,MAT,XXX,KEFF,DIFF,SIGR,CHI, + 1 SIGF,SCAT,FD,SAVG) + ! + ! compute new drift coefficients + DO IG=1,NG + DO IEL=1,NEL + IBM=MAT(IEL) + IF(IBM == 0) CYCLE + CALL NSSCO(NX,NY,NZ,NMIX,IEL,1,1,MAT,XX,YY,ZZ,DIFF(1,IG), + 1 IQFR(1,IEL),QFR2(1,IEL,IG),COEF) + IF(IEL == 1) THEN + DRIFT(1,IEL,IG)=-(SAVG(3*NEL+IEL,IG)+COEF(1)*SAVG(IEL,IG)) + 1 /SAVG(IEL,IG) + DRIFT(2,IEL,IG)=-(SAVG(3*NEL+IEL+1,IG)+COEF(2)* + 1 (SAVG(IEL+1,IG)-SAVG(IEL,IG)))/(SAVG(IEL+1,IG)+ + 2 SAVG(IEL,IG)) + ELSE IF(IEL < NEL) THEN + DRIFT(1,IEL,IG)=-(SAVG(3*NEL+IEL,IG)+COEF(1)*(SAVG(IEL,IG) + 1 -SAVG(IEL-1,IG)))/(SAVG(IEL,IG)+SAVG(IEL-1,IG)) + DRIFT(2,IEL,IG)=-(SAVG(3*NEL+IEL+1,IG)+COEF(2)* + 1 (SAVG(IEL+1,IG)-SAVG(IEL,IG)))/(SAVG(IEL+1,IG)+ + 2 SAVG(IEL,IG)) + ELSE + DRIFT(1,IEL,IG)=-(SAVG(3*NEL+IEL,IG)+COEF(1)*(SAVG(IEL,IG) + 1 -SAVG(IEL-1,IG)))/(SAVG(IEL,IG)+SAVG(IEL-1,IG)) + DRIFT(2,IEL,IG)=-(SAVG(3*NEL+IEL+1,IG)-COEF(2)* + 1 SAVG(IEL,IG))/SAVG(IEL,IG) + ENDIF + ENDDO + ENDDO + ENDDO +*---- +* END OF NODAL CORRECTION LOOP +*---- + IF(IMPX.GT.0) WRITE(6,20) KEFF,JTER + IF(IMPX > 2) THEN + WRITE(6,'(/21H NSSFL3: UNKNOWNS----)') + DO IG=1,NG + WRITE(6,'(14H NSSFL3: SAVG(,I4,2H)=)') IG + WRITE(6,'(1P,12E12.4)') SAVG(:NEL,IG) + WRITE(6,'(19H X-BOUNDARY FLUXES:)') + WRITE(6,'(1P,12E12.4)') SAVG(NEL+1:2*NEL,IG) + WRITE(6,'(1P,12E12.4)') SAVG(2*NEL+1:3*NEL,IG) + WRITE(6,'(12H X-CURRENTS:)') + WRITE(6,'(1P,12E12.4)') SAVG(3*NEL+1:,IG) + WRITE(6,'(5H ----)') + ENDDO + ENDIF +*---- +* SAVE SOLUTION +*---- + JPFLX=LCMGID(IPFLX,'FLUX') + DO IG=1,NG + CALL LCMPDL(JPFLX,IG,NUN,2,SAVG(1,IG)) + ENDDO + JPFLX=LCMGID(IPFLX,'DRIFT') + DO IG=1,NG + CALL LCMPDL(JPFLX,IG,6*NEL,2,DRIFT(1,1,IG)) + ENDDO + CALL LCMPUT(IPFLX,'K-EFFECTIVE',1,2,KEFF) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SAVG,DRIFT) + DEALLOCATE(EVECT,A,ZZ,YY,QFR2) + RETURN +* + 10 FORMAT(14H NSSFL3: JTER=,I4,11H CMFD KEFF=,1P E13.6, + 1 12H OBTAINED IN,I4,28H CMFD ITERATIONS WITH ERROR=, + 2 1P,E11.4,1H.) + 20 FORMAT(18H NSSFL3: ANM KEFF=,F11.8,12H OBTAINED IN,I5, + 1 28H NODAL CORRECTION ITERATIONS) + END diff --git a/Trivac/src/NSSFL4.f b/Trivac/src/NSSFL4.f new file mode 100755 index 0000000..bdf4e73 --- /dev/null +++ b/Trivac/src/NSSFL4.f @@ -0,0 +1,357 @@ +*DECK NSSFL4 + SUBROUTINE NSSFL4(IPFLX,NUN,NG,NX,NY,LL4F,LL4X,LL4Y,NMIX,NALB, + > ICL1,ICL2,NADI,EPSNOD,MAXNOD,EPSTHR,MAXTHR,EPSOUT,MAXOUT,MAT, + > XX,YY,XXX,YYY,IDL,VOL,KN,IQFR,QFR,DIFF,SIGR,CHI,SIGF,SCAT,BETA, + > FD,BNDTL,NPASS,MUX,MUY,IMAX,IMAY,IPY,IMPX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Flux calculation for the analytic nodal method in Cartesian 2D +* geometry using the nodal correction iteration strategy. +* +*Copyright: +* Copyright (C) 2022 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPFLX nodal flux. +* NUN number of unknowns per energy group. +* NG number of energy groups. +* NX number of nodes in the X direction. +* NY number of nodes in the Y direction. +* LL4F number of nodal flux unknowns. +* LL4X number of nodal X-directed net currents unknowns. +* LL4Y number of nodal Y-directed net currents unknowns. +* NMIX number of mixtures in the nodal calculation. +* NALB number of physical albedos. +* ICL1 number of free iterations in one cycle of the inverse power +* method (used for thermal iterations). +* ICL2 number of accelerated iterations in one cycle. +* NADI number of inner ADI iterations. +* EPSNOD nodal correction epsilon. +* MAXNOD maximum number of nodal correction iterations. +* EPSTHR thermal iteration epsilon. +* MAXTHR maximum number of thermal iterations. +* EPSOUT convergence epsilon for the power method. +* MAXOUT maximum number of iterations for the power method. +* MAT material mixtures. +* XX mesh spacings in the X direction. +* YY mesh spacings in the Y direction. +* XXX Cartesian coordinates along the X axis. +* YYY Cartesian coordinates along the Y axis. +* IDL position of averaged fluxes in unknown vector. +* VOL node volumes. +* KN node-ordered interface net current unknown list. +* IQFR boundary condition information. +* QFR albedo function information. +* DIFF diffusion coefficients +* SIGR removal cross sections. +* CHI fission spectra. +* SIGF nu times fission cross section. +* SCAT scattering cross section. +* BETA albedos. +* FD discontinuity factors. +* BNDTL set to 'flat' or 'quadratic'. +* NPASS number of transverse current iterations. +* MUX X-oriented compressed storage mode indices. +* MUY Y-oriented compressed storage mode indices. +* IMAX X-oriented position of each first non-zero column element. +* IMAY Y-oriented position of each first non-zero column element. +* IPY Y-oriented permutation matrices. +* IMPX edition flag. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPFLX + INTEGER NUN,NG,NX,NY,LL4F,LL4X,LL4Y,NMIX,NALB,ICL1,ICL2,NADI, + 1 MAXNOD,MAXTHR,MAXOUT,IMPX,MAT(NX*NY),IDL(NX*NY),KN(6,NX,NY), + 2 NPASS,IQFR(6,NX,NY),MUX(LL4F),MUY(LL4F),IMAX(LL4F),IMAY(LL4F), + 3 IPY(LL4F) + REAL EPSNOD,EPSTHR,EPSOUT,XX(NX*NY),YY(NX*NY),XXX(NX+1),YYY(NY+1), + 1 VOL(NX*NY),QFR(6,NX*NY),DIFF(NMIX,NG),SIGR(NMIX,NG),CHI(NMIX,NG), + 2 SIGF(NMIX,NG),SCAT(NMIX,NG,NG),BETA(NALB,NG,NG),FD(NMIX,4,NG,NG) + CHARACTER(LEN=12) :: BNDTL +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPFLX + INTEGER, PARAMETER :: NZ=1,NDIM=2 + INTEGER :: MUZ(1),IMAZ(1),IPZ(1) + REAL :: COEF(6),KEFF,KEFF_OLD +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: ZZ,EVECT + REAL, ALLOCATABLE, DIMENSION(:,:) :: A11X,A11Y,A11Z,SAVG + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: QFR2,DRIFT +* + ALB(X)=0.5*(1.0-X)/(1.0+X) +*---- +* SCRATCH STORAGE ALLOCATION +*---- + NEL=NX*NY + N=LL4F*NG + ALLOCATE(QFR2(6,NEL,NG),ZZ(NEL),EVECT(N)) + ALLOCATE(DRIFT(6,NEL,NG),SAVG(NUN,NG)) +*---- +* ALBEDO PROCESSING +*---- + QFR2(:6,:NEL,:NG)=0.0 + DO IG=1,NG + DO IQW=1,4 + DO I=1,NX + DO J=1,NY + IEL=(J-1)*NX+I + IALB=IQFR(IQW,I,J) + IF(IALB > 0) THEN + IF(IALB.GT.NALB) CALL XABORT('NSSFL4: BETA OVERFLOW.') + QFR2(IQW,IEL,IG)=QFR(IQW,IEL)*ALB(BETA(IALB,IG,IG)) + ELSE + QFR2(IQW,IEL,IG)=QFR(IQW,IEL) + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO +*---- +* INITIALIZATIONS +*---- + KEFF_OLD=0.0 + KEFF=1.0 + CALL LCMLEN(IPFLX,'FLUX',ILONG,ITYLCM) + IF(ILONG == 0) THEN + JPFLX=LCMLID(IPFLX,'FLUX',NG) + SAVG(:NUN,:NG)=1.0 + ELSE + JPFLX=LCMGID(IPFLX,'FLUX') + DO IG=1,NG + CALL LCMLEL(JPFLX,IG,ILONG,ITYLCM) + IF(ILONG /= NUN) CALL XABORT('NSSFL4: INVALID FLUX.') + CALL LCMGDL(JPFLX,IG,SAVG(1,IG)) + ENDDO + CALL LCMGET(IPFLX,'K-EFFECTIVE',KEFF) + ENDIF + CALL LCMLEN(IPFLX,'DRIFT',ILONG,ITYLCM) + IF(ILONG == 0) THEN + JPFLX=LCMLID(IPFLX,'DRIFT',6*NEL) + DRIFT(:6,:NEL,:NG)=0.0 + ELSE + JPFLX=LCMGID(IPFLX,'DRIFT') + DO IG=1,NG + CALL LCMLEL(JPFLX,IG,ILONG,ITYLCM) + IF(ILONG /= 6*NEL) CALL XABORT('NSSFL4: INVALID DRIFT.') + CALL LCMGDL(JPFLX,IG,DRIFT(1,1,IG)) + ENDDO + ENDIF + DO IEL=1,LL4F + DO IG=1,NG + EVECT((IG-1)*LL4F+IEL)=SAVG(IEL,IG) + ENDDO + ENDDO +*---- +* NODAL CORRECTION LOOP +*---- + NMAX=IMAX(LL4F) + NMAY=IMAY(LL4F) + NMAZ=1 + ALLOCATE(A11X(NMAX,NG),A11Y(NMAY,NG),A11Z(NMAZ,NG)) + ZZ(:NEL)=1.0 + MUZ(1)=0 + IMAZ(1)=0 + IPZ(1)=0 + JTER=0 + SAVG(:NUN,:NG)=0.0 + IOFY=5*LL4F+LL4X + DO WHILE((ABS(KEFF_OLD-KEFF) >= EPSNOD).OR.(JTER==0)) + JTER=JTER+1 + IF(IMPX.GT.0) THEN + WRITE(6,'(36H NSSFL4: Nodal correction iteration=,I5)') + > JTER + ENDIF + IF(JTER > MAXNOD) THEN + WRITE(6,'(/22H ACCURACY AT ITERATION,I4,2H =,1P,E12.5)') + > JTER,ABS(KEFF_OLD-KEFF) + CALL XABORT('NSSFL4: NODAL ITERATION FAILURE') + ENDIF + ! + ! set coarse mesh finite difference matrix + IOF=0 + DO IG=1,NG + CALL NSSMXYZ(LL4F,NDIM,NX,NY,NZ,NMIX,MAT,XX,YY,ZZ,IDL,VOL, + > IQFR,QFR2(1,1,IG),DIFF(1,IG),DRIFT(1,1,IG),SIGR(1,IG), + > MUX,MUY,MUZ,IMAX,IMAY,IMAZ,IPY,IPZ,A11X(1,IG),A11Y(1,IG), + > A11Z(1,IG)) + ENDDO + ! + ! CMFD power iteration + DELTA=ABS(KEFF_OLD-KEFF) + KEFF_OLD=KEFF + CALL NSSEIG(NMAX,NMAY,NMAZ,LL4F,NDIM,NEL,NMIX,NG,MAT,IDL,VOL, + > MUX,MUY,MUZ,IMAX,IMAY,IMAZ,IPY,IPZ,CHI,SIGF,SCAT,A11X,A11Y,A11Z, + > EPSTHR,MAXTHR,NADI,EPSOUT,MAXOUT,ICL1,ICL2,ITER,EVECT,KEFF,IMPX) + IF(IMPX > 0) WRITE(6,10) JTER,KEFF,ITER,DELTA + IF(IMPX > 2) THEN + WRITE(6,'(1X,A)') 'NSSFL4: EVECT=' + IOF=0 + DO IG=1,NG + WRITE(6,'(1X,1P,14E12.4)') EVECT(IOF+1:IOF+LL4F) + IOF=IOF+LL4F + ENDDO + ENDIF + ! + ! begin construct SAVG + IF(NUN /= IOFY+LL4Y) CALL XABORT('NSSFL4: INVALID NUN.') + DO IND1=1,LL4F + DO IG=1,NG + SAVG(IND1,IG)=EVECT((IG-1)*LL4F+IND1) + ENDDO + ENDDO + ! + ! one- and two-node anm relations + CALL NSSANM2(NUN,NX,NY,LL4F,LL4X,NG,BNDTL,NPASS,NMIX,IDL,KN, + > IQFR,QFR2,MAT,XXX,YYY,KEFF,DIFF,SIGR,CHI,SIGF,SCAT,FD,SAVG) + ! + ! compute new drift coefficients + DRIFT(:6,:NEL,:NG)=0.0 + DO IG=1,NG + DO J=1,NY + DO I=1,NX + IEL=(J-1)*NX+I + IND1=IDL(IEL) + IF(IND1 == 0) CYCLE + KK1=IQFR(1,I,J) + KK2=IQFR(2,I,J) + JXM=KN(1,I,J) ; JXP=KN(2,I,J) + JYM=KN(3,I,J) ; JYP=KN(4,I,J) + CALL NSSCO(NX,NY,NZ,NMIX,I,J,1,MAT,XX,YY,ZZ,DIFF(1,IG), + > IQFR(1,I,J),QFR2(1,IEL,IG),COEF) + IF((KK1 < 0).AND.(KK2 < 0)) THEN + DRIFT(1,IEL,IG)=-(SAVG(5*LL4F+JXM,IG)+COEF(1)* + > SAVG(IND1,IG))/SAVG(IND1,IG) + DRIFT(2,IEL,IG)=-(SAVG(5*LL4F+JXP,IG)-COEF(2)* + > SAVG(IND1,IG))/SAVG(IND1,IG) + ELSE IF(KK1 < 0) THEN + DRIFT(1,IEL,IG)=-(SAVG(5*LL4F+JXM,IG)+COEF(1)* + > SAVG(IND1,IG))/SAVG(IND1,IG) + IND3=IDL((J-1)*NX+I+1) + IF(IND3 /= 0) DRIFT(2,IEL,IG)=-(SAVG(5*LL4F+JXP,IG)+ + > COEF(2)*(SAVG(IND3,IG)-SAVG(IND1,IG)))/(SAVG(IND3,IG)+ + > SAVG(IND1,IG)) + ELSE IF(KK2 < 0) THEN + IND2=IDL((J-1)*NX+I-1) + IF(IND2 /= 0) DRIFT(1,IEL,IG)=-(SAVG(5*LL4F+JXM,IG)+ + > COEF(1)*(SAVG(IND1,IG)-SAVG(IND2,IG)))/(SAVG(IND1,IG)+ + > SAVG(IND2,IG)) + DRIFT(2,IEL,IG)=-(SAVG(5*LL4F+JXP,IG)-COEF(2)* + > SAVG(IND1,IG))/SAVG(IND1,IG) + ELSE + IND2=IDL((J-1)*NX+I-1) + IND3=IDL((J-1)*NX+I+1) + IF(IND2 /= 0) DRIFT(1,IEL,IG)=-(SAVG(5*LL4F+JXM,IG)+ + > COEF(1)*(SAVG(IND1,IG)-SAVG(IND2,IG)))/(SAVG(IND1,IG)+ + > SAVG(IND2,IG)) + IF(IND3 /= 0) DRIFT(2,IEL,IG)=-(SAVG(5*LL4F+JXP,IG)+ + > COEF(2)*(SAVG(IND3,IG)-SAVG(IND1,IG)))/(SAVG(IND3,IG)+ + > SAVG(IND1,IG)) + ENDIF + KK3=IQFR(3,I,J) + KK4=IQFR(4,I,J) + IF((KK3 < 0).AND.(KK4 < 0)) THEN + DRIFT(3,IEL,IG)=-(SAVG(IOFY+JYM,IG)+COEF(3)* + > SAVG(IND1,IG))/SAVG(IND1,IG) + DRIFT(4,IEL,IG)=-(SAVG(IOFY+JYP,IG)-COEF(4)* + > SAVG(IND1,IG))/SAVG(IND1,IG) + ELSE IF(KK3 < 0) THEN + DRIFT(3,IEL,IG)=-(SAVG(IOFY+JYM,IG)+COEF(3)* + > SAVG(IND1,IG))/SAVG(IND1,IG) + IND3=IDL(J*NX+I) + IF(IND3 /= 0) DRIFT(4,IEL,IG)=-(SAVG(IOFY+JYP,IG)+ + > COEF(4)*(SAVG(IND3,IG)-SAVG(IND1,IG)))/(SAVG(IND3,IG)+ + > SAVG(IND1,IG)) + ELSE IF(KK4 < 0) THEN + IND2=IDL((J-2)*NX+I) + IF(IND2 /= 0) DRIFT(3,IEL,IG)=-(SAVG(IOFY+JYM,IG)+ + > COEF(3)*(SAVG(IND1,IG)-SAVG(IND2,IG)))/(SAVG(IND1,IG)+ + > SAVG(IND2,IG)) + DRIFT(4,IEL,IG)=-(SAVG(IOFY+JYP,IG)-COEF(4)* + > SAVG(IND1,IG))/SAVG(IND1,IG) + ELSE + IND2=IDL((J-2)*NX+I) + IND3=IDL(J*NX+I) + IF(IND2 /= 0) DRIFT(3,IEL,IG)=-(SAVG(IOFY+JYM,IG)+ + > COEF(3)*(SAVG(IND1,IG)-SAVG(IND2,IG)))/(SAVG(IND1,IG)+ + > SAVG(IND2,IG)) + IF(IND3 /= 0) DRIFT(4,IEL,IG)=-(SAVG(IOFY+JYP,IG)+ + > COEF(4)*(SAVG(IND3,IG)-SAVG(IND1,IG)))/(SAVG(IND3,IG)+ + > SAVG(IND1,IG)) + ENDIF + ENDDO + ENDDO + ENDDO + IF(IMPX > 5) THEN + DO IG=1,NG + WRITE(6,'(28H NSSFL4: DRIFT COEFFICIENTS(,I5,2H):)') IG + DO IEL=1,NX*NY + WRITE(6,'(1P,I7,4E12.4)') IEL,DRIFT(:4,IEL,IG) + ENDDO + ENDDO + ENDIF + ENDDO + DEALLOCATE(A11Z,A11Y,A11X) +*---- +* END OF NODAL CORRECTION LOOP +*---- + IF(IMPX.GT.0) WRITE(6,20) KEFF,JTER + IF(IMPX > 2) THEN + WRITE(6,'(/21H NSSFL4: UNKNOWNS----)') + DO IG=1,NG + WRITE(6,'(14H NSSFL4: SAVG(,I4,2H)=)') IG + WRITE(6,'(1P,12E12.4)') SAVG(:LL4F,IG) + WRITE(6,'(19H X-BOUNDARY FLUXES:)') + WRITE(6,'(1P,12E12.4)') SAVG(LL4F+1:2*LL4F,IG) + WRITE(6,'(1P,12E12.4)') SAVG(2*LL4F+1:3*LL4F,IG) + WRITE(6,'(19H Y-BOUNDARY FLUXES:)') + WRITE(6,'(1P,12E12.4)') SAVG(3*LL4F+1:4*LL4F,IG) + WRITE(6,'(1P,12E12.4)') SAVG(4*LL4F+1:5*LL4F,IG) + WRITE(6,'(12H X-CURRENTS:)') + WRITE(6,'(1P,12E12.4)') SAVG(5*LL4F+1:IOFY,IG) + WRITE(6,'(12H Y-CURRENTS:)') + WRITE(6,'(1P,12E12.4)') SAVG(IOFY+1:NUN,IG) + WRITE(6,'(5H ----)') + ENDDO + ENDIF +*---- +* SAVE SOLUTION +*---- + JPFLX=LCMGID(IPFLX,'FLUX') + DO IG=1,NG + CALL LCMPDL(JPFLX,IG,NUN,2,SAVG(1,IG)) + ENDDO + JPFLX=LCMGID(IPFLX,'DRIFT') + DO IG=1,NG + CALL LCMPDL(JPFLX,IG,6*NEL,2,DRIFT(1,1,IG)) + ENDDO + CALL LCMPUT(IPFLX,'K-EFFECTIVE',1,2,KEFF) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SAVG,DRIFT) + DEALLOCATE(EVECT,ZZ,QFR2) + RETURN +* + 10 FORMAT(14H NSSFL4: JTER=,I4,11H CMFD KEFF=,1P E13.6, + 1 12H OBTAINED IN,I4,28H CMFD ITERATIONS WITH ERROR=, + 2 1P,E11.4,1H.) + 20 FORMAT(18H NSSFL4: ANM KEFF=,F11.8,12H OBTAINED IN,I5, + 1 11H ITERATIONS) + END diff --git a/Trivac/src/NSSFL5.f b/Trivac/src/NSSFL5.f new file mode 100755 index 0000000..f6be4f3 --- /dev/null +++ b/Trivac/src/NSSFL5.f @@ -0,0 +1,404 @@ +*DECK NSSFL5 + SUBROUTINE NSSFL5(IPFLX,NUN,NG,NX,NY,NZ,LL4F,LL4X,LL4Y,LL4Z,NMIX, + > NALB,ICL1,ICL2,NADI,EPSNOD,MAXNOD,EPSTHR,MAXTHR,EPSOUT,MAXOUT, + > MAT,XX,YY,ZZ,XXX,YYY,ZZZ,IDL,VOL,KN,IQFR,QFR,DIFF,SIGR,CHI,SIGF, + > SCAT,BETA,FD,BNDTL,NPASS,MUX,MUY,MUZ,IMAX,IMAY,IMAZ,IPY,IPZ,IMPX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Flux calculation for the analytic nodal method in Cartesian 3D +* geometry using the nodal correction iteration strategy. +* +*Copyright: +* Copyright (C) 2022 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPFLX nodal flux. +* NUN number of unknowns per energy group. +* NG number of energy groups. +* NX number of nodes in the X direction. +* NY number of nodes in the Y direction. +* NZ number of nodes in the Z direction. +* LL4F number of nodal flux unknowns. +* LL4X number of nodal X-directed net currents unknowns. +* LL4Y number of nodal Y-directed net currents unknowns. +* LL4Z number of nodal Z-directed net currents unknowns. +* NMIX number of mixtures in the nodal calculation. +* NALB number of physical albedos. +* ICL1 number of free iterations in one cycle of the inverse power +* method (used for thermal iterations). +* ICL2 number of accelerated iterations in one cycle. +* NADI number of inner ADI iterations. +* EPSNOD nodal correction epsilon. +* MAXNOD maximum number of nodal correction iterations. +* EPSTHR thermal iteration epsilon. +* MAXTHR maximum number of thermal iterations. +* EPSOUT convergence epsilon for the power method. +* MAXOUT maximum number of iterations for the power method. +* MAT material mixtures. +* XX mesh spacings in the X direction. +* YY mesh spacings in the Y direction. +* ZZ mesh spacings in the Z direction. +* XXX Cartesian coordinates along the X axis. +* YYY Cartesian coordinates along the Y axis. +* ZZZ Cartesian coordinates along the Z axis. +* IDL position of averaged fluxes in unknown vector. +* VOL node volumes. +* KN node-ordered interface net current unknown list. +* IQFR boundary condition information. +* QFR albedo function information. +* DIFF diffusion coefficients +* SIGR removal cross sections. +* CHI fission spectra. +* SIGF nu times fission cross section. +* SCAT scattering cross section. +* BETA albedos. +* FD discontinuity factors. +* BNDTL set to 'flat' or 'quadratic'. +* NPASS number of transverse current iterations. +* MUX X-oriented compressed storage mode indices. +* MUY Y-oriented compressed storage mode indices. +* MUZ Z-oriented compressed storage mode indices. +* IMAX X-oriented position of each first non-zero column element. +* IMAY Y-oriented position of each first non-zero column element. +* IMAZ Z-oriented position of each first non-zero column element. +* IPY Y-oriented permutation matrices. +* IPZ Z-oriented permutation matrices. +* IMPX edition flag. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPFLX + INTEGER NUN,NG,NX,NY,LL4F,LL4X,LL4Y,NMIX,NALB,ICL1,ICL2, + 1 NADI,MAXNOD,MAXTHR,MAXOUT,IMPX,MAT(NX*NY*NZ),IDL(NX*NY*NZ), + 2 KN(6,NX,NY,NZ),IQFR(6,NX,NY,NZ),NPASS,MUX(LL4F),MUY(LL4F), + 3 MUZ(LL4F),IMAX(LL4F),IMAY(LL4F),IMAZ(LL4F),IPY(LL4F),IPZ(LL4F) + REAL EPSNOD,EPSTHR,EPSOUT,XX(NX*NY*NZ),YY(NX*NY*NZ),ZZ(NX*NY*NZ), + 1 XXX(NX+1),YYY(NY+1),ZZZ(NZ+1),VOL(NX*NY*NZ),QFR(6,NX*NY*NZ), + 2 DIFF(NMIX,NG),SIGR(NMIX,NG),CHI(NMIX,NG),SIGF(NMIX,NG), + 3 SCAT(NMIX,NG,NG),BETA(NALB,NG,NG),FD(NMIX,6,NG,NG) + CHARACTER(LEN=12) :: BNDTL +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPFLX + INTEGER, PARAMETER :: NDIM=3 + REAL :: COEF(6),KEFF,KEFF_OLD +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: EVECT + REAL, ALLOCATABLE, DIMENSION(:,:) :: A11X,A11Y,A11Z + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: QFR2,DRIFT + REAL, POINTER, DIMENSION(:,:) :: SAVG +* + ALB(X)=0.5*(1.0-X)/(1.0+X) +*---- +* SCRATCH STORAGE ALLOCATION +*---- + NEL=NX*NY*NZ + N=LL4F*NG + ALLOCATE(QFR2(6,NEL,NG),EVECT(N)) + ALLOCATE(DRIFT(6,NEL,NG),SAVG(NUN,NG)) +*---- +* ALBEDO PROCESSING +*---- + QFR2(:6,:NEL,:NG)=0.0 + DO IG=1,NG + DO IQW=1,6 + DO I=1,NX + DO J=1,NY + DO K=1,NZ + IEL=(K-1)*NX*NY+(J-1)*NX+I + IALB=IQFR(IQW,I,J,K) + IF(IALB > 0) THEN + IF(IALB.GT.NALB) CALL XABORT('NSSFL5: BETA OVERFLOW.') + QFR2(IQW,IEL,IG)=QFR(IQW,IEL)*ALB(BETA(IALB,IG,IG)) + ELSE + QFR2(IQW,IEL,IG)=QFR(IQW,IEL) + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO +*---- +* INITIALIZATIONS +*---- + KEFF_OLD=0.0 + KEFF=1.0 + CALL LCMLEN(IPFLX,'FLUX',ILONG,ITYLCM) + IF(ILONG == 0) THEN + JPFLX=LCMLID(IPFLX,'FLUX',NG) + SAVG(:NUN,:NG)=1.0 + ELSE + JPFLX=LCMGID(IPFLX,'FLUX') + DO IG=1,NG + CALL LCMLEL(JPFLX,IG,ILONG,ITYLCM) + IF(ILONG /= NUN) CALL XABORT('NSSFL5: INVALID FLUX.') + CALL LCMGDL(JPFLX,IG,SAVG(1,IG)) + ENDDO + CALL LCMGET(IPFLX,'K-EFFECTIVE',KEFF) + ENDIF + CALL LCMLEN(IPFLX,'DRIFT',ILONG,ITYLCM) + IF(ILONG == 0) THEN + JPFLX=LCMLID(IPFLX,'DRIFT',6*NEL) + DRIFT(:6,:NEL,:NG)=0.0 + ELSE + JPFLX=LCMGID(IPFLX,'DRIFT') + DO IG=1,NG + CALL LCMLEL(JPFLX,IG,ILONG,ITYLCM) + IF(ILONG /= 6*NEL) CALL XABORT('NSSFL5: INVALID DRIFT.') + CALL LCMGDL(JPFLX,IG,DRIFT(1,1,IG)) + ENDDO + ENDIF + DO IND1=1,LL4F + DO IG=1,NG + EVECT((IG-1)*LL4F+IND1)=SAVG(IND1,IG) + ENDDO + ENDDO +*---- +* NODAL CORRECTION LOOP +*---- + NMAX=IMAX(LL4F) + NMAY=IMAY(LL4F) + NMAZ=IMAZ(LL4F) + ALLOCATE(A11X(NMAX,NG),A11Y(NMAY,NG),A11Z(NMAZ,NG)) + JTER=0 + SAVG(:NUN,:NG)=0.0 + IOFY=7*LL4F+LL4X + IOFZ=7*LL4F+LL4X+LL4Y + DO WHILE((ABS(KEFF_OLD-KEFF) >= EPSNOD).OR.(JTER==0)) + JTER=JTER+1 + IF(IMPX > 0) THEN + WRITE(6,'(36H NSSFL5: Nodal correction iteration=,I5)') + > JTER + ENDIF + IF(JTER > MAXNOD) THEN + WRITE(6,'(/22H ACCURACY AT ITERATION,I4,2H =,1P,E12.5)') + > JTER,ABS(KEFF_OLD-KEFF) + CALL XABORT('NSSFL5: NODAL ITERATION FAILURE') + ENDIF + ! + ! set CMFD matrices + IOF=0 + DO IG=1,NG + CALL NSSMXYZ(LL4F,NDIM,NX,NY,NZ,NMIX,MAT,XX,YY,ZZ,IDL,VOL, + > IQFR,QFR2(1,1,IG),DIFF(1,IG),DRIFT(1,1,IG),SIGR(1,IG), + > MUX,MUY,MUZ,IMAX,IMAY,IMAZ,IPY,IPZ,A11X(1,IG),A11Y(1,IG), + > A11Z(1,IG)) + ENDDO + ! + ! CMFD power iteration + DELTA=ABS(KEFF_OLD-KEFF) + KEFF_OLD=KEFF + CALL NSSEIG(NMAX,NMAY,NMAZ,LL4F,NDIM,NEL,NMIX,NG,MAT,IDL,VOL, + > MUX,MUY,MUZ,IMAX,IMAY,IMAZ,IPY,IPZ,CHI,SIGF,SCAT,A11X,A11Y,A11Z, + > EPSTHR,MAXTHR,NADI,EPSOUT,MAXOUT,ICL1,ICL2,ITER,EVECT,KEFF,IMPX) + IF(IMPX > 0) WRITE(6,10) JTER,KEFF,ITER,DELTA + IF(IMPX > 2) THEN + WRITE(6,'(1X,A)') 'NSSFL5: EVECT=' + IOF=0 + DO IG=1,NG + WRITE(6,'(1X,1P,14E12.4)') EVECT(IOF+1:IOF+LL4F) + IOF=IOF+LL4F + ENDDO + ENDIF + ! + ! begin construct SAVG + IF(NUN /= IOFZ+LL4Z) CALL XABORT('NSSFL5: INVALID NUN.') + DO IEL=1,LL4F + DO IG=1,NG + SAVG(IEL,IG)=EVECT((IG-1)*LL4F+IEL) + ENDDO + ENDDO + ! + ! one- and two-node anm relations + CALL NSSANM3(NUN,NX,NY,NZ,LL4F,LL4X,LL4Y,NG,BNDTL,NPASS,NMIX, + > IDL,KN,IQFR,QFR2,MAT,XXX,YYY,ZZZ,KEFF,DIFF,SIGR,CHI,SIGF,SCAT, + > FD,SAVG) + ! + ! compute new drift coefficients + DRIFT(:6,:NEL,:NG)=0.0 + DO IG=1,NG + DO K=1,NZ + DO J=1,NY + DO I=1,NX + IEL=(K-1)*NX*NY+(J-1)*NX+I + IND1=IDL(IEL) + IF(IND1 == 0) CYCLE + KK1=IQFR(1,I,J,K) + KK2=IQFR(2,I,J,K) + JXM=KN(1,I,J,K) ; JXP=KN(2,I,J,K) + JYM=KN(3,I,J,K) ; JYP=KN(4,I,J,K) + JZM=KN(5,I,J,K) ; JZP=KN(6,I,J,K) + CALL NSSCO(NX,NY,NZ,NMIX,I,J,K,MAT,XX,YY,ZZ,DIFF(1,IG), + > IQFR(1,I,J,K),QFR2(1,IEL,IG),COEF) + IF((KK1 < 0) .AND. (KK2 < 0)) THEN + DRIFT(1,IEL,IG)=-(SAVG(7*LL4F+JXM,IG)+COEF(1)* + > SAVG(IND1,IG))/SAVG(IND1,IG) + DRIFT(2,IEL,IG)=-(SAVG(7*LL4F+JXP,IG)-COEF(2)* + > SAVG(IND1,IG))/SAVG(IND1,IG) + ELSE IF(KK1 < 0) THEN + DRIFT(1,IEL,IG)=-(SAVG(7*LL4F+JXM,IG)+COEF(1)* + > SAVG(IND1,IG))/SAVG(IND1,IG) + IND3=IDL((K-1)*NX*NY+(J-1)*NX+I+1) + IF(IND3 /= 0) DRIFT(2,IEL,IG)=-(SAVG(7*LL4F+JXP,IG)+ + > COEF(2)*(SAVG(IND3,IG)-SAVG(IND1,IG)))/(SAVG(IND3,IG)+ + > SAVG(IND1,IG)) + ELSE IF(KK2 < 0) THEN + IND2=IDL((K-1)*NX*NY+(J-1)*NX+I-1) + IF(IND2 /= 0) DRIFT(1,IEL,IG)=-(SAVG(7*LL4F+JXM,IG)+ + > COEF(1)*(SAVG(IND1,IG)-SAVG(IND2,IG)))/(SAVG(IND1,IG)+ + > SAVG(IND2,IG)) + DRIFT(2,IEL,IG)=-(SAVG(7*LL4F+JXP,IG)-COEF(2)* + > SAVG(IND1,IG))/SAVG(IND1,IG) + ELSE + IND2=IDL((K-1)*NX*NY+(J-1)*NX+I-1) + IND3=IDL((K-1)*NX*NY+(J-1)*NX+I+1) + IF(IND2 /= 0) DRIFT(1,IEL,IG)=-(SAVG(7*LL4F+JXM,IG)+ + > COEF(1)*(SAVG(IND1,IG)-SAVG(IND2,IG)))/(SAVG(IND1,IG)+ + > SAVG(IND2,IG)) + IF(IND3 /= 0) DRIFT(2,IEL,IG)=-(SAVG(7*LL4F+JXP,IG)+ + > COEF(2)*(SAVG(IND3,IG)-SAVG(IND1,IG)))/(SAVG(IND3,IG)+ + > SAVG(IND1,IG)) + ENDIF + KK3=IQFR(3,I,J,K) + KK4=IQFR(4,I,J,K) + IF((KK3 < 0).AND.(KK4 < 0)) THEN + DRIFT(3,IEL,IG)=-(SAVG(IOFY+JYM,IG)+COEF(3)* + > SAVG(IND1,IG))/SAVG(IND1,IG) + DRIFT(4,IEL,IG)=-(SAVG(IOFY+JYP,IG)-COEF(4)* + > SAVG(IND1,IG))/SAVG(IND1,IG) + ELSE IF(KK3 < 0) THEN + DRIFT(3,IEL,IG)=-(SAVG(IOFY+JYM,IG)+COEF(3)* + > SAVG(IND1,IG))/SAVG(IND1,IG) + IND3=IDL((K-1)*NX*NY+J*NX+I) + IF(IND3 /= 0) DRIFT(4,IEL,IG)=-(SAVG(IOFY+JYP,IG)+ + > COEF(4)*(SAVG(IND3,IG)-SAVG(IND1,IG)))/(SAVG(IND3,IG)+ + > SAVG(IND1,IG)) + ELSE IF(KK4 < 0) THEN + IND2=IDL((K-1)*NX*NY+(J-2)*NX+I) + IF(IND2 /= 0) DRIFT(3,IEL,IG)=-(SAVG(IOFY+JYM,IG)+ + > COEF(3)*(SAVG(IND1,IG)-SAVG(IND2,IG)))/(SAVG(IND1,IG)+ + > SAVG(IND2,IG)) + DRIFT(4,IEL,IG)=-(SAVG(IOFY+JYP,IG)-COEF(4)* + > SAVG(IND1,IG))/SAVG(IND1,IG) + ELSE + IND2=IDL((K-1)*NX*NY+(J-2)*NX+I) + IND3=IDL((K-1)*NX*NY+J*NX+I) + IF(IND2 /= 0) DRIFT(3,IEL,IG)=-(SAVG(IOFY+JYM,IG)+ + > COEF(3)*(SAVG(IND1,IG)-SAVG(IND2,IG)))/(SAVG(IND1,IG)+ + > SAVG(IND2,IG)) + IF(IND3 /= 0) DRIFT(4,IEL,IG)=-(SAVG(IOFY+JYP,IG)+ + > COEF(4)*(SAVG(IND3,IG)-SAVG(IND1,IG)))/(SAVG(IND3,IG)+ + > SAVG(IND1,IG)) + ENDIF + KK5=IQFR(5,I,J,K) + KK6=IQFR(6,I,J,K) + IF((KK5 < 0).AND.(KK6 < 0)) THEN + DRIFT(5,IEL,IG)=-(SAVG(IOFZ+JZM,IG)+COEF(5)* + > SAVG(IND1,IG))/SAVG(IND1,IG) + DRIFT(6,IEL,IG)=-(SAVG(IOFZ+JZP,IG)-COEF(6)* + > SAVG(IND1,IG))/SAVG(IND1,IG) + ELSE IF(KK5 < 0) THEN + DRIFT(5,IEL,IG)=-(SAVG(IOFZ+JZM,IG)+COEF(5)* + > SAVG(IND1,IG))/SAVG(IND1,IG) + IND3=IDL(K*NX*NY+(J-1)*NX+I) + IF(IND3 /= 0) DRIFT(6,IEL,IG)=-(SAVG(IOFZ+JZP,IG)+ + > COEF(6)*(SAVG(IND3,IG)-SAVG(IND1,IG)))/(SAVG(IND3,IG)+ + > SAVG(IND1,IG)) + ELSE IF(KK6 < 0) THEN + IND2=IDL((K-2)*NX*NY+(J-1)*NX+I) + IF(IND2 /= 0) DRIFT(5,IEL,IG)=-(SAVG(IOFZ+JZM,IG)+ + > COEF(5)*(SAVG(IND1,IG)-SAVG(IND2,IG)))/(SAVG(IND1,IG)+ + > SAVG(IND2,IG)) + DRIFT(6,IEL,IG)=-(SAVG(IOFZ+JZP,IG)-COEF(6)* + > SAVG(IND1,IG))/SAVG(IND1,IG) + ELSE + IND2=IDL((K-2)*NX*NY+(J-1)*NX+I) + IND3=IDL(K*NX*NY+(J-1)*NX+I) + IF(IND2 /= 0) DRIFT(5,IEL,IG)=-(SAVG(IOFZ+JZM,IG)+ + > COEF(5)*(SAVG(IND1,IG)-SAVG(IND2,IG)))/(SAVG(IND1,IG)+ + > SAVG(IND2,IG)) + IF(IND3 /= 0) DRIFT(6,IEL,IG)=-(SAVG(IOFZ+JZP,IG)+ + > COEF(6)*(SAVG(IND3,IG)-SAVG(IND1,IG)))/(SAVG(IND3,IG)+ + > SAVG(IND1,IG)) + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO + IF(IMPX > 5) THEN + DO IG=1,NG + WRITE(6,'(28H NSSFL5: DRIFT COEFFICIENTS(,I5,2H):)') IG + DO IEL=1,NX*NY*NZ + WRITE(6,'(1P,I7,6E12.4)') IEL,DRIFT(:6,IEL,IG) + ENDDO + ENDDO + ENDIF + ENDDO + DEALLOCATE(A11Z,A11Y,A11X) +*---- +* END OF NODAL CORRECTION LOOP +*---- + IF(IMPX.GT.0) WRITE(6,20) KEFF,JTER + IF(IMPX > 2) THEN + WRITE(6,'(/21H NSSFL5: UNKNOWNS----)') + DO IG=1,NG + WRITE(6,'(14H NSSFL5: SAVG(,I4,2H)=)') IG + WRITE(6,'(1P,12E12.4)') SAVG(:LL4F,IG) + WRITE(6,'(19H X-BOUNDARY FLUXES:)') + WRITE(6,'(1P,12E12.4)') SAVG(LL4F+1:2*LL4F,IG) + WRITE(6,'(1P,12E12.4)') SAVG(2*LL4F+1:3*LL4F,IG) + WRITE(6,'(19H Y-BOUNDARY FLUXES:)') + WRITE(6,'(1P,12E12.4)') SAVG(3*LL4F+1:4*LL4F,IG) + WRITE(6,'(1P,12E12.4)') SAVG(4*LL4F+1:5*LL4F,IG) + WRITE(6,'(19H Z-BOUNDARY FLUXES:)') + WRITE(6,'(1P,12E12.4)') SAVG(5*LL4F+1:6*LL4F,IG) + WRITE(6,'(1P,12E12.4)') SAVG(6*LL4F+1:7*LL4F,IG) + WRITE(6,'(12H X-CURRENTS:)') + WRITE(6,'(1P,12E12.4)') SAVG(7*LL4F+1:IOFY,IG) + WRITE(6,'(12H Y-CURRENTS:)') + WRITE(6,'(1P,12E12.4)') SAVG(IOFY+1:IOFZ,IG) + WRITE(6,'(12H Z-CURRENTS:)') + WRITE(6,'(1P,12E12.4)') SAVG(IOFZ+1:NUN,IG) + WRITE(6,'(5H ----)') + ENDDO + ENDIF +*---- +* SAVE SOLUTION +*---- + JPFLX=LCMGID(IPFLX,'FLUX') + DO IG=1,NG + CALL LCMPDL(JPFLX,IG,NUN,2,SAVG(1,IG)) + ENDDO + JPFLX=LCMGID(IPFLX,'DRIFT') + DO IG=1,NG + CALL LCMPDL(JPFLX,IG,6*NEL,2,DRIFT(1,1,IG)) + ENDDO + CALL LCMPUT(IPFLX,'K-EFFECTIVE',1,2,KEFF) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(EVECT,QFR2) + DEALLOCATE(SAVG,DRIFT) + RETURN +* + 10 FORMAT(14H NSSFL5: JTER=,I4,11H CMFD KEFF=,1P E13.6, + 1 12H OBTAINED IN,I4,28H CMFD ITERATIONS WITH ERROR=, + 2 1P,E11.4,1H.) + 20 FORMAT(18H NSSFL5: ANM KEFF=,F11.8,12H OBTAINED IN,I5, + 1 29H NODAL CORRECTION ITERATIONS.) + END diff --git a/Trivac/src/NSSLR1.f90 b/Trivac/src/NSSLR1.f90 new file mode 100755 index 0000000..6bd0cfe --- /dev/null +++ b/Trivac/src/NSSLR1.f90 @@ -0,0 +1,164 @@ +subroutine NSSLR1(keff, ng, delx, diff, sigr, scat, chi, nusigf, L, R) +! +!----------------------------------------------------------------------- +! +!Purpose: +! Compute the 1D ANM coupling matrices for a single node. +! +!Copyright: +! Copyright (C) 2022 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version +! +!Author(s): A. Hebert +! +!Parameters: input +! keff effective multiplication factor. +! ng number of energy groups. +! delx node width along X-axis. +! diff diffusion coefficient array (cm). +! sigr removal cross section array (cm^-1). +! scat P0 scattering cross section matrix (cm^-1). +! chi fission spectrum array. +! nusigf nu*fission cross section array (cm^-1). +! +!Parameters: output +! L left nodal coupling matrix. +! R right nodal coupling matrix. +! +!----------------------------------------------------------------------- + ! + !---- + ! subroutine arguments + !---- + integer, intent(in) :: ng + real, intent(in) :: keff,delx + real, dimension(ng), intent(in) :: diff, sigr, chi, nusigf + real, dimension(ng,ng), intent(in) :: scat + real(kind=8), dimension(ng,2*ng), intent(out) :: L,R + !---- + ! local variables + !---- + real(kind=8) :: Lambda_r,sqla,mmax2 + !---- + ! allocatable arrays + !---- + complex(kind=8), allocatable, dimension(:,:) :: T,Lambda + real(kind=8), allocatable, dimension(:,:) :: F,DI,T_r,TI,S,Mm, & + & Mp,Nm,Np,GAR1,GAR2 + !---- + ! scratch storage allocation + !---- + allocate(F(ng,ng),T_r(ng,ng),T(ng,ng),TI(ng,ng),DI(ng,ng), & + & Lambda(ng,ng),S(ng,ng),Mm(2*ng,2*ng),Mp(2*ng,2*ng), & + & Nm(ng,2*ng),Np(ng,2*ng),GAR1(ng,2*ng),GAR2(ng,2*ng)) + !---- + ! compute matrices L and R + !---- + Mm(:,:)=0.0d0 + Mp(:,:)=0.0d0 + Nm(:,:)=0.0d0 + Np(:,:)=0.0d0 + DI(:,:)=0.0d0 + xm=0.0 ; xp=delx + do ig=1,ng + do jg=1,ng + if(ig == jg) then + F(ig,ig)=(chi(ig)*nusigf(ig)/keff-sigr(ig))/diff(ig) + else + F(ig,jg)=(chi(ig)*nusigf(jg)/keff+scat(ig,jg))/diff(ig) + endif + enddo + DI(ig,ig)=1.d0/diff(ig) + enddo + maxiter=40 + call ALHQR(ng,ng,F,maxiter,iter,T,Lambda) + mmax2=0.0d0 + do ig=1,ng + do jg=1,ng + mmax2=max(mmax2,abs(aimag(T(ig,jg)))) + enddo + enddo + if(mmax2 > 1.0e-6) then + write(6,'(3h T=)') + do ig=1,ng + write(6,'(1p,12e12.4)') T(ig,:) + enddo + call XABORT('NSSLR1: complex eigenvalues.') + endif + T_r(:,:)=real(T(:,:),8) + do ig=1,ng + Lambda_r=real(Lambda(ig,ig),8) + sqla=sqrt(abs(Lambda_r)) + if(delx*sqla < 1.e-6) then + if(Lambda_r >= 0) then + Mm(ig,ig)=-(delx*sqla)**6/5040.+(delx*sqla)**4/120.-(delx*sqla)**2/6.+1. + Mm(ig,ng+ig)=(delx*sqla)**5/720.-(delx*sqla)**3/24.+(delx*sqla)/2. + Mm(ng+ig,ng+ig)=-sqla + Mp(ng+ig,ig)=((delx*sqla)**6/120.-(delx*sqla)**4/6.+(delx*sqla)**2)/delx + Mp(ng+ig,ng+ig)=(-(delx*sqla)**5/24.+(delx*sqla)**3/2.-(delx*sqla))/delx + Nm(ig,ig)=1. + Np(ig,ig)=-(delx*sqla)**6/720.+(delx*sqla)**4/24.-(delx*sqla)**2/2.+1. + Np(ig,ng+ig)=(delx*sqla)**5/120.-(delx*sqla)**3/6.+(delx*sqla) + else + Mm(ig,ig)=(delx*sqla)**4/120.+(delx*sqla)**3/24.+(delx*sqla)**2/6.+(delx*sqla)/2. + 1. + Mm(ig,ng+ig)=-(delx*sqla)**3/24.+(delx*sqla)**2/6.-(delx*sqla)/2. + 1. + Mm(ng+ig,ig)=-sqla ; Mm(ng+ig,ng+ig)=sqla ; + Mp(ng+ig,ig)=(-(delx*sqla)**4/6.-(delx*sqla)**3/2.-(delx*sqla)**2-(delx*sqla))/delx + Mp(ng+ig,ng+ig)=(-(delx*sqla)**4/6+(delx*sqla)**3/2.-(delx*sqla)**2+(delx*sqla))/delx + Nm(ig,ig)=1. ; Nm(ig,ng+ig)=1. ; + Np(ig,ig)=(delx*sqla)**4/24.+(delx*sqla)**3/6.+(delx*sqla)**2/2.+(delx*sqla)+1. + Np(ig,ng+ig)=(delx*sqla)**4/24.-(delx*sqla)**3/6.+(delx*sqla)**2/2.-(delx*sqla)+1. + endif + else if(Lambda_r >= 0) then + Mm(ig,ig)=(sin(sqla*xp)-sin(sqla*xm))/(delx*sqla) + Mm(ig,ng+ig)=-(cos(sqla*xp)-cos(sqla*xm))/(delx*sqla) + Mm(ng+ig,ig)=sqla*sin(sqla*xm) + Mm(ng+ig,ng+ig)=-sqla*cos(sqla*xm) + Mp(ng+ig,ig)=sqla*sin(sqla*xp) + Mp(ng+ig,ng+ig)=-sqla*cos(sqla*xp) + Nm(ig,ig)=cos(sqla*xm) + Nm(ig,ng+ig)=sin(sqla*xm) + Np(ig,ig)=cos(sqla*xp) + Np(ig,ng+ig)=sin(sqla*xp) + else + Mm(ig,ig)=exp(sqla*xm)*(exp(sqla*(xp-xm))-1.0d0)/(delx*sqla) + Mm(ig,ng+ig)=-exp(-sqla*xm)*(exp(-sqla*(xp-xm))-1.0d0)/(delx*sqla) + Mm(ng+ig,ig)=-sqla*exp(sqla*xm) + Mm(ng+ig,ng+ig)=sqla*exp(-sqla*xm) + Mp(ng+ig,ig)=-sqla*exp(sqla*xp) + Mp(ng+ig,ng+ig)=sqla*exp(-sqla*xp) + Nm(ig,ig)=exp(sqla*xm) + Nm(ig,ng+ig)=exp(-sqla*xm) + Np(ig,ig)=exp(sqla*xp) + Np(ig,ng+ig)=exp(-sqla*xp) + endif + Mp(ig,ig)=Mm(ig,ig) + Mp(ig,ng+ig)=Mm(ig,ng+ig) + enddo + ! + TI(:,:)=T_r(:,:) + call ALINVD(2*ng,Mm,2*ng,ier) + if(ier /= 0) call XABORT('NSSLR1: singular matrix.(1)') + call ALINVD(2*ng,Mp,2*ng,ier) + if(ier /= 0) call XABORT('NSSLR1: singular matrix.(2)') + call ALINVD(ng,TI,ng,ier) + if(ier /= 0) call XABORT('NSSLR1: singular matrix.(3)') + ! + GAR1=matmul(Nm,Mm) ! ng,2*ng + GAR2=matmul(Np,Mp) ! ng,2*ng + S=matmul(TI,DI) ! ng,ng + GAR1=matmul(T_r,GAR1) ! ng,2*ng + GAR2=matmul(T_r,GAR2) ! ng,2*ng + ! + L(:ng,:ng)=matmul(GAR1(:ng,:ng),TI(:ng,:ng)) + L(:ng,ng+1:2*ng)=matmul(GAR1(:ng,ng+1:2*ng),S(:ng,:ng)) + R(:ng,:ng)=matmul(GAR2(:ng,:ng),TI(:ng,:ng)) + R(:ng,ng+1:2*ng)=matmul(GAR2(:ng,ng+1:2*ng),S(:ng,:ng)) + !---- + ! scratch storage deallocation + !---- + deallocate(GAR2,GAR1,Np,Nm,Mp,Mm,S,Lambda,DI,TI,T,T_r,F) +end subroutine NSSLR1 diff --git a/Trivac/src/NSSLR2.f90 b/Trivac/src/NSSLR2.f90 new file mode 100755 index 0000000..c589317 --- /dev/null +++ b/Trivac/src/NSSLR2.f90 @@ -0,0 +1,238 @@ +subroutine NSSLR2(keff, ng, bndtl, xxx, dely, diff, sigr, scat, chi, nusigf, L, R) +! +!----------------------------------------------------------------------- +! +!Purpose: +! Compute the 2D ANM coupling matrices for a single node. +! +!Copyright: +! Copyright (C) 2023 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version +! +!Author(s): A. Hebert +! +!Parameters: input +! keff effective multiplication factor. +! ng number of energy groups. +! bndtl set to 'flat' or 'quadratic'. +! xxx node support along X-axis. +! dely node width along Y-axis. +! diff diffusion coefficient array (cm). +! sigr removal cross section array (cm-1). +! scat P0 scattering cross section matrix (cm^-1). +! chi fission spectrum array. +! nusigf nu*fission cross section array (cm^-1). +! +!Parameters: output +! L left nodal coupling matrix. +! R right nodal coupling matrix. +! +!----------------------------------------------------------------------- + ! + !---- + ! subroutine arguments + !---- + integer, intent(in) :: ng + real, intent(in) :: keff, xxx(4), dely + real, dimension(ng), intent(in) :: diff, sigr, chi, nusigf + real, dimension(ng,ng), intent(in) :: scat + character(len=12), intent(in) :: bndtl + real(kind=8), dimension(ng,8*ng), intent(out) :: L, R + !---- + ! local variables + !---- + real(kind=8) :: m0(3,3),m2(3,3),m3(2,3),m4(1,3),Lambda_r,sqla,mmax2 + !---- + ! allocatable arrays + !---- + complex(kind=8), allocatable, dimension(:,:) :: T,Lambda + real(kind=8), allocatable, dimension(:,:) :: F,DI,T_r,TI,S,Mm,Mp,Nm,Np, & + & GAR1,GAR2,GAR3,GAR4,Vm,Vp,Um,Up,MAT1,MAT2,S7 + !---- + ! scratch storage allocation + !---- + allocate(F(ng,ng),T_r(ng,ng),T(ng,ng),TI(ng,ng),DI(ng,ng), & + & Lambda(ng,ng),S(ng,ng),Mm(2*ng,2*ng),Mp(2*ng,2*ng),Nm(ng,2*ng), & + & Np(ng,2*ng),GAR1(ng,2*ng),GAR2(ng,2*ng),GAR3(ng,8*ng), & + & GAR4(ng,8*ng),Vm(2*ng,3*ng),Vp(2*ng,3*ng),Um(ng,3*ng), & + & Up(ng,3*ng),MAT1(ng,8*ng),MAT2(ng,8*ng)) + ! + ! quadratic leakage and boundary conditions + xmm=xxx(1) ; xm=xxx(2) ; xp=xxx(3) ; xpp=xxx(4) ; delx=xp-xm ; + if(xmm == -99999.) then + ! Vacuum or zero flux node at left boundary + xmm=2.0*xm-xp + m0(:3,1)=1.0d0 ; m0(1,2)=(xmm+xm)/2.0d0 ; m0(1,3)=(xmm**2+xmm*xm+xm**2)/3.0d0 + m0(2,2)=(xm+xp)/2.0d0 ; m0(2,3)=(xm**2+xm*xp+xp**2)/3.0d0 + m0(3,2)=(xp+xpp)/2.0d0 ; m0(3,3)=(xp**2+xp*xpp+xpp**2)/3.0d0 + call ALINVD(3,m0,3,ier) + if(ier /= 0) call XABORT('NSSLR2: singular matrix.(1)') + m0(:3,1)=0.0d0 + elseif(xpp == -99999.) then + ! Vacuum or zero flux node at right boundary + xpp=2.0*xp-xm + m0(:3,1)=1.0d0 ; m0(1,2)=(xmm+xm)/2.0d0 ; m0(1,3)=(xmm**2+xmm*xm+xm**2)/3.0d0 + m0(2,2)=(xm+xp)/2.0d0 ; m0(2,3)=(xm**2+xm*xp+xp**2)/3.0d0 + m0(3,2)=(xp+xpp)/2.0d0 ; m0(3,3)=(xp**2+xp*xpp+xpp**2)/3.0d0 + call ALINVD(3,m0,3,ier) + if(ier /= 0) call XABORT('NSSLR2: singular matrix.(2)') + m0(:3,3)=0.0d0 + else + ! Internal node + m0(:3,1)=1.0d0 ; m0(1,2)=(xmm+xm)/2.0d0 ; m0(1,3)=(xmm**2+xmm*xm+xm**2)/3.0d0 + m0(2,2)=(xm+xp)/2.0d0 ; m0(2,3)=(xm**2+xm*xp+xp**2)/3.0d0 + m0(3,2)=(xp+xpp)/2.0d0 ; m0(3,3)=(xp**2+xp*xpp+xpp**2)/3.0d0 + call ALINVD(3,m0,3,ier) + if(ier /= 0) call XABORT('NSSLR2: singular matrix.(3)') + endif + if(bndtl == 'flat') then + ! flat leakage approximation + m0(:3,:3)=0.0d0 ; m0(1,2)=1.0d0 + endif + !---- + ! compute matrices L and R + !---- + Mm(:,:)=0.0d0 + Mp(:,:)=0.0d0 + Nm(:,:)=0.0d0 + Np(:,:)=0.0d0 + DI(:,:)=0.0d0 + Vm(:,:)=0.0d0 + Vp(:,:)=0.0d0 + Um(:,:)=0.0d0 + Up(:,:)=0.0d0 + do ig=1,ng + do jg=1,ng + if(ig == jg) then + F(ig,ig)=(chi(ig)*nusigf(ig)/keff-sigr(ig))/diff(ig) + else + F(ig,jg)=(chi(ig)*nusigf(jg)/keff+scat(ig,jg))/diff(ig) + endif + enddo + DI(ig,ig)=1./diff(ig) + enddo + maxiter=40 + call ALHQR(ng,ng,F,maxiter,iter,T,Lambda) + mmax2=0.0d0 + do ig=1,ng + do jg=1,ng + mmax2=max(mmax2,abs(aimag(T(ig,jg)))) + enddo + enddo + if(mmax2 > 1.0e-6) then + write(6,'(3h T=)') + do ig=1,ng + write(6,'(1p,12e12.4)') T(ig,:) + enddo + call XABORT('NSSLR2: complex eigenvalues.') + endif + T_r(:,:)=real(T(:,:),8) + do ig=1,ng + Lambda_r=real(Lambda(ig,ig),8) + sqla=sqrt(abs(Lambda_r)) + m2(:3,:3)=0.0d0 + m2(1,1)=1.0d0/Lambda_r ; m2(1,3)=-2.0d0/Lambda_r**2 + m2(2,2)=1.0d0/Lambda_r ; m2(3,3)=1.0d0/Lambda_r + m2(:3,:3)=matmul(m2(:3,:3),m0(:3,:3)) + m3(1,1)=1.0d0 ; m3(1,2)=(xm+xp)/2. ; m3(1,3)=(xm**2+xm*xp+xp**2)/3.0d0 + m3(2,1)=0.0d0 ; m3(2,2)=-1.0d0 ; m3(2,3)=-2.0d0*xm + m3(:2,:3)=matmul(m3(:2,:3),m2(:3,:3)) + Vm(ig,ig)=m3(1,1) ; Vm(ig,ng+ig)=m3(1,2) ; Vm(ig,2*ng+ig)=m3(1,3) ; + Vm(ng+ig,ig)=m3(2,1) ; Vm(ng+ig,ng+ig)=m3(2,2) ; Vm(ng+ig,2*ng+ig)=m3(2,3) ; + m3(1,1)=1.0d0 ; m3(1,2)=(xm+xp)/2.0d0 ; m3(1,3)=(xm**2+xm*xp+xp**2)/3.0d0 + m3(2,1)=0.0d0 ; m3(2,2)=-1.0d0 ; m3(2,3)=-2.0d0*xp + m3(:2,:3)=matmul(m3(:2,:3),m2(:3,:3)) + Vp(ig,ig)=m3(1,1) ; Vp(ig,ng+ig)=m3(1,2) ; Vp(ig,2*ng+ig)=m3(1,3) ; + Vp(ng+ig,ig)=m3(2,1) ; Vp(ng+ig,ng+ig)=m3(2,2) ; Vp(ng+ig,2*ng+ig)=m3(2,3) ; + m4(1,1)=1.0d0 ; m4(1,2)=xm ; m4(1,3)=xm**2 + m4(:1,:3)=matmul(m4(:1,:3),m2(:3,:3)) + Um(ig,ig)=m4(1,1) ; Um(ig,ng+ig)=m4(1,2) ; Um(ig,2*ng+ig)=m4(1,3) ; + m4(1,1)=1.0d0 ; m4(1,2)=xp ; m4(1,3)=xp**2 + m4(:1,:3)=matmul(m4(:1,:3),m2(:3,:3)) + Up(ig,ig)=m4(1,1) ; Up(ig,ng+ig)=m4(1,2) ; Up(ig,2*ng+ig)=m4(1,3) ; + if(delx*sqla < 1.e-6) then + if(Lambda_r >= 0) then + Mm(ig,ig)=-(delx*sqla)**6/5040.+(delx*sqla)**4/120.-(delx*sqla)**2/6.+1. + Mm(ig,ng+ig)=(delx*sqla)**5/720.-(delx*sqla)**3/24.+(delx*sqla)/2. + Mm(ng+ig,ng+ig)=-sqla + Mp(ng+ig,ig)=((delx*sqla)**6/120.-(delx*sqla)**4/6.+(delx*sqla)**2)/delx + Mp(ng+ig,ng+ig)=(-(delx*sqla)**5/24.+(delx*sqla)**3/2.-(delx*sqla))/delx + Nm(ig,ig)=1. + Np(ig,ig)=-(delx*sqla)**6/720.+(delx*sqla)**4/24.-(delx*sqla)**2/2.+1. + Np(ig,ng+ig)=(delx*sqla)**5/120.-(delx*sqla)**3/6.+(delx*sqla) + else + Mm(ig,ig)=(delx*sqla)**4/120.+(delx*sqla)**3/24.+(delx*sqla)**2/6.+(delx*sqla)/2. + 1. + Mm(ig,ng+ig)=-(delx*sqla)**3/24.+(delx*sqla)**2/6.-(delx*sqla)/2. + 1. + Mm(ng+ig,ig)=-sqla ; Mm(ng+ig,ng+ig)=sqla ; + Mp(ng+ig,ig)=(-(delx*sqla)**4/6.-(delx*sqla)**3/2.-(delx*sqla)**2-(delx*sqla))/delx + Mp(ng+ig,ng+ig)=(-(delx*sqla)**4/6+(delx*sqla)**3/2.-(delx*sqla)**2+(delx*sqla))/delx + Nm(ig,ig)=1. ; Nm(ig,ng+ig)=1. ; + Np(ig,ig)=(delx*sqla)**4/24.+(delx*sqla)**3/6.+(delx*sqla)**2/2.+(delx*sqla)+1. + Np(ig,ng+ig)=(delx*sqla)**4/24.-(delx*sqla)**3/6.+(delx*sqla)**2/2.-(delx*sqla)+1. + endif + else if(Lambda_r >= 0) then + Mm(ig,ig)=(sin(sqla*xp)-sin(sqla*xm))/(delx*sqla) + Mm(ig,ng+ig)=-(cos(sqla*xp)-cos(sqla*xm))/(delx*sqla) + Mm(ng+ig,ig)=sqla*sin(sqla*xm) + Mm(ng+ig,ng+ig)=-sqla*cos(sqla*xm) + Mp(ng+ig,ig)=sqla*sin(sqla*xp) + Mp(ng+ig,ng+ig)=-sqla*cos(sqla*xp) + Nm(ig,ig)=cos(sqla*xm) + Nm(ig,ng+ig)=sin(sqla*xm) + Np(ig,ig)=cos(sqla*xp) + Np(ig,ng+ig)=sin(sqla*xp) + else + Mm(ig,ig)=exp(sqla*xm)*(exp(sqla*(xp-xm))-1.0d0)/(delx*sqla) + Mm(ig,ng+ig)=-exp(-sqla*xm)*(exp(-sqla*(xp-xm))-1.0d0)/(delx*sqla) + Mm(ng+ig,ig)=-sqla*exp(sqla*xm) + Mm(ng+ig,ng+ig)=sqla*exp(-sqla*xm) + Mp(ng+ig,ig)=-sqla*exp(sqla*xp) + Mp(ng+ig,ng+ig)=sqla*exp(-sqla*xp) + Nm(ig,ig)=exp(sqla*xm) + Nm(ig,ng+ig)=exp(-sqla*xm) + Np(ig,ig)=exp(sqla*xp) + Np(ig,ng+ig)=exp(-sqla*xp) + endif + Mp(ig,ig)=Mm(ig,ig) + Mp(ig,ng+ig)=Mm(ig,ng+ig) + enddo + ! + TI(:,:)=T_r(:,:) + call ALINVD(2*ng,Mm,2*ng,ier) + if(ier /= 0) call XABORT('NSSLR2: singular matrix.(4)') + call ALINVD(2*ng,Mp,2*ng,ier) + if(ier /= 0) call XABORT('NSSLR2: singular matrix.(5)') + call ALINVD(ng,TI,ng,ier) + if(ier /= 0) call XABORT('NSSLR2: singular matrix.(6)') + ! + GAR1=matmul(Nm,Mm) ! ng,2*ng + GAR2=matmul(Np,Mp) ! ng,2*ng + S=matmul(TI,DI) ! ng,ng + ! + MAT1(:ng,:2*ng)=GAR1(:ng,:2*ng) + MAT1(:ng,2*ng+1:5*ng)=-Um(:ng,:3*ng)/dely+matmul(GAR1(:ng,:2*ng),Vm(:2*ng,:3*ng))/dely + MAT1(:ng,5*ng+1:8*ng)=Um(:ng,:3*ng)/dely-matmul(GAR1(:ng,:2*ng),Vm(:2*ng,:3*ng))/dely + MAT2(:ng,:2*ng)=GAR2(:ng,:2*ng) + MAT2(:ng,2*ng+1:5*ng)=-Up(:ng,:3*ng)/dely+matmul(GAR2(:ng,:2*ng),Vp(:2*ng,:3*ng))/dely + MAT2(:ng,5*ng+1:8*ng)=Up(:ng,:3*ng)/dely-matmul(GAR2(:ng,:2*ng),Vp(:2*ng,:3*ng))/dely + ! + GAR3=matmul(T_r,MAT1) ! ng,8*ng + GAR4=matmul(T_r,MAT2) ! ng,8*ng + L(:ng,:ng)=matmul(GAR3(:ng,:ng),TI(:ng,:ng)) + R(:ng,:ng)=matmul(GAR4(:ng,:ng),TI(:ng,:ng)) + allocate(S7(7*ng,7*ng)) + S7(:,:)=0.0d0 ! 7*ng,7*ng + do i=1,7 + S7((i-1)*ng+1:i*ng,(i-1)*ng+1:i*ng)=S(:ng,:ng) + enddo + L(:ng,ng+1:8*ng)=matmul(GAR3(:ng,ng+1:8*ng),S7(:7*ng,:7*ng)) + R(:ng,ng+1:8*ng)=matmul(GAR4(:ng,ng+1:8*ng),S7(:7*ng,:7*ng)) + !---- + ! scratch storage deallocation + !---- + deallocate(S7,MAT2,MAT1,Up,Um,Vp,Vm,GAR4,GAR3,GAR2,GAR1,Np,Nm,Mp,Mm,S, & + & Lambda,DI,TI,T,T_r,F) +end subroutine NSSLR2 diff --git a/Trivac/src/NSSLR3.f90 b/Trivac/src/NSSLR3.f90 new file mode 100755 index 0000000..436649b --- /dev/null +++ b/Trivac/src/NSSLR3.f90 @@ -0,0 +1,244 @@ +subroutine NSSLR3(keff, ng, bndtl, xxx, dely, delz, diff, sigr, scat, & +& chi, nusigf, L, R) +! +!----------------------------------------------------------------------- +! +!Purpose: +! Compute the 3D ANM coupling matrices for a single node. +! +!Copyright: +! Copyright (C) 2023 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version +! +!Author(s): A. Hebert +! +!Parameters: input +! keff effective multiplication factor. +! ng number of energy groups. +! bndtl set to 'flat' or 'quadratic'. +! xxx node support along X-axis. +! dely node width along Y-axis. +! delz node width along Z-axis. +! diff diffusion coefficient array (cm). +! sigr removal cross section array (cm-1). +! scat P0 scattering cross section matrix (cm^-1). +! chi fission spectrum array. +! nusigf nu*fission cross section array (cm^-1). +! +!Parameters: output +! L left nodal coupling matrix. +! R right nodal coupling matrix. +! +!----------------------------------------------------------------------- + ! + !---- + ! subroutine arguments + !---- + integer, intent(in) :: ng + real, intent(in) :: keff, xxx(4), dely, delz + real, dimension(ng), intent(in) :: diff, sigr, chi, nusigf + real, dimension(ng,ng), intent(in) :: scat + character(len=12), intent(in) :: bndtl + real(kind=8), dimension(ng,14*ng), intent(out) :: L, R + !---- + ! local variables + !---- + real(kind=8) :: m0(3,3),m2(3,3),m3(2,3),m4(1,3),Lambda_r,sqla,mmax2 + !---- + ! allocatable arrays + !---- + complex(kind=8), allocatable, dimension(:,:) :: T,Lambda + real(kind=8), allocatable, dimension(:,:) :: F,DI,T_r,TI,S,Mm,Mp,Nm,Np, & + & GAR1,GAR2,GAR3,GAR4,Vm,Vp,Um,Up,MAT1,MAT2,S13 + !---- + ! scratch storage allocation + !---- + allocate(F(ng,ng),T_r(ng,ng),T(ng,ng),TI(ng,ng),DI(ng,ng), & + & Lambda(ng,ng),S(ng,ng),Mm(2*ng,2*ng),Mp(2*ng,2*ng),Nm(ng,2*ng), & + & Np(ng,2*ng),GAR1(ng,2*ng),GAR2(ng,2*ng),GAR3(ng,14*ng), & + & GAR4(ng,14*ng),Vm(2*ng,3*ng),Vp(2*ng,3*ng),Um(ng,3*ng), & + & Up(ng,3*ng),MAT1(ng,14*ng),MAT2(ng,14*ng)) + ! + ! quadratic leakage and boundary conditions + xmm=xxx(1) ; xm=xxx(2) ; xp=xxx(3) ; xpp=xxx(4) ; delx=xp-xm ; + if(xmm == -99999.) then + ! Vacuum or zero flux node at left boundary + xmm=2.0*xm-xp + m0(:3,1)=1.0d0 ; m0(1,2)=(xmm+xm)/2.0d0 ; m0(1,3)=(xmm**2+xmm*xm+xm**2)/3.0d0 + m0(2,2)=(xm+xp)/2.0d0 ; m0(2,3)=(xm**2+xm*xp+xp**2)/3.0d0 + m0(3,2)=(xp+xpp)/2.0d0 ; m0(3,3)=(xp**2+xp*xpp+xpp**2)/3.0d0 + call ALINVD(3,m0,3,ier) + if(ier /= 0) call XABORT('NSSLR3: singular matrix.(1)') + m0(:3,1)=0.0d0 + elseif(xpp == -99999.) then + ! Vacuum or zero flux node at right boundary + xpp=2.0*xp-xm + m0(:3,1)=1.0d0 ; m0(1,2)=(xmm+xm)/2.0d0 ; m0(1,3)=(xmm**2+xmm*xm+xm**2)/3.0d0 + m0(2,2)=(xm+xp)/2.0d0 ; m0(2,3)=(xm**2+xm*xp+xp**2)/3.0d0 + m0(3,2)=(xp+xpp)/2.0d0 ; m0(3,3)=(xp**2+xp*xpp+xpp**2)/3.0d0 + call ALINVD(3,m0,3,ier) + if(ier /= 0) call XABORT('NSSLR3: singular matrix.(2)') + m0(:3,3)=0.0d0 + else + ! Internal node + m0(:3,1)=1.0d0 ; m0(1,2)=(xmm+xm)/2.0d0 ; m0(1,3)=(xmm**2+xmm*xm+xm**2)/3.0d0 + m0(2,2)=(xm+xp)/2.0d0 ; m0(2,3)=(xm**2+xm*xp+xp**2)/3.0d0 + m0(3,2)=(xp+xpp)/2.0d0 ; m0(3,3)=(xp**2+xp*xpp+xpp**2)/3.0d0 + call ALINVD(3,m0,3,ier) + if(ier /= 0) call XABORT('NSSLR3: singular matrix.(3)') + endif + if(bndtl == 'flat') then + ! flat leakage approximation + m0(:3,:3)=0.0d0 ; m0(1,2)=1.0d0 + endif + !---- + ! compute matrices L and R + !---- + Mm(:,:)=0.0d0 + Mp(:,:)=0.0d0 + Nm(:,:)=0.0d0 + Np(:,:)=0.0d0 + DI(:,:)=0.0d0 + Vm(:,:)=0.0d0 + Vp(:,:)=0.0d0 + Um(:,:)=0.0d0 + Up(:,:)=0.0d0 + do ig=1,ng + do jg=1,ng + if(ig == jg) then + F(ig,ig)=(chi(ig)*nusigf(ig)/keff-sigr(ig))/diff(ig) + else + F(ig,jg)=(chi(ig)*nusigf(jg)/keff+scat(ig,jg))/diff(ig) + endif + enddo + DI(ig,ig)=1./diff(ig) + enddo + maxiter=40 + call ALHQR(ng,ng,F,maxiter,iter,T,Lambda) + mmax2=0.0d0 + do ig=1,ng + do jg=1,ng + mmax2=max(mmax2,abs(aimag(T(ig,jg)))) + enddo + enddo + if(mmax2 > 1.0e-6) then + write(6,'(3h T=)') + do ig=1,ng + write(6,'(1p,12e12.4)') T(ig,:) + enddo + call XABORT('NSSLR3: complex eigenvalues.') + endif + T_r(:,:)=real(T(:,:),8) + do ig=1,ng + Lambda_r=real(Lambda(ig,ig),8) + sqla=sqrt(abs(Lambda_r)) + m2(:3,:3)=0.0d0 + m2(1,1)=1.0d0/Lambda_r ; m2(1,3)=-2.0d0/Lambda_r**2 + m2(2,2)=1.0d0/Lambda_r ; m2(3,3)=1.0d0/Lambda_r + m2(:3,:3)=matmul(m2(:3,:3),m0(:3,:3)) + m3(1,1)=1.0d0 ; m3(1,2)=(xm+xp)/2. ; m3(1,3)=(xm**2+xm*xp+xp**2)/3.0d0 + m3(2,1)=0.0d0 ; m3(2,2)=-1.0d0 ; m3(2,3)=-2.0d0*xm + m3(:2,:3)=matmul(m3(:2,:3),m2(:3,:3)) + Vm(ig,ig)=m3(1,1) ; Vm(ig,ng+ig)=m3(1,2) ; Vm(ig,2*ng+ig)=m3(1,3) ; + Vm(ng+ig,ig)=m3(2,1) ; Vm(ng+ig,ng+ig)=m3(2,2) ; Vm(ng+ig,2*ng+ig)=m3(2,3) ; + m3(1,1)=1.0d0 ; m3(1,2)=(xm+xp)/2.0d0 ; m3(1,3)=(xm**2+xm*xp+xp**2)/3.0d0 + m3(2,1)=0.0d0 ; m3(2,2)=-1.0d0 ; m3(2,3)=-2.0d0*xp + m3(:2,:3)=matmul(m3(:2,:3),m2(:3,:3)) + Vp(ig,ig)=m3(1,1) ; Vp(ig,ng+ig)=m3(1,2) ; Vp(ig,2*ng+ig)=m3(1,3) ; + Vp(ng+ig,ig)=m3(2,1) ; Vp(ng+ig,ng+ig)=m3(2,2) ; Vp(ng+ig,2*ng+ig)=m3(2,3) ; + m4(1,1)=1.0d0 ; m4(1,2)=xm ; m4(1,3)=xm**2 + m4(:1,:3)=matmul(m4(:1,:3),m2(:3,:3)) + Um(ig,ig)=m4(1,1) ; Um(ig,ng+ig)=m4(1,2) ; Um(ig,2*ng+ig)=m4(1,3) ; + m4(1,1)=1.0d0 ; m4(1,2)=xp ; m4(1,3)=xp**2 + m4(:1,:3)=matmul(m4(:1,:3),m2(:3,:3)) + Up(ig,ig)=m4(1,1) ; Up(ig,ng+ig)=m4(1,2) ; Up(ig,2*ng+ig)=m4(1,3) ; + if(delx*sqla < 1.e-6) then + if(Lambda_r >= 0) then + Mm(ig,ig)=-(delx*sqla)**6/5040.+(delx*sqla)**4/120.-(delx*sqla)**2/6.+1. + Mm(ig,ng+ig)=(delx*sqla)**5/720.-(delx*sqla)**3/24.+(delx*sqla)/2. + Mm(ng+ig,ng+ig)=-sqla + Mp(ng+ig,ig)=((delx*sqla)**6/120.-(delx*sqla)**4/6.+(delx*sqla)**2)/delx + Mp(ng+ig,ng+ig)=(-(delx*sqla)**5/24.+(delx*sqla)**3/2.-(delx*sqla))/delx + Nm(ig,ig)=1. + Np(ig,ig)=-(delx*sqla)**6/720.+(delx*sqla)**4/24.-(delx*sqla)**2/2.+1. + Np(ig,ng+ig)=(delx*sqla)**5/120.-(delx*sqla)**3/6.+(delx*sqla) + else + Mm(ig,ig)=(delx*sqla)**4/120.+(delx*sqla)**3/24.+(delx*sqla)**2/6.+(delx*sqla)/2. + 1. + Mm(ig,ng+ig)=-(delx*sqla)**3/24.+(delx*sqla)**2/6.-(delx*sqla)/2. + 1. + Mm(ng+ig,ig)=-sqla ; Mm(ng+ig,ng+ig)=sqla ; + Mp(ng+ig,ig)=(-(delx*sqla)**4/6.-(delx*sqla)**3/2.-(delx*sqla)**2-(delx*sqla))/delx + Mp(ng+ig,ng+ig)=(-(delx*sqla)**4/6+(delx*sqla)**3/2.-(delx*sqla)**2+(delx*sqla))/delx + Nm(ig,ig)=1. ; Nm(ig,ng+ig)=1. ; + Np(ig,ig)=(delx*sqla)**4/24.+(delx*sqla)**3/6.+(delx*sqla)**2/2.+(delx*sqla)+1. + Np(ig,ng+ig)=(delx*sqla)**4/24.-(delx*sqla)**3/6.+(delx*sqla)**2/2.-(delx*sqla)+1. + endif + else if(Lambda_r >= 0) then + Mm(ig,ig)=(sin(sqla*xp)-sin(sqla*xm))/(delx*sqla) + Mm(ig,ng+ig)=-(cos(sqla*xp)-cos(sqla*xm))/(delx*sqla) + Mm(ng+ig,ig)=sqla*sin(sqla*xm) + Mm(ng+ig,ng+ig)=-sqla*cos(sqla*xm) + Mp(ng+ig,ig)=sqla*sin(sqla*xp) + Mp(ng+ig,ng+ig)=-sqla*cos(sqla*xp) + Nm(ig,ig)=cos(sqla*xm) + Nm(ig,ng+ig)=sin(sqla*xm) + Np(ig,ig)=cos(sqla*xp) + Np(ig,ng+ig)=sin(sqla*xp) + else + Mm(ig,ig)=exp(sqla*xm)*(exp(sqla*(xp-xm))-1.0d0)/(delx*sqla) + Mm(ig,ng+ig)=-exp(-sqla*xm)*(exp(-sqla*(xp-xm))-1.0d0)/(delx*sqla) + Mm(ng+ig,ig)=-sqla*exp(sqla*xm) + Mm(ng+ig,ng+ig)=sqla*exp(-sqla*xm) + Mp(ng+ig,ig)=-sqla*exp(sqla*xp) + Mp(ng+ig,ng+ig)=sqla*exp(-sqla*xp) + Nm(ig,ig)=exp(sqla*xm) + Nm(ig,ng+ig)=exp(-sqla*xm) + Np(ig,ig)=exp(sqla*xp) + Np(ig,ng+ig)=exp(-sqla*xp) + endif + Mp(ig,ig)=Mm(ig,ig) + Mp(ig,ng+ig)=Mm(ig,ng+ig) + enddo + ! + TI(:,:)=T_r(:,:) + call ALINVD(2*ng,Mm,2*ng,ier) + if(ier /= 0) call XABORT('NSSLR3: singular matrix.(4)') + call ALINVD(2*ng,Mp,2*ng,ier) + if(ier /= 0) call XABORT('NSSLR3: singular matrix.(5)') + call ALINVD(ng,TI,ng,ier) + if(ier /= 0) call XABORT('NSSLR3: singular matrix.(6)') + ! + GAR1=matmul(Nm,Mm) ! ng,2*ng + GAR2=matmul(Np,Mp) ! ng,2*ng + S=matmul(TI,DI) ! ng,ng + ! + MAT1(:ng,:2*ng)=GAR1(:ng,:2*ng) + MAT1(:ng,2*ng+1:5*ng)=-Um(:ng,:3*ng)/dely+matmul(GAR1(:ng,:2*ng),Vm(:2*ng,:3*ng))/dely + MAT1(:ng,5*ng+1:8*ng)=Um(:ng,:3*ng)/dely-matmul(GAR1(:ng,:2*ng),Vm(:2*ng,:3*ng))/dely + MAT1(:ng,8*ng+1:11*ng)=-Um(:ng,:3*ng)/delz+matmul(GAR1(:ng,:2*ng),Vm(:2*ng,:3*ng))/delz + MAT1(:ng,11*ng+1:14*ng)=Um(:ng,:3*ng)/delz-matmul(GAR1(:ng,:2*ng),Vm(:2*ng,:3*ng))/delz + MAT2(:ng,:2*ng)=GAR2(:ng,:2*ng) + MAT2(:ng,2*ng+1:5*ng)=-Up(:ng,:3*ng)/dely+matmul(GAR2(:ng,:2*ng),Vp(:2*ng,:3*ng))/dely + MAT2(:ng,5*ng+1:8*ng)=Up(:ng,:3*ng)/dely-matmul(GAR2(:ng,:2*ng),Vp(:2*ng,:3*ng))/dely + MAT2(:ng,8*ng+1:11*ng)=-Up(:ng,:3*ng)/delz+matmul(GAR2(:ng,:2*ng),Vp(:2*ng,:3*ng))/delz + MAT2(:ng,11*ng+1:14*ng)=Up(:ng,:3*ng)/delz-matmul(GAR2(:ng,:2*ng),Vp(:2*ng,:3*ng))/delz + ! + GAR3=matmul(T_r,MAT1) ! ng,14*ng + GAR4=matmul(T_r,MAT2) ! ng,14*ng + L(:ng,:ng)=matmul(GAR3(:ng,:ng),TI(:ng,:ng)) + R(:ng,:ng)=matmul(GAR4(:ng,:ng),TI(:ng,:ng)) + allocate(S13(13*ng,13*ng)) + S13(:,:)=0.0d0 ! 13*ng,13*ng + do i=1,13 + S13((i-1)*ng+1:i*ng,(i-1)*ng+1:i*ng)=S(:ng,:ng) + enddo + L(:ng,ng+1:14*ng)=matmul(GAR3(:ng,ng+1:14*ng),S13(:13*ng,:13*ng)) + R(:ng,ng+1:14*ng)=matmul(GAR4(:ng,ng+1:14*ng),S13(:13*ng,:13*ng)) + !---- + ! scratch storage deallocation + !---- + deallocate(S13,MAT2,MAT1,Up,Um,Vp,Vm,GAR4,GAR3,GAR2,GAR1,Np,Nm,Mp,Mm,S, & + & Lambda,DI,TI,T,T_r,F) +end subroutine NSSLR3 diff --git a/Trivac/src/NSSMXYZ.f90 b/Trivac/src/NSSMXYZ.f90 new file mode 100755 index 0000000..92a9db7 --- /dev/null +++ b/Trivac/src/NSSMXYZ.f90 @@ -0,0 +1,219 @@ +subroutine NSSMXYZ(ll4f,ndim,nx,ny,nz,nmix,mat,xx,yy,zz,idl,vol,iqfr,qfr, & +& diff,drift,sigt,mux,muy,muz,imax,imay,imaz,ipy,ipz,a11x,a11y,a11z) +! +!----------------------------------------------------------------------- +! +!Purpose: +! Assembly of system matrices for coarse mesh finite differences with +! nodal correction. +! +!Copyright: +! Copyright (C) 2022 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version +! +!Author(s): A. Hebert +! +!Parameters: input +! ll4f total number of averaged flux unknown per energy group. +! ndim number of dimensions (1, 2, or 3). +! nx number of nodes in the X direction. +! ny number of nodes in the Y direction. +! nz number of nodes in the Z direction. +! nmix number of mixtures. +! mat node mixtures. +! xx node widths in the X direction. +! yy node widths in the Y direction. +! zz node widths in the Z direction. +! idl position of averaged fluxes in unknown vector. +! vol node volumes. +! iqfr boundary conditions. +! qfr albedo functions. +! diff diffusion coefficients. +! drift drift coefficients. +! sigt removal macroscopic cross section. +! mux X-oriented compressed storage mode indices. +! muy Y-oriented compressed storage mode indices. +! muz Z-oriented compressed storage mode indices. +! imax X-oriented position of each first non-zero column element. +! imay Y-oriented position of each first non-zero column element. +! imaz Z-oriented position of each first non-zero column element. +! ipy Y-oriented permutation matrices. +! ipz Z-oriented permutation matrices. +! +!Parameters: output +! a11x X-directed matrices corresponding to the divergence (i.e. +! leakage) and removal terms. Dimensionned to imax(ll4f). +! a11y Y-directed matrices corresponding to the divergence (i.e. +! leakage) and removal terms. Dimensionned to imay(ll4f). +! a11z Z-directed matrices corresponding to the divergence (i.e. +! leakage) and removal terms. Dimensionned to imaz(ll4f). +! +!----------------------------------------------------------------------- +! + !---- + ! subroutine arguments + !---- + integer,intent(in) :: ll4f,ndim,nx,ny,nz,nmix,mat(nx,ny,nz),idl(nx,ny,nz), & + & iqfr(6,nx,ny,nz),mux(ll4f),muy(ll4f),muz(ll4f),imax(ll4f),imay(ll4f),imaz(ll4f), & + & ipy(ll4f),ipz(ll4f) + real,intent(in) :: xx(nx,ny,nz),yy(nx,ny,nz),zz(nx,ny,nz),vol(nx,ny,nz), & + & qfr(6,nx,ny,nz),diff(nmix),drift(6,nx,ny,nz),sigt(nmix) + real,intent(out) :: a11x(*),a11y(*),a11z(*) + !---- + ! local variables + !---- + real :: coef(6),codr(6) + ! + a11x(:imax(ll4f))=0.0 + if(ndim > 1) a11y(:imay(ll4f))=0.0 + if(ndim == 3) a11z(:imaz(ll4f))=0.0 + do k=1,nz + do j=1,ny + do i=1,nx + ibm=mat(i,j,k) + if(ibm <= 0) cycle + kel=idl(i,j,k) + if(kel == 0) cycle + vol0=vol(i,j,k) + call NSSCO(nx,ny,nz,nmix,i,j,k,mat,xx,yy,zz,diff,iqfr(1,i,j,k),qfr(1,i,j,k),coef) + coef(1:2)=coef(1:2)*vol0/xx(i,j,k) + coef(3:4)=coef(3:4)*vol0/yy(i,j,k) + coef(5:6)=coef(5:6)*vol0/zz(i,j,k) + codr(1:2)=drift(1:2,i,j,k)*vol0/xx(i,j,k) + codr(3:4)=drift(3:4,i,j,k)*vol0/yy(i,j,k) + codr(5:6)=drift(5:6,i,j,k)*vol0/zz(i,j,k) + ! + ! x-directed couplings + kel2=0 + kk1=iqfr(1,i,j,k) + if(kk1 == -4) then + kel2=idl(nx,j,k) + else if(kk1 == 0) then + kel2=idl(i-1,j,k) + endif + if(kel2 /= 0) then + if(kel2 <= kel) then + key=mux(kel)-kel+kel2 + a11x(key)=a11x(key)-coef(1)+codr(1) + else + key=mux(kel2)+kel2-kel + a11x(key)=a11x(key)-coef(1)+codr(1) + endif + endif + kel2=0 + kk2=iqfr(2,i,j,k) + if(kk2 == -4) then + kel2=idl(1,j,k) + else if(kk2 == 0) then + kel2=idl(i+1,j,k) + endif + if(kel2 /= 0) then + if(kel2 <= kel) then + key=mux(kel)-kel+kel2 + a11x(key)=a11x(key)-coef(2)-codr(2) + else + key=mux(kel2)+kel2-kel + a11x(key)=a11x(key)-coef(2)-codr(2) + endif + endif + key0=mux(kel) + a11x(key0)=a11x(key0)+coef(1)+codr(1)+coef(2)-codr(2) + a11x(key0)=a11x(key0)+coef(3)+codr(3)+coef(4)-codr(4) + a11x(key0)=a11x(key0)+coef(5)+codr(5)+coef(6)-codr(6) + a11x(key0)=a11x(key0)+sigt(ibm)*vol0 + ! + if(ndim > 1) then + ! y-directed couplings + kel2=0 + kk3=iqfr(3,i,j,k) + if(kk3 == -4) then + kel2=idl(i,ny,k) + else if(kk3 == 0) then + kel2=idl(i,j-1,k) + endif + ind1=ipy(kel) + if(kel2 /= 0) then + ind2=ipy(kel2) + if(kel2 <= kel) then + key=muy(ind1)-ind1+ind2 + a11y(key)=a11y(key)-coef(3)+codr(3) + else + key=muy(ind2)+ind2-ind1 + a11y(key)=a11y(key)-coef(3)+codr(3) + endif + endif + kel2=0 + kk4=iqfr(4,i,j,k) + if(kk4 == -4) then + kel2=idl(i,1,k) + else if(kk4 == 0) then + kel2=idl(i,j+1,k) + endif + if(kel2 /= 0) then + ind2=ipy(kel2) + if(kel2 <= kel) then + key=muy(ind1)-ind1+ind2 + a11y(key)=a11y(key)-coef(4)-codr(4) + else + key=muy(ind2)+ind2-ind1 + a11y(key)=a11y(key)-coef(4)-codr(4) + endif + endif + key0=muy(ind1) + a11y(key0)=a11y(key0)+coef(1)+codr(1)+coef(2)-codr(2) + a11y(key0)=a11y(key0)+coef(3)+codr(3)+coef(4)-codr(4) + a11y(key0)=a11y(key0)+coef(5)+codr(5)+coef(6)-codr(6) + a11y(key0)=a11y(key0)+sigt(ibm)*vol0 + endif + ! + if(ndim > 2) then + ! z-directed couplings + kel2=0 + kk5=iqfr(5,i,j,k) + if(kk5 == -4) then + kel2=idl(i,j,nz) + else if(kk5 == 0) then + kel2=idl(i,j,k-1) + endif + ind1=ipz(kel) + if(kel2 /= 0) then + ind2=ipz(kel2) + if(kel2 <= kel) then + key=muz(ind1)-ind1+ind2 + a11z(key)=a11z(key)-coef(5)+codr(5) + else + key=muz(ind2)+ind2-ind1 + a11z(key)=a11z(key)-coef(5)+codr(5) + endif + endif + kel2=0 + kk6=iqfr(6,i,j,k) + if(kk6 == -4) then + kel2=idl(i,j,1) + else if(kk6 == 0) then + kel2=idl(i,j,k+1) + endif + if(kel2 /= 0) then + ind2=ipz(kel2) + if(kel2 <= kel) then + key=muz(ind1)-ind1+ind2 + a11z(key)=a11z(key)-coef(6)-codr(6) + else + key=muz(ind2)+ind2-ind1 + a11z(key)=a11z(key)-coef(6)-codr(6) + endif + endif + key0=muz(ind1) + a11z(key0)=a11z(key0)+coef(1)+codr(1)+coef(2)-codr(2) + a11z(key0)=a11z(key0)+coef(3)+codr(3)+coef(4)-codr(4) + a11z(key0)=a11z(key0)+coef(5)+codr(5)+coef(6)-codr(6) + a11z(key0)=a11z(key0)+sigt(ibm)*vol0 + endif + enddo + enddo + enddo + return +end subroutine NSSMXYZ diff --git a/Trivac/src/NSST.f b/Trivac/src/NSST.f new file mode 100755 index 0000000..b7cb74d --- /dev/null +++ b/Trivac/src/NSST.f @@ -0,0 +1,370 @@ +*DECK NSST + SUBROUTINE NSST(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Nodal expansion method (NEM) tracking operator. +* +*Copyright: +* Copyright (C) 2020 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1): create or modification type(L_TRACK); +* HENTRY(2): read-only type(L_GEOM). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 + TYPE(C_PTR) KENTRY(NENTRY) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + CHARACTER TEXT4*4,TEXT12*12,TITLE*72,HSIGN*12 + DOUBLE PRECISION DFLOTT + LOGICAL ILK + INTEGER ISTATE(NSTATE),NCODE(6),ICODE(6) + REAL ZCODE(6) + TYPE(C_PTR) IPGEO,IPTRK +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MAT,IDL,ISPLX,ISPLY,ISPLZ, + 1 MUX,MUY,MUZ,IMAX,IMAY,IMAZ,IPY,IPZ + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: KN,IQFR + REAL, ALLOCATABLE, DIMENSION(:) :: XXX,YYY,ZZZ,XX,YY,ZZ,VOL + REAL, ALLOCATABLE, DIMENSION(:,:) :: QFR +*---- +* PARAMETER VALIDATION. +*---- + IF(NENTRY.NE.2) CALL XABORT('NSST: TWO PARAMETERS EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('NSST: L' + 1 //'CM OBJECT EXPECTED AT LHS.') + IF((JENTRY(1).NE.0).AND.(JENTRY(1).NE.1)) CALL XABORT('NSST: E' + 1 //'NTRY IN CREATE OR MODIFICATION MODE EXPECTED.') + IF((JENTRY(2).NE.2).OR.((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2))) + 1 CALL XABORT('NSST: LCM OBJECT IN READ-ONLY MODE EXPECTED AT R' + 2 //'HS.') + CALL LCMGTC(KENTRY(2),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_GEOM') THEN + TEXT12=HENTRY(2) + CALL XABORT('NSST: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_GEOM EXPECTED.') + ENDIF + IPTRK=KENTRY(1) + IPGEO=KENTRY(2) + HSIGN='L_TRACK' + CALL LCMPTC(IPTRK,'SIGNATURE',12,HSIGN) + HSIGN='TRIVAC' + CALL LCMPTC(IPTRK,'TRACK-TYPE',12,HSIGN) + CALL LCMGET(IPGEO,'STATE-VECTOR',ISTATE) + IDIM=0 + ITYPE=ISTATE(1) + IF(ITYPE.EQ.2) THEN + IDIM=1 + ELSE IF(ITYPE.EQ.5) THEN + IDIM=2 + ELSE IF(ITYPE.EQ.7) THEN + IDIM=3 + ELSE + CALL XABORT('NSST: 1D, 2D OR 3D CARTESIAN GEOMETRY EXPECTED.') + ENDIF + NX=ISTATE(3) + NY=ISTATE(4) + NZ=ISTATE(5) + CALL LCMLEN(IPGEO,'BIHET',ILONG,ITYLCM) + IF(ILONG.NE.0) CALL XABORT('NSST: DOUBLE-HETEROGENEITY NOT SUPPO' + 1 //'RTED.') +* + IMPX=1 + TITLE=' ' + IGMAX=0 + ICHX=5 + NADI=2 + IF(IDIM.EQ.1) THEN + MAXPTS=NX + ELSE IF(IDIM.EQ.2) THEN + MAXPTS=NX*NY + ELSE + MAXPTS=NX*NY*NZ + ENDIF + IF(JENTRY(1).EQ.1) THEN + CALL LCMGTC(IPTRK,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_TRACK') THEN + TEXT12=HENTRY(1) + CALL XABORT('NSST: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_TRACK EXPECTED.') + ENDIF + CALL LCMGTC(IPTRK,'TRACK-TYPE',12,HSIGN) + IF(HSIGN.NE.'TRIVAC') THEN + TEXT12=HENTRY(3) + CALL XABORT('NSST: TRACK-TYPE OF '//TEXT12//' IS '//HSIGN + 1 //'. TRIVAC EXPECTED.') + ENDIF + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + ICHX=ISTATE(12) ! CMFD/NEM/ANM + IGMAX=ISTATE(39) + CALL LCMLEN(IPTRK,'TITLE',LENGT,ITYLCM) + IF(LENGT.GT.0) CALL LCMGTC(IPTRK,'TITLE',72,TITLE) + ENDIF + 10 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.EQ.10) GO TO 30 + IF(INDIC.NE.3) CALL XABORT('NSST: CHARACTER DATA EXPECTED.') + IF(TEXT4.EQ.'EDIT') THEN + CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('NSST: INTEGER DATA EXPECTED(1).') + ELSE IF(TEXT4.EQ.'TITL') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TITLE,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('NSST: TITLE EXPECTED.') + ELSE IF(TEXT4.EQ.'MAXR') THEN + CALL REDGET(INDIC,MAXPTS,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('NSST: INTEGER DATA EXPECTED(2).') + ELSE IF(TEXT4.EQ.'CMFD') THEN + ICHX=4 + ELSE IF(TEXT4.EQ.'NEM') THEN + ICHX=5 + ELSE IF(TEXT4.EQ.'ANM') THEN + ICHX=6 + ELSE IF(TEXT4.EQ.'HYPE') THEN + CALL REDGET(INDIC,IGMAX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('NSST: INTEGER DATA EXPECTED(3).') + ELSE IF(TEXT4.EQ.'ADI') THEN + CALL REDGET(INDIC,NADI,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('NSST: INTEGER DATA EXPECTED(4).') + ELSE IF(TEXT4.EQ.';') THEN + GO TO 30 + ELSE + CALL XABORT('NSST: '//TEXT4//' IS AN INVALID KEYWORD.') + ENDIF + GO TO 10 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + 30 IF(IMPX.GT.1) WRITE(6,100) TITLE + ALLOCATE(XXX(MAXPTS+1),YYY(MAXPTS+1),ZZZ(MAXPTS+1),MAT(MAXPTS), + 1 IDL(MAXPTS),VOL(MAXPTS),XX(MAXPTS),YY(MAXPTS),ZZ(MAXPTS), + 2 KN(6,MAXPTS),QFR(6,MAXPTS),IQFR(6,MAXPTS)) +*---- +* RECOVER TRACKING INFORMATION +*---- + ALLOCATE(ISPLX(MAXPTS),ISPLY(MAXPTS),ISPLZ(MAXPTS)) + CALL READ3D(MAXPTS,MAXPTS,MAXPTS,MAXPTS,IPGEO,IHEX,IR,ILK,SIDE, + 1 XXX,YYY,ZZZ,IMPX,NX,NY,NZ,MAT,NEL,NCODE,ICODE,ZCODE,ISPLX,ISPLY, + 2 ISPLZ,ISPLH,ISPLL) + DEALLOCATE(ISPLX,ISPLY,ISPLZ) + IF(IDIM.EQ.1) THEN +* 1D GEOMETRY + NY=1 + NCODE(3)=2 + NCODE(4)=2 + ZCODE(3)=1.0 + ZCODE(4)=1.0 + YYY(1)=0.0 + YYY(2)=1.0 + ENDIF + IF(IDIM.LE.2) THEN +* 1D OR 2D GEOMETRY + NZ=1 + NCODE(5)=2 + NCODE(6)=2 + ZCODE(5)=1.0 + ZCODE(6)=1.0 + ZZZ(1)=0.0 + ZZZ(2)=1.0 + ENDIF +*---- +* UNFOLD THE DOMAIN IN DIAGONAL SYMMETRY CASES. +*---- + IDIAG=0 + IF((NCODE(2).EQ.3).AND.(NCODE(3).EQ.3)) THEN + IDIAG=1 + NCODE(3)=NCODE(1) + NCODE(2)=NCODE(4) + ICODE(3)=ICODE(1) + ICODE(2)=ICODE(4) + ZCODE(3)=ZCODE(1) + ZCODE(2)=ZCODE(4) + K=NEL + DO IZ=NZ,1,-1 + IOFF=(IZ-1)*NX*NY + DO IY=NY,1,-1 + DO IX=NX,IY+1,-1 + MAT(IOFF+(IY-1)*NX+IX)=MAT(IOFF+(IX-1)*NY+IY) + ENDDO + DO IX=IY,1,-1 + MAT(IOFF+(IY-1)*NX+IX)=MAT(K) + K=K-1 + ENDDO + ENDDO + ENDDO + NEL=NX*NY*NZ + IF(K.NE.0) THEN + CALL XABORT('TRITRK: UNABLE TO UNFOLD THE DOMAIN(1).') + ENDIF + ELSE IF((NCODE(1).EQ.3).AND.(NCODE(4).EQ.3)) THEN + IDIAG=1 + NCODE(1)=NCODE(3) + NCODE(4)=NCODE(2) + ICODE(1)=ICODE(3) + ICODE(4)=ICODE(2) + ZCODE(1)=ZCODE(3) + ZCODE(4)=ZCODE(2) + K=NEL + DO IZ=NZ,1,-1 + IOFF=(IZ-1)*NX*NY + DO IY=NY,1,-1 + DO IX=NX,IY,-1 + MAT(IOFF+(IY-1)*NX+IX)=MAT(K) + K=K-1 + ENDDO + ENDDO + ENDDO + DO IZ=1,NZ + IOFF=(IZ-1)*NX*NY + DO IY=1,NY + DO IX=1,IY-1 + MAT(IOFF+(IY-1)*NX+IX)=MAT(IOFF+(IX-1)*NY+IY) + ENDDO + ENDDO + ENDDO + NEL=NX*NY*NZ + IF(K.NE.0) THEN + CALL XABORT('TRITRK: UNABLE TO UNFOLD THE DOMAIN(2).') + ENDIF + ENDIF + IF(IMPX.GT.5) THEN + WRITE(6,120) 'NCODE',(NCODE(I),I=1,6) + WRITE(6,120) 'MAT',(MAT(I),I=1,NX*NY*NZ) + ENDIF +*---- +* SET TRACKING INFORMATION +*---- + LL4F=0 + DO KEL=1,NEL + IF(MAT(KEL).GT.0) LL4F=LL4F+1 + ENDDO + ALLOCATE(MUX(LL4F),MUY(LL4F),MUZ(LL4F),IMAX(LL4F),IMAY(LL4F), + 1 IMAZ(LL4F),IPY(LL4F),IPZ(LL4F)) + CALL NSSDFC(IMPX,IDIM,NX,NY,NZ,NCODE,ICODE,ZCODE,MAT,XXX,YYY,ZZZ, + 1 LL4F,LL4X,LL4Y,LL4Z,VOL,XX,YY,ZZ,IDL,KN,QFR,IQFR,MUX,MUY,MUZ, + 2 IMAX,IMAY,IMAZ,IPY,IPZ) + IF(IDIM.EQ.1) THEN + NUN=LL4F*3+LL4X + ELSE IF(IDIM.EQ.2) THEN + NUN=LL4F*5+LL4X+LL4Y + ELSE + NUN=LL4F*7+LL4X+LL4Y+LL4Z + ENDIF +*---- +* SAVE INFORMATION ON LCM +*---- + ISTATE(:)=0 + ISTATE(1)=NEL + ISTATE(2)=NUN + ISTATE(4)=MAXVAL(MAT(:NEL)) + ISTATE(6)=ITYPE ! Geometry type + ISTATE(12)=ICHX ! CMFD/NEM/ANM + ISTATE(14)=NX + IF(IDIM.GE.2) ISTATE(15)=NY + IF(IDIM.EQ.3) ISTATE(16)=NZ + ISTATE(25)=LL4F + ISTATE(27)=LL4X + ISTATE(28)=LL4Y + ISTATE(29)=LL4Z + ISTATE(33)=NADI + ISTATE(39)=IGMAX + CALL LCMPUT(IPTRK,'STATE-VECTOR',NSTATE,1,ISTATE) + CALL LCMPUT(IPTRK,'NCODE',6,1,NCODE) + CALL LCMPUT(IPTRK,'ZCODE',6,2,ZCODE) + CALL LCMPUT(IPTRK,'ICODE',6,1,ICODE) + CALL LCMPUT(IPTRK,'MATCOD',NEL,1,MAT) + CALL LCMPUT(IPTRK,'VOLUME',NEL,2,VOL) + CALL LCMPUT(IPTRK,'KEYFLX',NEL,1,IDL) + CALL LCMPUT(IPTRK,'XX',NEL,2,XX) + CALL LCMPUT(IPTRK,'XXX',NX+1,2,XXX) + IF(IDIM.GE.2) THEN + CALL LCMPUT(IPTRK,'YY',NEL,2,YY) + CALL LCMPUT(IPTRK,'YYY',NY+1,2,YYY) + ENDIF + IF(IDIM.EQ.3) THEN + CALL LCMPUT(IPTRK,'ZZ',NEL,2,ZZ) + CALL LCMPUT(IPTRK,'ZZZ',NZ+1,2,ZZZ) + ENDIF + CALL LCMPUT(IPTRK,'KN',6*NEL,1,KN) + CALL LCMPUT(IPTRK,'QFR',6*NEL,2,QFR) + CALL LCMPUT(IPTRK,'IQFR',6*NEL,1,IQFR) + CALL LCMPUT(IPTRK,'MUX',LL4F,1,MUX) + CALL LCMPUT(IPTRK,'IMAX',LL4F,1,IMAX) + IF(IDIM.GE.2) THEN + CALL LCMPUT(IPTRK,'MUY',LL4F,1,MUY) + CALL LCMPUT(IPTRK,'IMAY',LL4F,1,IMAY) + CALL LCMPUT(IPTRK,'IPY',LL4F,1,IPY) + ENDIF + IF(IDIM.EQ.3) THEN + CALL LCMPUT(IPTRK,'MUZ',LL4F,1,MUZ) + CALL LCMPUT(IPTRK,'IMAZ',LL4F,1,IMAZ) + CALL LCMPUT(IPTRK,'IPZ',LL4F,1,IPZ) + ENDIF + IF(TITLE.NE.' ') CALL LCMPTC(IPTRK,'TITLE',72,TITLE) + TEXT12=HENTRY(2) + CALL LCMPTC(IPTRK,'LINK.GEOM',12,TEXT12) + IF(IMPX.GT.1) THEN + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + WRITE(6,110) ISTATE(1:2),ISTATE(4),ISTATE(6),ISTATE(12), + 1 ISTATE(14:16),ISTATE(25),ISTATE(27:29),ISTATE(33),ISTATE(39) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IPZ,IPY,IMAZ,IMAY,IMAX,MUZ,MUY,MUX) + DEALLOCATE(XX,ZZ,YY,ZZZ,YYY,XXX) + DEALLOCATE(IQFR,QFR,KN,VOL,IDL,MAT) + RETURN +* + 100 FORMAT(1H1,24HNN NN SSSSS SSSSS, + 1 97(1H*)/26H NNN NN SSSSSSS SSSSSSS, + 2 58(1H*),38H MULTIGROUP VERSION. A. HEBERT (2021)/ + 3 26H NNNN NN SS SS SS SS/26H NN NN NN SSS SSS / + 4 26H NN NN NN SSS SSS /26H NN NNNN SS SS SS SS/ + 5 26H NN NNN SSSSSSS SSSSSSS/26H NN NN SSSSS SSSSS // + 6 1X,A72//) + 110 FORMAT(/14H STATE VECTOR:/ + 1 7H NREG ,I8,22H (NUMBER OF REGIONS)/ + 2 7H NUN ,I8,23H (NUMBER OF UNKNOWNS)/ + 3 7H NMIX ,I8,23H (NUMBER OF MIXTURES)/ + 4 7H ITYPE ,I8,41H (TYPE OF GEOMETRY -- 2:1D; 5:2D; 7:3D)/ + 5 7H ICHX ,I8,40H (TYPE OF SOLUTION 4/5/6:CMFD/NEM/ANM)/ + 6 7H NX ,I8,40H (NUMBER OF ELEMENTS ALONG THE X AXIS)/ + 7 7H NY ,I8,40H (NUMBER OF ELEMENTS ALONG THE Y AXIS)/ + 8 7H NZ ,I8,40H (NUMBER OF ELEMENTS ALONG THE Z AXIS)/ + 9 7H LL4F ,I8,29H (NUMBER OF AVERAGE FLUXES)/ + 1 7H LL4X ,I8,38H (NUMBER OF X-DIRECTED NET CURRENTS)/ + 2 7H LL4Y ,I8,38H (NUMBER OF Y-DIRECTED NET CURRENTS)/ + 3 7H LL4Z ,I8,38H (NUMBER OF Z-DIRECTED NET CURRENTS)/ + 4 7H NADI ,I8,29H (NUMBER OF ADI ITERATIONS)/ + 5 7H IGMAX ,I8,47H (ENERGY GROUP LIMIT WITH HYPERBOLIC TRIAL FU, + 6 8HNCTIONS)) + 120 FORMAT(/24H NSST: VALUES OF VECTOR ,A6,4H ARE/(1X,1P,20I6)) + END diff --git a/Trivac/src/OUT.f b/Trivac/src/OUT.f new file mode 100755 index 0000000..7c1f2bb --- /dev/null +++ b/Trivac/src/OUT.f @@ -0,0 +1,188 @@ +*DECK OUT + SUBROUTINE OUT(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Simple edition module for TRIVAC-3. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1): create or modification type(L_MACROLIB); +* HENTRY(2): read-only type(L_FLUX); +* HENTRY(3): read-only type(L_TRACK); +* HENTRY(4): read-only type(L_MACROLIB); +* HENTRY(5): read-only type(L_GEOM). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*Comments: +* The OUT: calling specifications are: +* MACRO2 := OUT: FLUX TRACK MACRO GEOM :: (out\_data) ; +* where +* MACRO2 : name of the \emph{lcm} object (type L\_MACROLIB) containing the +* extended \emph{macrolib}. +* FLUX : name of the \emph{lcm} object (type L\_FLUX) containing a solution +* TRACK : name of the \emph{lcm} object (type L\_TRACK) containing a +* \emph{tracking}. +* MACRO : name of the \emph{lcm} object (type L\_MACROLIB) containing the +* reference \emph{macrolib}. +* GEOM : name of the \emph{lcm} object (type L\_GEOM) containing the +* reference \emph{geometry}. +* out\_data}] : structure containing the data to module OUT: +* +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + CHARACTER TEXT12*12,TITLE*72,HTRACK*12,HSIGN*12 + INTEGER IGP(NSTATE) + TYPE(C_PTR) IPMAC1,IPMAC2,IPFLUX,IPTRK,IPGEOM + INTEGER, DIMENSION(:),ALLOCATABLE :: MAT,IDL + REAL, DIMENSION(:),ALLOCATABLE :: VOL +*---- +* PARAMETER VALIDATION. +*---- + IF(NENTRY.LE.1) CALL XABORT('OUT: TWO PARAMETERS EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('OUT: LCM ' + 1 //'OBJECT EXPECTED AT LHS.') + IF(JENTRY(1).NE.0) CALL XABORT('OUT: ENTRY IN CREATE MODE EXPECT' + 1 //'ED.') + IF((JENTRY(2).NE.2).OR.((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2))) + 1 CALL XABORT('OUT: LCM OBJECT IN READ-ONLY MODE EXPECTED AT RHS.') + IPMAC2=KENTRY(1) + IPFLUX=KENTRY(2) + CALL LCMGTC(IPFLUX,'SIGNATURE',12,HSIGN) + TEXT12=HENTRY(2) + IF(HSIGN.NE.'L_FLUX') THEN + CALL XABORT('OUT: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_FLUX EXPECTED.') + ENDIF + HSIGN='L_MACROLIB' + CALL LCMPTC(IPMAC2,'SIGNATURE',12,HSIGN) + CALL LCMPTC(IPMAC2,'LINK.FLUX',12,TEXT12) +*---- +* RECOVER IPGEOM, IPMAC1 AND IPTRK POINTERS. +*---- + CALL LCMGTC(IPFLUX,'LINK.TRACK',12,TEXT12) + DO 10 I=1,NENTRY + IF(HENTRY(I).EQ.TEXT12) THEN + IPTRK=KENTRY(I) + CALL LCMGTC(IPTRK,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_TRACK') THEN + TEXT12=HENTRY(I) + CALL XABORT('OUT: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_TRACK EXPECTED.') + ENDIF + GO TO 20 + ENDIF + 10 CONTINUE + CALL XABORT('OUT: UNABLE TO FIND A POINTER TO L_TRACK.') + 20 CALL LCMGTC(IPFLUX,'LINK.MACRO',12,TEXT12) + DO 50 I=1,NENTRY + IF(HENTRY(I).EQ.TEXT12) THEN + IPMAC1=KENTRY(I) + CALL LCMGTC(IPMAC1,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_MACROLIB') THEN + TEXT12=HENTRY(I) + CALL XABORT('OUT: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_MACROLIB EXPECTED.') + ENDIF + GO TO 60 + ENDIF + 50 CONTINUE + CALL XABORT('OUT: UNABLE TO FIND A POINTER TO L_MACROLIB.') + 60 DO 70 I=1,NENTRY + CALL LCMLEN(KENTRY(I),'SIGNATURE',ILONG,ITYLCM) + IF(ILONG.NE.0) THEN + CALL LCMGTC(KENTRY(I),'SIGNATURE',12,HSIGN) + IF(HSIGN.EQ.'L_GEOM') THEN + IPGEOM=KENTRY(I) + GO TO 80 + ENDIF + ENDIF + 70 CONTINUE + CALL XABORT('OUT: UNABLE TO FIND A POINTER TO L_GEOM.') + 80 CALL LCMGET(IPMAC1,'STATE-VECTOR',IGP) + NGRP=IGP(1) + NBMIX=IGP(2) + NL=IGP(3) + NBFIS=IGP(4) + NALBP=IGP(8) +*---- +* FIND TYPE OF TRACKING. +*---- + CALL LCMGTC(IPTRK,'TRACK-TYPE',12,HTRACK) +*---- +* RECOVER GENERAL TRACKING INFORMATION. +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',IGP) + NEL=IGP(1) + NUN=IGP(2) + IF(HTRACK.EQ.'BIVAC') THEN + IELEM=IGP(8) + ICOL=IGP(9) + IBFP=0 + ELSE IF(HTRACK.EQ.'TRIVAC') THEN + IELEM=IGP(9) + ICOL=IGP(10) + IBFP=0 + ELSE IF(HTRACK.EQ.'SN') THEN + IELEM=IGP(8) + ICOL=0 + IBFP=IGP(31) + ELSE + ICOL=0 + IBFP=0 + ENDIF + MAXNEL=NEL + CALL LCMLEN(IPTRK,'KEYFLX',LKFL,ITYLCM) + ALLOCATE(MAT(NEL),VOL(NEL),IDL(LKFL)) + CALL LCMGET(IPTRK,'MATCOD',MAT) + CALL LCMGET(IPTRK,'VOLUME',VOL) + CALL LCMGET(IPTRK,'KEYFLX',IDL) + CALL LCMLEN(IPTRK,'TITLE',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + CALL LCMGTC(IPTRK,'TITLE',72,TITLE) + CALL LCMPTC(IPMAC2,'TITLE',72,TITLE) + ELSE + TITLE='*** NO TITLE PROVIDED ***' + ENDIF +*---- +* EDITION. +*---- + CALL OUTDRV(IPGEOM,IPMAC1,IPFLUX,IPMAC2,MAXNEL,NBMIX,NL, + 1 NBFIS,NGRP,NEL,NUN,NALBP,HTRACK,IELEM,ICOL,MAT,VOL,IDL, + 2 TITLE,IBFP) +*---- +* RELEASE GENERAL TRACKING INFORMATION. +*---- + DEALLOCATE(IDL,VOL,MAT) + RETURN + END diff --git a/Trivac/src/OUTAUX.f b/Trivac/src/OUTAUX.f new file mode 100755 index 0000000..64a2567 --- /dev/null +++ b/Trivac/src/OUTAUX.f @@ -0,0 +1,527 @@ +*DECK OUTAUX + SUBROUTINE OUTAUX (IPMAC1,IPMAC2,NBMIX,NL,NBFIS,NGRP,NEL,NUN, + 1 NALBP,NZS,NGCOND,MAT,VOL,IDL,EVECT,IHOM,IGCOND,IMPX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform homogenization into NZS regions and condensation into NGCOND +* macrogroups based on averaged fluxes contained in EVECT. Create an +* output extended macrolib containing homogenized volumes, integrated +* fluxes and cross sections. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPMAC1 L_MACROLIB pointer to the input macrolib. +* IPMAC2 L_MACROLIB pointer to the output extended macrolib. +* NBMIX number of material mixtures. +* NL scattering anisotropy. +* NBFIS number of fissionable isotopes. +* NGRP total number of energy groups. +* NEL number of finite elements. +* NUN number of unknowns per energy group. +* NALBP number of physical albedos. +* NZS number of homogenized regions so that NZS=max(IHOM(i)). +* NGCOND number of macrogroups after energy condensation. +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* IDL position of the average flux component associated with +* each volume. +* EVECT unknowns. +* IHOM homogenized index assigned to each element. +* IGCOND limit of condensed groups. +* IMPX print parameter (equal to zero for no print). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMAC1,IPMAC2 + PARAMETER(NREAC=11) + INTEGER NBMIX,NL,NBFIS,NGRP,NEL,NUN,NALBP,NZS,NGCOND,MAT(NEL), + 1 IDL(NEL),IHOM(NEL),IGCOND(NGCOND),IMPX + REAL VOL(NEL),EVECT(NUN,NGRP) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPMAC1,KPMAC1,JPMAC2,KPMAC2 + PARAMETER(NSTATE=40) + CHARACTER HREAC(NREAC)*12,TEXT12*12,SUFF*2,TEXT6*6 + INTEGER IDATA(NSTATE) + LOGICAL LNUSIG,LESTOP,LFIXE,LREAC(NREAC) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, DIMENSION(:), ALLOCATABLE :: IJJ,NJJ,IPOS + REAL, DIMENSION(:), ALLOCATABLE :: VOLI,WORK,SCAT,RATE,GAR,RATEF, + 1 DEN,DEN2 + REAL, DIMENSION(:,:), ALLOCATABLE :: FLINT,CHI,ZUFIS,ALBPGR, + 1 ALBP,OUTR,ESTOP,DEN3 + REAL, DIMENSION(:,:,:), ALLOCATABLE :: OUTSC + DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: ACCUM +*---- +* DATA STATEMENT +*---- + DATA HREAC/'NTOT0','SIGW00','NUSIGF','NFTOT','H-FACTOR', + 1 'OVERV','DIFF','DIFFX','DIFFY','DIFFZ','C-FACTOR'/ +*---- +* SCRATCH STORAGE ALLOCATION +* OUTR(IBM,NREAC+1): volume +* OUTR(IBM,NREAC+2): integrated direct flux +* OUTR(IBM,NREAC+3): fission spectrum +* OUTR(IBM,NREAC+4): fixed sources +*---- + ALLOCATE(VOLI(NZS),WORK(NZS),RATE(NZS),FLINT(NZS,NGRP), + 1 CHI(NBMIX,NBFIS),ZUFIS(NBMIX,NBFIS),OUTR(NZS+1,NREAC+4), + 2 OUTSC(NZS,NL+1,NGCOND),GAR(NGRP),ALBPGR(NALBP,NGRP), + 3 ALBP(NALBP,NGCOND),ESTOP(NZS,NGRP+1)) + ALLOCATE(ACCUM(NZS,NBFIS)) +* + ALBP(:NALBP,:NGCOND)=0.0 + ESTOP(:NZS,:NGRP+1)=0.0 + LNUSIG=.FALSE. + LESTOP=.FALSE. + LFIXE=.FALSE. + LREAC(:NREAC)=.FALSE. +*---- +* RECOVER PHYSICAL ALBEDOS. +*---- + IF(NALBP.GT.0) CALL LCMGET(IPMAC1,'ALBEDO',ALBPGR) +*---- +* DIRECT FLUX CALCULATION. +*---- + VOLI(:NZS)=0.0 + FLINT(:NZS,:NGRP)=0.0 + DO 20 K=1,NEL + IBM=IHOM(K) + IPFL=IDL(K) + IF((IBM.NE.0).AND.(MAT(K).NE.0).AND.(IPFL.NE.0)) THEN + VOLI(IBM)=VOLI(IBM)+VOL(K) + DO 10 IGR=1,NGRP + FLINT(IBM,IGR)=FLINT(IBM,IGR)+EVECT(IPFL,IGR)*VOL(K) + 10 CONTINUE + ENDIF + 20 CONTINUE + CALL LCMPUT(IPMAC2,'VOLUME',NZS,2,VOLI) +*---- +* FISSION RATE CALCULATION. +*---- + IF(IMPX.GT.0) WRITE(6,'(/35H OUTAUX: REACTION RATE CALCULATION.)') + JPMAC1=LCMGID(IPMAC1,'GROUP') + JPMAC2=LCMLID(IPMAC2,'GROUP',NGCOND) + IF(NBFIS.GT.0) THEN + ACCUM(:NZS,:NBFIS)=0.0D0 + DO 100 IGR=1,NGRP + KPMAC1=LCMGIL(JPMAC1,IGR) + CALL LCMGET(KPMAC1,'NUSIGF',ZUFIS) + DO 90 IFISS=1,NBFIS + DO 80 K=1,NEL + IBM=IHOM(K) + L=MAT(K) + IPFL=IDL(K) + IF((IBM.NE.0).AND.(L.NE.0).AND.(IPFL.NE.0)) THEN + ACCUM(IBM,IFISS)=ACCUM(IBM,IFISS)+EVECT(IPFL,IGR)*VOL(K)* + 1 ZUFIS(L,IFISS) + ENDIF + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + ENDIF +*---- +* LOOP OVER ENERGY GROUP LIST. +*---- + IGRFIN=0 + DO 500 IGRC=1,NGCOND + IGRDEB=IGRFIN+1 + IGRFIN=IGCOND(IGRC) + OUTR(:NZS+1,:NREAC+4)=0.0 + OUTSC(:NZS,:NL+1,:NGCOND)=0.0 + ALLOCATE(RATEF(NZS),DEN(NZS)) + RATEF(:NZS)=0.0 + DEN(:NZS)=0.0 + DO 310 IGR=IGRDEB,IGRFIN + KPMAC1=LCMGIL(JPMAC1,IGR) + DO 110 IBM=1,NZS + OUTR(IBM,NREAC+2)=OUTR(IBM,NREAC+2)+FLINT(IBM,IGR) + 110 CONTINUE +*---- +* SET VOLUMES. +*---- + DO 120 IBM=1,NZS + OUTR(IBM,NREAC+1)=VOLI(IBM) + 120 CONTINUE +*---- +* REACTION RATE CALCULATION. +*---- + DO 150 IREAC=1,NREAC + CALL LCMLEN(KPMAC1,HREAC(IREAC),LENGT,ITYLCM) + LREAC(IREAC)=LREAC(IREAC).OR.(LENGT.NE.0) + IF((HREAC(IREAC).EQ.'H-FACTOR').AND.(LENGT.EQ.0)) THEN + WRITE(6,'(/46H OUTAUX: *** WARNING *** NO H-FACTOR FOUND ON , + 1 25HLCM. USE NU*SIGF INSTEAD.)') + LNUSIG=.TRUE. + GO TO 150 + ELSE IF(HREAC(IREAC).EQ.'NUSIGF') THEN + GO TO 150 + ELSE IF(HREAC(IREAC).EQ.'SIGW00') THEN + GO TO 150 + ELSE + TEXT12=HREAC(IREAC) + ENDIF + IF(LENGT.GT.0) THEN + IF(LENGT.GT.NBMIX) CALL XABORT('OUTAUX: INVALID LENGTH FOR '// + 1 HREAC(IREAC)//' CROSS SECTIONS.') + CALL LCMGET(KPMAC1,TEXT12,WORK) + RATE(:NZS)=0.0 + DO 130 K=1,NEL + IBM=IHOM(K) + L=MAT(K) + IPFL=IDL(K) + IF((IBM.NE.0).AND.(L.NE.0).AND.(IPFL.NE.0)) THEN + RATE(IBM)=RATE(IBM)+EVECT(IPFL,IGR)*VOL(K)*WORK(L) + ENDIF + 130 CONTINUE + DO 140 IBM=1,NZS + OUTR(IBM,IREAC)=OUTR(IBM,IREAC)+RATE(IBM) + 140 CONTINUE + ENDIF + 150 CONTINUE +*---- +* FIXED SOURCES +*---- + CALL LCMLEN(KPMAC1,'FIXE',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + LFIXE=.TRUE. + IF(LENGT.GT.NBMIX) CALL XABORT('OUTAUX: INVALID LENGTH FOR '// + 1 'FIXE SOURCE.') + CALL LCMGET(KPMAC1,'FIXE',WORK) + RATE(:NZS)=0.0 + DO 160 K=1,NEL + IBM=IHOM(K) + L=MAT(K) + IPFL=IDL(K) + IF((IBM.NE.0).AND.(L.NE.0).AND.(IPFL.NE.0)) THEN + RATE(IBM)=RATE(IBM)+VOL(K)*WORK(L) + ENDIF + 160 CONTINUE + DO 170 IBM=1,NZS + OUTR(IBM,NREAC+4)=OUTR(IBM,NREAC+4)+RATE(IBM) + 170 CONTINUE + ENDIF +*---- +* SCATTERING MATRIX INFORMATION IGR <-- JGR. +*---- + ALLOCATE(IJJ(NBMIX),NJJ(NBMIX),IPOS(NBMIX)) + ALLOCATE(SCAT(NBMIX*NGRP)) + DO 220 IL=1,NL + WRITE(SUFF,'(I2.2)') IL-1 + CALL LCMLEN(KPMAC1,'NJJS'//SUFF,LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + IF(LENGT.GT.NBMIX) CALL XABORT('OUTAUX: INVALID LENGTH FOR '// + 1 'SCATTERING CROSS SECTIONS.') + CALL LCMLEN(KPMAC1,'SCAT'//SUFF,LENGT,ITYLCM) + IF(LENGT.GT.NBMIX*NGRP) CALL XABORT('OUTAUX: SCAT OVERFLOW.') + CALL LCMGET(KPMAC1,'NJJS'//SUFF,NJJ) + CALL LCMGET(KPMAC1,'IJJS'//SUFF,IJJ) + CALL LCMGET(KPMAC1,'IPOS'//SUFF,IPOS) + CALL LCMGET(KPMAC1,'SCAT'//SUFF,SCAT) + IPOSDE=0 + DO 210 K=1,NEL + IBM=IHOM(K) + L=MAT(K) + IPFL=IDL(K) + IF((IBM.NE.0).AND.(L.NE.0).AND.(IPFL.NE.0)) THEN + GAR(:NGRP)=0.0 + IPOSDE=IPOS(L)-1 + DO 180 JGR=IJJ(L),IJJ(L)-NJJ(L)+1,-1 + IPOSDE=IPOSDE+1 + GAR(JGR)=SCAT(IPOSDE) + 180 CONTINUE + JGRFIN=0 + DO 200 JGRC=1,NGCOND + JGRDEB=JGRFIN+1 + JGRFIN=IGCOND(JGRC) + DO 190 JGR=JGRDEB,JGRFIN + OUTSC(IBM,IL,JGRC)=OUTSC(IBM,IL,JGRC)+EVECT(IPFL,JGR)* + 1 VOL(K)*GAR(JGR) + 190 CONTINUE + 200 CONTINUE + ENDIF + 210 CONTINUE + IF(IL.EQ.1) OUTR(:NZS,2)=OUTSC(:NZS,IL,IGRC) + ENDIF + 220 CONTINUE + DEALLOCATE(SCAT) + DEALLOCATE(IJJ,NJJ,IPOS) +*---- +* FISSION SPECTRUM AND NUSIGF HOMOGENIZATION. +*---- + IF(NBFIS.GT.0) THEN + CALL LCMLEN(KPMAC1,'NUSIGF',LENGT,ITYLCM) + IF(LENGT.NE.NBMIX*NBFIS) CALL XABORT('OUTAUX: INVALID LENGTH ' + 1 //'FOR FISSION SPECTRUM.') + CALL LCMGET(KPMAC1,'NUSIGF',ZUFIS) + CALL LCMLEN(KPMAC1,'CHI',LENGT,ITYLCM) + DEN(:NZS)=0.0 + IF(LENGT.EQ.0) THEN + IF(IGR.EQ.IGRDEB) OUTR(:NZS,NREAC+3)=1.0 + ELSE + CALL LCMGET(KPMAC1,'CHI',CHI) + DO 240 K=1,NEL + IBM=IHOM(K) + L=MAT(K) + IF((IBM.NE.0).AND.(L.NE.0)) THEN + DO 230 IFISS=1,NBFIS + RATEF(IBM)=RATEF(IBM)+CHI(L,IFISS)*REAL(ACCUM(IBM,IFISS)) + DEN(IBM)=DEN(IBM)+REAL(ACCUM(IBM,IFISS)) + 230 CONTINUE + ENDIF + 240 CONTINUE + ENDIF + DO 260 IFISS=1,NBFIS + DO 250 K=1,NEL + IBM=IHOM(K) + L=MAT(K) + IPFL=IDL(K) + IF((IBM.NE.0).AND.(L.NE.0).AND.(IPFL.NE.0)) THEN + OUTR(IBM,3)=OUTR(IBM,3)+EVECT(IPFL,IGR)*VOL(K)*ZUFIS(L,IFISS) + ENDIF + 250 CONTINUE + 260 CONTINUE + ENDIF +*---- +* CONDENSE PHYSICAL ALBEDOS. +*---- + IF(NALBP.GT.0) THEN + DO 280 IAL=1,NALBP + DO 270 IBM=1,NZS + ALBP(IAL,IGRC)=ALBP(IAL,IGRC)+ALBPGR(IAL,IGR)*FLINT(IBM,IGR) + 270 CONTINUE + 280 CONTINUE + ENDIF +*---- +* RECOVER AND HOMOGENIZE STOPPING POWERS +*---- + CALL LCMLEN(KPMAC1,'ESTOPW',LENGT,ITYLCM) + IF(LENGT.EQ.2*NBMIX) THEN + ALLOCATE(DEN3(NBMIX,2)) + LESTOP=.TRUE. + CALL LCMGET(KPMAC1,'ESTOPW',DEN3) + DO 290 K=1,NEL + IBM=IHOM(K) + L=MAT(K) + IPFL=IDL(K) + IF((IBM.NE.0).AND.(L.NE.0).AND.(IPFL.NE.0)) THEN + IF(IGR.EQ.1) THEN + FACTOR=EVECT(IPFL,IGR)/FLINT(IBM,IGR) + ELSE + FACTOR=(EVECT(IPFL,IGR-1)+EVECT(IPFL,IGR))/ + 1 (FLINT(IBM,IGR-1)+FLINT(IBM,IGR)) + ENDIF + ESTOP(IBM,IGR)=ESTOP(IBM,IGR)+FACTOR*VOL(K)*DEN3(L,1) + ENDIF + 290 CONTINUE + IF(IGR.EQ.NGRP) THEN + DO 300 K=1,NEL + IBM=IHOM(K) + L=MAT(K) + IPFL=IDL(K) + IF((IBM.NE.0).AND.(L.NE.0).AND.(IPFL.NE.0)) THEN + FACTOR=EVECT(IPFL,IGR)/FLINT(IBM,IGR) + ESTOP(IBM,IGR+1)=ESTOP(IBM,IGR+1)+FACTOR*VOL(K)*DEN3(L,2) + ENDIF + 300 CONTINUE + ENDIF + DEALLOCATE(DEN3) + ENDIF + 310 CONTINUE +* + DO 340 K=1,NEL + IBM=IHOM(K) + L=MAT(K) + IPFL=IDL(K) + IF((IBM.NE.0).AND.(L.NE.0).AND.(IPFL.NE.0)) THEN + JGRFIN=0 + DO 330 JGRC=1,NGCOND + JGRDEB=JGRFIN+1 + JGRFIN=IGCOND(JGRC) + DO 320 JGR=JGRDEB,JGRFIN + OUTSC(IBM,NL+1,JGRC)=OUTSC(IBM,NL+1,JGRC)+EVECT(IPFL,JGR)*VOL(K) + 320 CONTINUE + 330 CONTINUE + ENDIF + 340 CONTINUE + IF(NBFIS.GT.0) THEN + DO 350 IBM=1,NZS + IF(DEN(IBM).NE.0.0) OUTR(IBM,NREAC+3)=RATEF(IBM)/DEN(IBM) + 350 CONTINUE + ENDIF + DEALLOCATE(DEN,RATEF) +*---- +* PRINT THE REACTION RATES: +*---- + IF(IMPX.GT.0) THEN + DO 360 I=1,NREAC+3 + OUTR(NZS+1,I)=0.0 + 360 CONTINUE + WRITE(6,520) IGRC,'VOLUME ','FLUX-INTG ', + 1 (HREAC(I),I=1,6),'CHI ' + DO 380 IBM=1,NZS + DO 370 I=1,NREAC+3 + OUTR(NZS+1,I)=OUTR(NZS+1,I)+OUTR(IBM,I) + 370 CONTINUE + WRITE(6,530) IBM,OUTR(IBM,NREAC+1),OUTR(IBM,NREAC+2), + 1 (OUTR(IBM,I),I=1,6),OUTR(IBM,NREAC+3) + 380 CONTINUE + WRITE(6,540) OUTR(NZS+1,NREAC+1),OUTR(NZS+1,NREAC+2), + 1 (OUTR(NZS+1,I),I=1,6) + ENDIF +*---- +* COMPUTE HOMOGENIZED-CONDENSED MACROLIB +*---- + KPMAC2=LCMDIL(JPMAC2,IGRC) + CALL LCMPUT(KPMAC2,'FLUX-INTG',NZS,2,OUTR(1,NREAC+2)) + DO 400 IREAC=1,NREAC + IF(LREAC(IREAC)) THEN + DO 390 IBM=1,NZS + RATE(IBM)=OUTR(IBM,IREAC) + IF(RATE(IBM).NE.0.0) RATE(IBM)=RATE(IBM)/OUTR(IBM,NREAC+2) + 390 CONTINUE + CALL LCMPUT(KPMAC2,HREAC(IREAC),NZS,2,RATE) + IF(LNUSIG.AND.(IREAC.EQ.3)) THEN + CALL LCMPUT(KPMAC2,'H-FACTOR',NZS,2,RATE) + ENDIF + ENDIF + 400 CONTINUE + IF(LREAC(3)) CALL LCMPUT(KPMAC2,'CHI',NZS,2,OUTR(1,NREAC+3)) + IF(LFIXE) THEN + DO 410 IBM=1,NZS + RATE(IBM)=OUTR(IBM,NREAC+4) + IF(RATE(IBM).NE.0.0) RATE(IBM)=RATE(IBM)/VOLI(IBM) + 410 CONTINUE + CALL LCMPUT(KPMAC2,'FIXE',NZS,2,RATE) + ENDIF +* + ALLOCATE(IJJ(NZS),NJJ(NZS),IPOS(NZS)) + ALLOCATE(SCAT(NZS*NGCOND)) + DO 460 IL=1,NL + WRITE(SUFF,'(I2.2)') IL-1 + DO 430 IBM=1,NZS + IGMIN=IGRC + IGMAX=IGRC + DO 420 JGRC=NGCOND,1,-1 + IF(OUTSC(IBM,IL,JGRC).NE.0.0) THEN + IGMIN=MIN(IGMIN,JGRC) + IGMAX=MAX(IGMAX,JGRC) + OUTSC(IBM,IL,JGRC)=OUTSC(IBM,IL,JGRC)/OUTSC(IBM,NL+1,JGRC) + ENDIF + 420 CONTINUE + IJJ(IBM)=IGMAX + NJJ(IBM)=IGMAX-IGMIN+1 + 430 CONTINUE + IPOSDE=0 + DO 450 IBM=1,NZS + IPOS(IBM)=IPOSDE+1 + DO 440 JGRC=IJJ(IBM),IJJ(IBM)-NJJ(IBM)+1,-1 + IPOSDE=IPOSDE+1 + SCAT(IPOSDE)=OUTSC(IBM,IL,JGRC) + 440 CONTINUE + 450 CONTINUE + CALL LCMPUT(KPMAC2,'SCAT'//SUFF,IPOSDE,2,SCAT) + CALL LCMPUT(KPMAC2,'IPOS'//SUFF,NZS,1,IPOS) + CALL LCMPUT(KPMAC2,'NJJS'//SUFF,NZS,1,NJJ) + CALL LCMPUT(KPMAC2,'IJJS'//SUFF,NZS,1,IJJ) + CALL LCMPUT(KPMAC2,'SIGW'//SUFF,NZS,2,OUTSC(1,IL,IGRC)) + 460 CONTINUE + DEALLOCATE(SCAT) + DEALLOCATE(IJJ,NJJ,IPOS) +* + IF(NALBP.GT.0) THEN + DFI=0.0 + DO 470 IBM=1,NZS + DFI=DFI+OUTR(IBM,NREAC+2) + 470 CONTINUE + DO 480 IAL=1,NALBP + ALBP(IAL,IGRC)=ALBP(IAL,IGRC)/DFI + 480 CONTINUE + ENDIF +*---- +* SAVE STOPPING POWERS +*---- + IF(LESTOP) THEN + ALLOCATE(DEN3(NZS,2)) + DO 490 IBM=1,NZS + IF(IGRC.EQ.1) THEN + DEN3(IBM,1)=ESTOP(IBM,1) + ELSE + DEN3(IBM,1)=ESTOP(IBM,IGCOND(IGRC-1)) + ENDIF + DEN3(IBM,2)=ESTOP(IBM,IGCOND(IGRC)+1) + 490 CONTINUE + CALL LCMPUT(KPMAC2,'ESTOPW',NZS*2,2,DEN3) + DEALLOCATE(DEN3) + ENDIF + 500 CONTINUE +*---- +* END OF LOOP OVER MACROGROUPS +*---- +*---- +* RECOVER AND CONDENSE ENERGY MESH +*---- + CALL LCMLEN(IPMAC1,'ENERGY',LENGT,ITYLCM) + IF(LENGT.EQ.NGRP+1) THEN + ALLOCATE(DEN(NGRP+1),DEN2(NGCOND+1)) + CALL LCMGET(IPMAC1,'ENERGY',DEN) + DEN2(1)=DEN(1) + DO 510 IGRC=1,NGCOND + DEN2(IGRC+1)=DEN(IGCOND(IGRC)+1) + 510 CONTINUE + CALL LCMPUT(IPMAC2,'ENERGY',NGCOND+1,2,DEN2) + DEALLOCATE(DEN2,DEN) + ENDIF +*---- +* SAVE ALBEDO AND STATE-VECTOR +*---- + IF(NALBP.GT.0) THEN + CALL LCMPUT(IPMAC2,'ALBEDO',NALBP*NGCOND,2,ALBP) + ENDIF + CALL LCMLEN(IPMAC1,'PARTICLE',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + CALL LCMGTC(IPMAC1,'PARTICLE',12,TEXT6) + CALL LCMPTC(IPMAC2,'PARTICLE',12,TEXT6) + ENDIF + IDATA(:NSTATE)=0 + IDATA(1)=NGCOND + IDATA(2)=NZS + IDATA(3)=NL + IDATA(4)=1 + IDATA(8)=NALBP + IF(LREAC(7)) THEN + IDATA(9)=1 + ELSE IF(LREAC(8)) THEN + IDATA(9)=2 + ENDIF + IDATA(15)=0 + CALL LCMPUT(IPMAC2,'STATE-VECTOR',NSTATE,1,IDATA) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(ACCUM) + DEALLOCATE(ESTOP,ALBP,ALBPGR,GAR,OUTSC,OUTR,ZUFIS,CHI,FLINT, + 1 RATE,WORK,VOLI) + RETURN +* + 520 FORMAT(/' G R O U P : ',I3/1X,'IHOM',9A14) + 530 FORMAT(1X,I4,1P,9E14.5) + 540 FORMAT(/5H SUM,1P,8E14.5) + END diff --git a/Trivac/src/OUTDRV.f b/Trivac/src/OUTDRV.f new file mode 100755 index 0000000..f377715 --- /dev/null +++ b/Trivac/src/OUTDRV.f @@ -0,0 +1,265 @@ +*DECK OUTDRV + SUBROUTINE OUTDRV (IPGEOM,IPMAC1,IPFLUX,IPMAC2,MAXNEL,NBMIX,NL, + 1 NBFIS,NGRP,NEL,NUN,NALBP,HTRACK,IELEM,ICOL,MAT,VOL,IDL,TITR,IBFP) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Driver for the post-treatment of reactor calculation results. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A Hebert +* +*Parameters: input +* IPGEOM L_GEOM pointer to the geometry. +* IPMAC1 L_MACROLIB pointer to the nuclear properties. +* IPFLUX L_FLUX pointer to the solution. +* IPMAC2 L_MACROLIB pointer to the edition information. +* MAXNEL maximum number of finite elements. +* NBMIX number of material mixtures. +* NL scattering anisotropy. +* NBFIS number of fissionable isotopes. +* NGRP total number of energy groups. +* NEL total number of finite elements. +* NUN total number of unknowns per group. +* NALBP number of physical albedos. +* HTRACK type of tracking (equal to 'BIVAC' or 'TRIVAC'). +* IELEM degree of the Lagrangian finite elements: +* ICOL type of quadrature used to integrate the mass matrix +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* IDL position of the average flux component associated with +* each volume. +* TITR title. +* IBFP Boltzmann Fokker-Planck calculations. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPGEOM,IPMAC1,IPMAC2,IPFLUX + CHARACTER TITR*72,HTRACK*12 + INTEGER MAXNEL,NBMIX,NL,NBFIS,NGRP,NEL,NUN,NALBP,IELEM,ICOL, + 1 MAT(NEL),IDL(NEL),IBFP + REAL VOL(NEL) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPMAC1,KPMAC1 + CHARACTER TEXT4*4 + REAL NORM + DOUBLE PRECISION DFLOTT,ZNORM + INTEGER, DIMENSION(:), ALLOCATABLE :: IHOM,IGCOND,MATCOD + REAL, DIMENSION(:), ALLOCATABLE :: SGD,FLUXC + REAL, DIMENSION(:,:), ALLOCATABLE :: EVECT,ADECT,ZUFIS,ESTOPW +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IHOM(NEL),IGCOND(NGRP),EVECT(NUN,NGRP),SGD(NBMIX), + 1 FLUXC(NEL),MATCOD(NEL)) +* + TKR=0.0 + IMPX=1 + IADJ=0 + NGCOND=NGRP + DO IGR=1,NGRP + IGCOND(IGR)=IGR + ENDDO + LMOD=0 + CALL KDRCPU(TK1) +*---- +* RECOVER THE K-EFFECTIVE AND THE DIRECT FLUX. +*---- + CALL LCMLEN(IPFLUX,'K-EFFECTIVE',ILEN,ITYLCM) + IF(ILEN.GT.0) THEN + CALL LCMGET(IPFLUX,'K-EFFECTIVE',FKEFF) + CALL LCMPUT(IPMAC2,'K-EFFECTIVE',1,2,FKEFF) + ENDIF + CALL LCMLEN(IPFLUX,'NORM-FS',ILEN,ITYLCM) + IF(ILEN.GT.0) THEN + CALL LCMGET(IPFLUX,'NORM-FS',NORM) + CALL LCMPUT(IPMAC2,'NORM-FS',1,2,NORM) + CALL LCMGET(IPFLUX,'MATCOD',MATCOD) + CALL LCMPUT(IPMAC2,'MATCOD',NEL,1,MATCOD) + ENDIF + CALL LCMLEN(IPFLUX,'FLUXC',ILEN,ITYLCM) + IF(ILEN.GT.0) THEN + CALL LCMGET(IPFLUX,'FLUXC',FLUXC) + CALL LCMPUT(IPMAC2,'FLUXC',NEL,2,FLUXC) + CALL LCMGET(IPFLUX,'ECUTOFF',ECUTOFF) + CALL LCMPUT(IPMAC2,'ECUTOFF',1,2,ECUTOFF) + ENDIF +* + 20 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('OUTDRV: CHARACTER DATA EXPECTED.') +* + IF(TEXT4.EQ.'EDIT') THEN + CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('OUTDRV: INTEGER DATA EXPECTED.') + ELSE IF(TEXT4.EQ.'MODE') THEN + CALL REDGET(INDIC,LMOD,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('OUTDRV: INTEGER DATA EXPECTED.') + ELSE IF(TEXT4.EQ.'DIRE') THEN + IADJ=0 + ELSE IF(TEXT4.EQ.'PROD') THEN + IADJ=1 + ELSE + CALL OUTFLX(IPFLUX,0,NGRP,NUN,LMOD,IMPX,EVECT) + IF(IBFP.GT.0) THEN + JPMAC1=LCMGID(IPMAC1,'GROUP') + KPMAC1=LCMGIL(JPMAC1,NGRP) + CALL LCMLEN(KPMAC1,'ESTOPW',LENGT,ITYLCM) + IF(LENGT.NE.2*NBMIX) CALL XABORT('OUTDRV: ESTOPW REQUIRED.') + ALLOCATE(ESTOPW(NBMIX,2)) + CALL LCMGET(KPMAC1,'ESTOPW',ESTOPW) + CALL LCMPUT(IPMAC2,'ESTOPW',NBMIX,2,ESTOPW(:,2)) + DEALLOCATE(ESTOPW) + ENDIF + GO TO 40 + ENDIF + GO TO 20 +* + 30 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('OUTDRV: CHARACTER DATA EXPECTED.') +* + 40 IF(TEXT4.EQ.'POWR') THEN +* NORMALIZATION TO A GIVEN FISSION POWER. + CALL REDGET (INDIC,NITMA,POWER,TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('OUTDRV: REAL DATA EXPECTED.') +* NORMALIZATION FACTOR FOR THE DIRECT FLUX. + ZNORM=0.0D0 + JPMAC1=LCMGID(IPMAC1,'GROUP') + DO 60 IGR=1,NGRP + KPMAC1=LCMGIL(JPMAC1,IGR) + CALL LCMLEN(KPMAC1,'H-FACTOR',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + CALL LCMGET(KPMAC1,'H-FACTOR',SGD) + ELSE + WRITE(6,'(/43H OUTDRV: *** WARNING *** NO H-FACTOR FOUND , + 1 28HON LCM. USE NU*SIGF INSTEAD.)') + ALLOCATE(ZUFIS(NBMIX,NBFIS)) + SGD(:NBMIX)=0.0 + CALL LCMGET(KPMAC1,'NUSIGF',ZUFIS) + DO IBM=1,NBMIX + DO IFISS=1,NBFIS + SGD(IBM)=SGD(IBM)+ZUFIS(IBM,IFISS) + ENDDO + ENDDO + DEALLOCATE(ZUFIS) + ENDIF + DO 50 K=1,NEL + L=MAT(K) + IF((L.EQ.0).OR.(IDL(K).EQ.0)) GO TO 50 + ZNORM=ZNORM+EVECT(IDL(K),IGR)*VOL(K)*SGD(L) + 50 CONTINUE + 60 CONTINUE + ZNORM=POWER/ZNORM + WRITE(6,300) ' DIRECT',ZNORM + DO 80 IGR=1,NGRP + DO 70 I=1,NUN + EVECT(I,IGR)=EVECT(I,IGR)*REAL(ZNORM) + 70 CONTINUE + 80 CONTINUE + ELSE IF(TEXT4.EQ.'SOUR') THEN +* NORMALIZATION TO A GIVEN SOURCE INTENSITY. + CALL REDGET (INDIC,NITMA,SNUMB,TEXT4,DFLOTT) + IF(INDIC.NE.2) CALL XABORT('OUTDRV: REAL DATA EXPECTED.') +* NORMALIZATION FACTOR FOR THE DIRECT FLUX. + ZNORM=0.0D0 + JPMAC1=LCMGID(IPMAC1,'GROUP') + DO 100 IGR=1,NGRP + KPMAC1=LCMGIL(JPMAC1,IGR) + CALL LCMLEN(KPMAC1,'FIXE',LENGT,ITYLCM) + IF(LENGT.EQ.0) THEN + CALL LCMLIB(KPMAC1) + CALL XABORT('OUTDRV: SOURCE RECORD MISSING IN MACROLIB.') + ENDIF + CALL LCMGET(KPMAC1,'FIXE',SGD) + DO 90 K=1,NEL + L=MAT(K) + IF(L.GT.0) ZNORM=ZNORM+VOL(K)*SGD(L) + 90 CONTINUE + 100 CONTINUE + ZNORM=SNUMB/ZNORM + WRITE(6,305) ' DIRECT',ZNORM + DO 120 IGR=1,NGRP + DO 110 I=1,NUN + EVECT(I,IGR)=EVECT(I,IGR)*REAL(ZNORM) + 110 CONTINUE + 120 CONTINUE + ELSE IF(TEXT4.EQ.'COND') THEN + NGCOND=0 + CALL REDGET (INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.EQ.3) THEN + IF(TEXT4.EQ.'NONE') THEN + NGCOND=NGRP + DO IGR=1,NGRP + IGCOND(IGR)=IGR + ENDDO + GO TO 30 + ENDIF + NGCOND=1 + IGCOND(NGCOND)=NGRP + GO TO 40 + ELSE IF(INDIC.EQ.1) THEN + 130 IF(NITMA.GT.NGRP) NITMA=NGRP + NGCOND=NGCOND+1 + IGCOND(NGCOND)=NITMA + CALL REDGET (INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.EQ.1) THEN + GO TO 130 + ELSE IF(INDIC.EQ.3) THEN + GO TO 40 + ELSE + CALL XABORT('OUTDRV: INTEGER OR CHARACTER DATA EXPECTED.') + ENDIF + ELSE + CALL XABORT('OUTDRV: INTEGER OR CHARACTER DATA EXPECTED.') + ENDIF + ELSE IF(TEXT4.EQ.'INTG') THEN +* COMPUTE AND DISPLAY THE MACRO-ZONE REACTION RATES. +* READ THE MACRO-ZONES DEFINITION. + IF(IMPX.GT.0) WRITE(6,330) (IGCOND(IG),IG=1,NGCOND) + CALL OUTHOM (MAXNEL,IPGEOM,IMPX,NEL,IELEM,ICOL,HTRACK,MAT,NZS, + 1 IHOM) + IF(NZS.GT.NEL) CALL XABORT('OUTDRV: INVALID VALUE OF NZS.') + IF(IMPX.GT.0) WRITE(6,320) TITR + IF(IADJ.EQ.0) THEN + CALL OUTAUX(IPMAC1,IPMAC2,NBMIX,NL,NBFIS,NGRP,NEL,NUN,NALBP, + 1 NZS,NGCOND,MAT,VOL,IDL,EVECT,IHOM,IGCOND,IMPX) + ELSE IF(IADJ.EQ.1) THEN + ALLOCATE(ADECT(NUN,NGRP)) + CALL OUTFLX(IPFLUX,1,NGRP,NUN,LMOD,IMPX,ADECT) + CALL OUTPRO(IPMAC1,IPMAC2,NBMIX,NL,NBFIS,NGRP,NEL,NUN,NALBP, + 1 NZS,NGCOND,MAT,VOL,IDL,EVECT,ADECT,IHOM,IGCOND,IMPX) + DEALLOCATE(ADECT) + ENDIF + ELSE IF(TEXT4.EQ.';') THEN + CALL KDRCPU(TK2) + TKR=TK2-TK1 + WRITE(6,310) TKR + GO TO 140 + ELSE + CALL XABORT('OUTDRV: '//TEXT4//' IS AN INVALID KEY WORD.') + ENDIF + GO TO 30 +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + 140 DEALLOCATE(FLUXC,SGD,EVECT,IGCOND,IHOM) + RETURN +* + 300 FORMAT(/9H OUTDRV: ,A7,28H FLUX NORMALIZATION FACTOR =,1P,E13.5) + 305 FORMAT(/9H OUTDRV: ,A7,30H SOURCE NORMALIZATION FACTOR =,1P,E13.5) + 310 FORMAT(/49H OUTDRV: CPU TIME FOR REACTION RATE CALCULATION =,F7.3) + 320 FORMAT(/12H OUTDRV: ***,A72,3H***) + 330 FORMAT(/20H CONDENSATION INDEX:/(1X,14I5)) + END diff --git a/Trivac/src/OUTFLX.f b/Trivac/src/OUTFLX.f new file mode 100755 index 0000000..2cf83c7 --- /dev/null +++ b/Trivac/src/OUTFLX.f @@ -0,0 +1,89 @@ +*DECK OUTFLX + SUBROUTINE OUTFLX(IPFLUX,ITYP,NGRP,NUN,LMOD,IMPX,EVECT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover the direct or adjoint flux. +* +*Copyright: +* Copyright (C) 2012 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A Hebert +* +*Parameters: input +* IPFLUX L_FLUX pointer to the solution. +* ITYP type of flux (=0: direct; =1: adjoint). +* NGRP total number of energy groups. +* NUN total number of unknowns per group. +* LMOD index of mode. +* IMPX print flag. +* +*Parameters: output +* EVECT flux. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPFLUX + INTEGER ITYP,NGRP,NUN,LMOD,IMPX + REAL EVECT(NUN,NGRP) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPFLUX,KPFLUX,MPFLUX +* + IF(ITYP.EQ.0) THEN +* RECOVER THE DIRECT FLUX. + IF(IMPX.GT.0) WRITE(6,20) 'DIRECT' + CALL LCMLEN(IPFLUX,'K-EFFECTIVE',ILEN,ITYLCM) + IF(ILEN.GT.0) CALL LCMGET(IPFLUX,'K-EFFECTIVE',FKEFF) + CALL LCMLEN(IPFLUX,'FLUX',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + MPFLUX=LCMGID(IPFLUX,'FLUX') + ELSE + CALL LCMLEN(IPFLUX,'MODE',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + IF(LMOD.LE.0) CALL XABORT('OUTFLX: INVALID MODE INDEX.') + JPFLUX=LCMGID(IPFLUX,'MODE') + KPFLUX=LCMGIL(JPFLUX,LMOD) + MPFLUX=LCMGID(KPFLUX,'FLUX') + ELSE + CALL LCMLIB(IPFLUX) + CALL XABORT('OUTFLX: UNABLE TO RECOVER A DIRECT FLUX.') + ENDIF + ENDIF + ELSE IF(ITYP.EQ.1) THEN +* RECOVER THE ADJOINT FLUX. + IF(IMPX.GT.0) WRITE(6,20) 'ADJOINT' + CALL LCMLEN(IPFLUX,'AK-EFFECTIVE',ILEN,ITYLCM) + IF(ILEN.GT.0) CALL LCMGET(IPFLUX,'AK-EFFECTIVE',FKEFF) + CALL LCMLEN(IPFLUX,'AFLUX',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + MPFLUX=LCMGID(IPFLUX,'AFLUX') + ELSE + CALL LCMLEN(IPFLUX,'MODE',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + IF(LMOD.LE.0) CALL XABORT('OUTFLX: INVALID MODE INDEX.') + JPFLUX=LCMGID(IPFLUX,'MODE') + KPFLUX=LCMGIL(JPFLUX,LMOD) + MPFLUX=LCMGID(KPFLUX,'AFLUX') + ELSE + CALL LCMLIB(IPFLUX) + CALL XABORT('OUTFLX: UNABLE TO RECOVER AN ADJOINT FLUX.') + ENDIF + ENDIF + ENDIF + DO 10 IGR=1,NGRP + CALL LCMGDL(MPFLUX,IGR,EVECT(1,IGR)) + 10 CONTINUE + RETURN + 20 FORMAT(/21H OUTFLX: RECOVER THE ,A,6H FLUX.) + END diff --git a/Trivac/src/OUTHOM.f b/Trivac/src/OUTHOM.f new file mode 100755 index 0000000..45341bf --- /dev/null +++ b/Trivac/src/OUTHOM.f @@ -0,0 +1,249 @@ +*DECK OUTHOM + SUBROUTINE OUTHOM(MAXNEL,IPGEOM,IMPX,NEL,IELEM,ICOL,HTRACK,MAT, + 1 NZS,IHOM) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read an modify the merge indices. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXNEL maximum number of elements. +* IPGEOM L_GEOM pointer to the geometry. +* IMPX print parameter. +* NEL total number of finite elements. +* IELEM degree of the Lagrangian finite elements: +* ICOL type of quadrature used to integrate the mass matrix +* HTRACK type of tracking (equal to 'BIVAC' or 'TRIVAC'). +* MAT index-number of the mixture type assigned to each volume. +* +*Parameters: output +* NZS number of merged regions. +* IHOM merge indices. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPGEOM + CHARACTER HTRACK*12 + INTEGER MAXNEL,IMPX,NEL,IELEM,ICOL,MAT(NEL),NZS,IHOM(NEL) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + INTEGER ISTATE(NSTATE),NCODE(6),ICODE(6) + REAL ZCODE(6) + LOGICAL ILK,LDIAG,CHEX,LFOLD1,LFOLD2,LFOLD3 + DOUBLE PRECISION DFLOTT + CHARACTER TEXT4*4,HSMG*131 + INTEGER, DIMENSION(:), ALLOCATABLE :: MAT2,DPP,MX,XXX,YYY,ZZZ + INTEGER, DIMENSION(:), ALLOCATABLE :: ISPLX,ISPLY,ISPLZ + EQUIVALENCE (ITYPE,ISTATE(1)),(LR1,ISTATE(2)),(LX1,ISTATE(3)), + 1 (LY1,ISTATE(4)),(LZ1,ISTATE(5)) +*---- +* DETERMINE THE MESH SPLITTING INFO FROM THE GEOMETRY. +*---- + ALLOCATE(ISPLX(MAXNEL),ISPLY(MAXNEL),ISPLZ(MAXNEL)) + ALLOCATE(XXX(MAXNEL+1),YYY(MAXNEL+1),ZZZ(MAXNEL+1)) +* + ALLOCATE(MAT2(MAXNEL)) + CALL READ3D(MAXNEL,MAXNEL,MAXNEL,MAXNEL,IPGEOM,IHEX,IR,ILK,SIDE, + 1 XXX,YYY,ZZZ,IMPX,LX,LY,LZ,MAT2,IPAS,NCODE,ICODE,ZCODE,ISPLX, + 2 ISPLY,ISPLZ,ISPLH,ISPLL) + DEALLOCATE(MAT2) +* + CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE) + LYOLD=1 + LZOLD=1 + NELOLD=0 + IF(ITYPE.EQ.2) THEN +* 1-D CARTESIAN GEOMETRY. + LXOLD=LX1 + NELOLD=LXOLD + ELSE IF((ITYPE.EQ.3).OR.(ITYPE.EQ.4)) THEN +* 1-D CYLINDRICAL/SPHERICAL GEOMETRY. + LXOLD=LR1 + NELOLD=LXOLD + ELSE IF(ITYPE.EQ.5) THEN +* 2-D CARTESIAN GEOMETRY. + LXOLD=LX1 + LYOLD=LY1 + NELOLD=LXOLD*LYOLD + LDIAG=.FALSE. + DO 30 IC=1,4 + LDIAG=LDIAG.OR.(NCODE(IC).EQ.3) + 30 CONTINUE + IF(LDIAG) NELOLD=(LXOLD+1)*LXOLD/2 + ELSE IF(ITYPE.EQ.6) THEN +* 2-D CYLINDRICAL GEOMETRY. + LXOLD=LR1 + LZOLD=LZ1 + NELOLD=LXOLD*LZOLD + ELSE IF(ITYPE.EQ.7) THEN +* 3-D CARTESIAN GEOMETRY. + LXOLD=LX1 + LYOLD=LY1 + LZOLD=LZ1 + NELOLD=LXOLD*LYOLD*LZOLD + LDIAG=.FALSE. + DO 40 IC=1,4 + LDIAG=LDIAG.OR.(NCODE(IC).EQ.3) + 40 CONTINUE + IF(LDIAG) NELOLD=(LXOLD+1)*LXOLD*LZOLD/2 + ELSE IF(ITYPE.EQ.8) THEN +* 2-D HEXAGONAL GEOMETRY. + LXOLD=LX1 + NELOLD=LXOLD + ELSE IF(ITYPE.EQ.9) THEN +* 3-D HEXAGONAL GEOMETRY. + LXOLD=LX1 + LZOLD=LZ1 + NELOLD=LXOLD*LZOLD + ENDIF +*---- +* READ THE MERGE INDICES. +*---- + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.EQ.1) THEN + DO 160 K=1,NELOLD + IHOM(K)=0 + 160 CONTINUE + IHOM(1)=NITMA + NZS=NITMA + DO 170 K=2,NELOLD + CALL REDGET(INDIC,IHOM(K),FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('OUTHOM: INTEGER EXPECTED.') + NZS=MAX(NZS,IHOM(K)) + 170 CONTINUE + IF((ITYPE.EQ.8).OR.(ITYPE.EQ.9)) CALL LCMGET(IPGEOM,'IHEX',IHEX) + ELSE IF((INDIC.EQ.3).AND.(TEXT4.EQ.'NONE')) THEN + NZS=NEL + DO 180 K=1,NEL + IHOM(K)=K + 180 CONTINUE + GO TO 270 + ELSE IF((INDIC.EQ.3).AND.(TEXT4.EQ.'IN')) THEN + DO 190 K=1,NELOLD + IHOM(K)=K + 190 CONTINUE + NZS=NELOLD + IF((ITYPE.EQ.8).OR.(ITYPE.EQ.9)) CALL LCMGET(IPGEOM,'IHEX',IHEX) + ELSE IF((INDIC.EQ.3).AND.(TEXT4.EQ.'MIX')) THEN + CALL LCMLEN(IPGEOM,'MIX',ILONG,ITYLCM) + IF(ILONG.NE.NELOLD) THEN + WRITE(HSMG,'(42HOUTHOM: INCONSISTENT INTG MIX OPTION (EXPE, + 1 24HCTED NUMBER OF MIXTURES=,I5,24H; VALUE FOUND IN L_GEOM , + 2 7HOBJECT=,I5,2H).)') NELOLD,ILONG + CALL XABORT(HSMG) + ENDIF + CALL LCMGET(IPGEOM,'MIX',IHOM) + NZS=0 + DO 200 K=1,NELOLD + NZS=MAX(NZS,IHOM(K)) + 200 CONTINUE + IF((ITYPE.EQ.8).OR.(ITYPE.EQ.9)) CALL LCMGET(IPGEOM,'IHEX',IHEX) + ELSE + CALL XABORT('OUTHOM: INVALID KEY WORD.') + ENDIF +*---- +* UNFOLD HEXAGONAL GEOMETRY IN BIVAC AND TRIVAC CASES. +*---- + CHEX=(ITYPE.EQ.8).OR.(ITYPE.EQ.9) + LFOLD1=CHEX.AND.(IHEX.NE.9).AND.(HTRACK.EQ.'TRIVAC') + LFOLD2=CHEX.AND.(IHEX.NE.9).AND.(HTRACK.EQ.'BIVAC').AND. + 1 (IELEM.GT.0).AND.(ICOL.LE.3) + LFOLD3=CHEX.AND.(IHEX.NE.9).AND.((HTRACK.EQ.'MCCG').OR. + 1 (HTRACK.EQ.'EXCELL')) + IF(LFOLD1.OR.LFOLD2.OR.LFOLD3) THEN + IF(NELOLD.NE.LXOLD*LZOLD) CALL XABORT('OUTHOM: HEXAGONAL SPLI' + 1 //'T ERROR.') + ALLOCATE(DPP(MAXNEL),MX(NELOLD)) + DO 205 I=1,NELOLD + MX(I)=IHOM(I) + 205 CONTINUE + LXOLD=LX1 + CALL BIVALL(MAXNEL,IHEX,LXOLD,LX,DPP) + DO 215 KZ=1,LZOLD + DO 210 KX=1,LX + IHOM(KX+(KZ-1)*LX)=0 + KEL=DPP(KX)+(KZ-1)*LXOLD + IF(KEL.GT.LXOLD*LZOLD) CALL XABORT('OUTHOM: MX OVERFLOW.') + IHOM(KX+(KZ-1)*LX)=MX(KEL) + 210 CONTINUE + 215 CONTINUE + DEALLOCATE(MX,DPP) + LXOLD=LX + IHEX=9 + ENDIF +*---- +* MESH-SPLITTING FOR THE IHOM VECTOR. +*---- + IF(NZS.GT.NELOLD) CALL XABORT('OUTHOM: FAILURE 1.') + IF(ISTATE(11).NE.0) THEN + CALL SPLIT0(MAXNEL,ITYPE,NCODE,LXOLD,LYOLD,LZOLD,ISPLX,ISPLY, + 1 ISPLZ,0,ISPLL,NEL2,LX,LY,LZ,SIDE,XXX,YYY,ZZZ,IHOM,.FALSE.,IMPX) + ENDIF +*---- +* FORCE DIAGONAL SYMMETRY AND UNFOLD THE IHOM VECTOR. +*---- + IF((NCODE(2).EQ.3).AND.(NCODE(3).EQ.3)) THEN + IF(NEL.EQ.LX*LY*LZ) THEN + K=(LX*(LX+1)/2)*LZ + DO 232 IZ=LZ,1,-1 + IOFF=(IZ-1)*LX*LY + DO 231 IY=LY,1,-1 + DO 220 IX=LX,IY+1,-1 + IHOM(IOFF+(IY-1)*LX+IX)=IHOM(IOFF+(IX-1)*LY+IY) + 220 CONTINUE + DO 230 IX=IY,1,-1 + IHOM(IOFF+(IY-1)*LX+IX)=IHOM(K) + K=K-1 + 230 CONTINUE + 231 CONTINUE + 232 CONTINUE + IF(K.NE.0) CALL XABORT('OUTHOM: FAILURE 2.') + ENDIF + ELSE IF((NCODE(1).EQ.3).AND.(NCODE(4).EQ.3)) THEN + IF(NEL.EQ.LX*LY*LZ) THEN + K=(LX*(LX+1)/2)*LZ + DO 242 IZ=LZ,1,-1 + IOFF=(IZ-1)*LX*LY + DO 241 IY=LY,1,-1 + DO 240 IX=LX,IY,-1 + IHOM(IOFF+(IY-1)*LX+IX)=IHOM(K) + K=K-1 + 240 CONTINUE + 241 CONTINUE + 242 CONTINUE + DO 252 IZ=1,LZ + IOFF=(IZ-1)*LX*LY + DO 251 IY=1,LY + DO 250 IX=1,IY-1 + IHOM(IOFF+(IY-1)*LX+IX)=IHOM(IOFF+(IX-1)*LY+IY) + 250 CONTINUE + 251 CONTINUE + 252 CONTINUE + IF(K.NE.0) CALL XABORT('OUTHOM: FAILURE 3.') + ENDIF + ENDIF + DEALLOCATE(ZZZ,YYY,XXX,ISPLZ,ISPLY,ISPLX) + DO 260 K=1,NEL + IF(MAT(K).EQ.0) IHOM(K)=0 + 260 CONTINUE + 270 IF(IMPX.GT.0) THEN + WRITE(6,'(/15H MERGING INDEX:/(1X,14I5))') (IHOM(K),K=1,NEL) + ENDIF + RETURN + END diff --git a/Trivac/src/OUTPRO.f b/Trivac/src/OUTPRO.f new file mode 100755 index 0000000..dc7b7c6 --- /dev/null +++ b/Trivac/src/OUTPRO.f @@ -0,0 +1,559 @@ +*DECK OUTPRO + SUBROUTINE OUTPRO (IPMAC1,IPMAC2,NBMIX,NL,NBFIS,NGRP,NEL,NUN, + 1 NALBP,NZS,NGCOND,MAT,VOL,IDL,EVECT,ADECT,IHOM,IGCOND,IMPX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform direct-adjoint homogenization into NZS regions and +* condensation into NGCOND macrogroups based on averaged fluxes +* contained in EVECT and adjoint fluxes contained in ADECT. Create +* an output extended macrolib containing homogenized volumes, +* integrated fluxes and cross sections. +* +*Copyright: +* Copyright (C) 2018 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPMAC1 L_MACROLIB pointer to the input macrolib. +* IPMAC2 L_MACROLIB pointer to the output extended macrolib. +* NBMIX number of material mixtures. +* NL scattering anisotropy. +* NBFIS number of fissionable isotopes. +* NGRP total number of energy groups. +* NEL number of finite elements. +* NUN number of unknowns per energy group. +* NALBP number of physical albedos. +* NZS number of homogenized regions so that NZS=max(IHOM(i)). +* NGCOND number of macrogroups after energy condensation. +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* IDL position of the average flux component associated with +* each volume. +* EVECT unknowns. +* ADECT adjoint flux unknowns. +* IHOM homogenized index assigned to each element. +* IGCOND limit of condensed groups. +* IMPX print parameter (equal to zero for no print). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMAC1,IPMAC2 + PARAMETER(NREAC=11) + INTEGER NBMIX,NL,NBFIS,NGRP,NEL,NUN,NALBP,NZS,NGCOND,MAT(NEL), + 1 IDL(NEL),IHOM(NEL),IGCOND(NGCOND),IMPX + REAL VOL(NEL),EVECT(NUN,NGRP),ADECT(NUN,NGRP) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPMAC1,KPMAC1,JPMAC2,KPMAC2 + PARAMETER(NSTATE=40) + CHARACTER HREAC(NREAC)*12,TEXT12*12,SUFF*2,TEXT6*6 + INTEGER IDATA(NSTATE) + LOGICAL LNUSIG,LESTOP,LFIXE,LREAC(NREAC) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, DIMENSION(:), ALLOCATABLE :: IJJ,NJJ,IPOS + REAL, DIMENSION(:), ALLOCATABLE :: VOLI,WORK,SCAT,RATE,GAR,RATEF, + 1 DEN,DEN2 + REAL, DIMENSION(:,:), ALLOCATABLE :: FLINT,AFLINT,CHI,ZUFIS, + 1 ALBPGR,ALBP,OUTR,ESTOP,DEN3 + REAL, DIMENSION(:,:,:), ALLOCATABLE :: OUTSC + DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: ACCUM +*---- +* DATA STATEMENT +*---- + DATA HREAC/'NTOT0','SIGW00','NUSIGF','NFTOT','H-FACTOR', + 1 'OVERV','DIFF','DIFFX','DIFFY','DIFFZ','C-FACTOR'/ +*---- +* SCRATCH STORAGE ALLOCATION +* OUTR(IBM,NREAC+1): volume +* OUTR(IBM,NREAC+2): integrated direct flux +* OUTR(IBM,NREAC+3): adjoint weighting flux +* OUTR(IBM,NREAC+4): fission spectrum +* OUTR(IBM,NREAC+5): fixed sources +*---- + ALLOCATE(VOLI(NZS),WORK(NZS),RATE(NZS),FLINT(NZS,NGRP), + 1 AFLINT(NZS,NGRP),CHI(NBMIX,NBFIS),ZUFIS(NBMIX,NBFIS), + 2 OUTR(NZS+1,NREAC+5),OUTSC(NZS,NL+2,NGCOND),GAR(NGRP), + 3 ALBPGR(NALBP,NGRP),ALBP(NALBP,NGCOND),ESTOP(NZS,NGRP+1)) + ALLOCATE(ACCUM(NZS,NBFIS)) +* + ALBP(:NALBP,:NGCOND)=0.0 + ESTOP(:NZS,:NGRP+1)=0.0 + LNUSIG=.FALSE. + LESTOP=.FALSE. + LFIXE=.FALSE. + LREAC(:NREAC)=.FALSE. +*---- +* RECOVER PHYSICAL ALBEDOS. +*---- + IF(NALBP.GT.0) CALL LCMGET(IPMAC1,'ALBEDO',ALBPGR) +*---- +* DIRECT FLUX CALCULATION. +*---- + VOLI(:NZS)=0.0 + FLINT(:NZS,:NGRP)=0.0 + DO 20 K=1,NEL + IBM=IHOM(K) + IPFL=IDL(K) + IF((IBM.NE.0).AND.(MAT(K).NE.0).AND.(IPFL.NE.0)) THEN + VOLI(IBM)=VOLI(IBM)+VOL(K) + DO 10 IGR=1,NGRP + FLINT(IBM,IGR)=FLINT(IBM,IGR)+EVECT(IPFL,IGR)*VOL(K) + 10 CONTINUE + ENDIF + 20 CONTINUE + CALL LCMPUT(IPMAC2,'VOLUME',NZS,2,VOLI) +*---- +* ADJOINT FLUX CALCULATION. +*---- + AFLINT(:NZS,:NGRP)=0.0 + DO 40 K=1,NEL + IBM=IHOM(K) + IPFL=IDL(K) + IF((IBM.NE.0).AND.(MAT(K).NE.0).AND.(IPFL.NE.0)) THEN + DO 30 IGR=1,NGRP + AFLINT(IBM,IGR)=AFLINT(IBM,IGR)+ADECT(IPFL,IGR)* + 1 EVECT(IPFL,IGR)*VOL(K) + 30 CONTINUE + ENDIF + 40 CONTINUE + DO 60 IGR=1,NGRP + DO 50 IBM=1,NZS + AFLINT(IBM,IGR)=AFLINT(IBM,IGR)/FLINT(IBM,IGR) + 50 CONTINUE + 60 CONTINUE +*---- +* FISSION RATE CALCULATION. +*---- + IF(IMPX.GT.0) WRITE(6,'(/35H OUTPRO: REACTION RATE CALCULATION.)') + JPMAC1=LCMGID(IPMAC1,'GROUP') + JPMAC2=LCMLID(IPMAC2,'GROUP',NGCOND) + IF(NBFIS.GT.0) THEN + ACCUM(:NZS,:NBFIS)=0.0D0 + DO 100 IGR=1,NGRP + KPMAC1=LCMGIL(JPMAC1,IGR) + CALL LCMGET(KPMAC1,'NUSIGF',ZUFIS) + DO 90 IFISS=1,NBFIS + DO 80 K=1,NEL + IBM=IHOM(K) + L=MAT(K) + IPFL=IDL(K) + IF((IBM.NE.0).AND.(L.NE.0).AND.(IPFL.NE.0)) THEN + ACCUM(IBM,IFISS)=ACCUM(IBM,IFISS)+ADECT(IPFL,IGR)* + 1 EVECT(IPFL,IGR)*VOL(K)*ZUFIS(L,IFISS) + ENDIF + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + ENDIF +*---- +* LOOP OVER ENERGY GROUP LIST. +*---- + IGRFIN=0 + DO 500 IGRC=1,NGCOND + IGRDEB=IGRFIN+1 + IGRFIN=IGCOND(IGRC) + OUTR(:NZS+1,:NREAC+5)=0.0 + OUTSC(:NZS,:NL+2,:NGCOND)=0.0 + ALLOCATE(RATEF(NZS),DEN(NZS)) + RATEF(:NZS)=0.0 + DEN(:NZS)=0.0 + DO 310 IGR=IGRDEB,IGRFIN + KPMAC1=LCMGIL(JPMAC1,IGR) + DO 110 IBM=1,NZS + OUTR(IBM,NREAC+2)=OUTR(IBM,NREAC+2)+FLINT(IBM,IGR) + OUTR(IBM,NREAC+3)=OUTR(IBM,NREAC+3)+AFLINT(IBM,IGR) + 110 CONTINUE +*---- +* SET VOLUMES. +*---- + DO 120 IBM=1,NZS + OUTR(IBM,NREAC+1)=VOLI(IBM) + 120 CONTINUE +*---- +* REACTION RATE CALCULATION. +*---- + DO 150 IREAC=1,NREAC + CALL LCMLEN(KPMAC1,HREAC(IREAC),LENGT,ITYLCM) + LREAC(IREAC)=LREAC(IREAC).OR.(LENGT.NE.0) + IF((HREAC(IREAC).EQ.'H-FACTOR').AND.(LENGT.EQ.0)) THEN + WRITE(6,'(/46H OUTPRO: *** WARNING *** NO H-FACTOR FOUND ON , + 1 25HLCM. USE NU*SIGF INSTEAD.)') + LNUSIG=.TRUE. + GO TO 150 + ELSE IF(HREAC(IREAC).EQ.'NUSIGF') THEN + GO TO 150 + ELSE IF(HREAC(IREAC).EQ.'SIGW00') THEN + GO TO 150 + ELSE + TEXT12=HREAC(IREAC) + ENDIF + IF(LENGT.GT.0) THEN + IF(LENGT.GT.NBMIX) CALL XABORT('OUTPRO: INVALID LENGTH FOR '// + 1 HREAC(IREAC)//' CROSS SECTIONS.') + CALL LCMGET(KPMAC1,TEXT12,WORK) + RATE(:NZS)=0.0 + DO 130 K=1,NEL + IBM=IHOM(K) + L=MAT(K) + IPFL=IDL(K) + IF((IBM.NE.0).AND.(L.NE.0).AND.(IPFL.NE.0)) THEN + RATE(IBM)=RATE(IBM)+ADECT(IPFL,IGR)*EVECT(IPFL,IGR)*VOL(K)* + 1 WORK(L) + ENDIF + 130 CONTINUE + DO 140 IBM=1,NZS + OUTR(IBM,IREAC)=OUTR(IBM,IREAC)+RATE(IBM) + 140 CONTINUE + ENDIF + 150 CONTINUE +*---- +* FIXED SOURCES +*---- + CALL LCMLEN(KPMAC1,'FIXE',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + LFIXE=.TRUE. + IF(LENGT.GT.NBMIX) CALL XABORT('OUTPRO: INVALID LENGTH FOR '// + 1 'FIXE SOURCE.') + CALL LCMGET(KPMAC1,'FIXE',WORK) + RATE(:NZS)=0.0 + DO 160 K=1,NEL + IBM=IHOM(K) + L=MAT(K) + IPFL=IDL(K) + IF((IBM.NE.0).AND.(L.NE.0).AND.(IPFL.NE.0)) THEN + RATE(IBM)=RATE(IBM)+ADECT(IPFL,IGR)*VOL(K)*WORK(L) + ENDIF + 160 CONTINUE + DO 170 IBM=1,NZS + OUTR(IBM,NREAC+5)=OUTR(IBM,NREAC+5)+RATE(IBM) + 170 CONTINUE + ENDIF +*---- +* SCATTERING MATRIX INFORMATION IGR <-- JGR. +*---- + ALLOCATE(IJJ(NBMIX),NJJ(NBMIX),IPOS(NBMIX)) + ALLOCATE(SCAT(NBMIX*NGRP)) + DO 220 IL=1,NL + WRITE(SUFF,'(I2.2)') IL-1 + CALL LCMLEN(KPMAC1,'NJJS'//SUFF,LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + IF(LENGT.GT.NBMIX) CALL XABORT('OUTPRO: INVALID LENGTH FOR '// + 1 'SCATTERING CROSS SECTIONS.') + CALL LCMLEN(KPMAC1,'SCAT'//SUFF,LENGT,ITYLCM) + IF(LENGT.GT.NBMIX*NGRP) CALL XABORT('OUTPRO: SCAT OVERFLOW.') + CALL LCMGET(KPMAC1,'NJJS'//SUFF,NJJ) + CALL LCMGET(KPMAC1,'IJJS'//SUFF,IJJ) + CALL LCMGET(KPMAC1,'IPOS'//SUFF,IPOS) + CALL LCMGET(KPMAC1,'SCAT'//SUFF,SCAT) + IPOSDE=0 + DO 210 K=1,NEL + IBM=IHOM(K) + L=MAT(K) + IPFL=IDL(K) + IF((IBM.NE.0).AND.(L.NE.0).AND.(IPFL.NE.0)) THEN + GAR(:NGRP)=0.0 + IPOSDE=IPOS(L)-1 + DO 180 JGR=IJJ(L),IJJ(L)-NJJ(L)+1,-1 + IPOSDE=IPOSDE+1 + GAR(JGR)=SCAT(IPOSDE) + 180 CONTINUE + JGRFIN=0 + DO 200 JGRC=1,NGCOND + JGRDEB=JGRFIN+1 + JGRFIN=IGCOND(JGRC) + DO 190 JGR=JGRDEB,JGRFIN + OUTSC(IBM,IL,JGRC)=OUTSC(IBM,IL,JGRC)+ADECT(IPFL,JGR)* + 1 EVECT(IPFL,JGR)*VOL(K)*GAR(JGR) + 190 CONTINUE + 200 CONTINUE + ENDIF + 210 CONTINUE + IF(IL.EQ.1) OUTR(:NZS,2)=OUTSC(:NZS,IL,IGRC) + ENDIF + 220 CONTINUE + DEALLOCATE(SCAT) + DEALLOCATE(IJJ,NJJ,IPOS) +*---- +* FISSION SPECTRUM AND NUSIGF HOMOGENIZATION. +*---- + IF(NBFIS.GT.0) THEN + CALL LCMLEN(KPMAC1,'NUSIGF',LENGT,ITYLCM) + IF(LENGT.NE.NBMIX*NBFIS) CALL XABORT('OUTPRO: INVALID LENGTH ' + 1 //'FOR FISSION SPECTRUM.') + CALL LCMGET(KPMAC1,'NUSIGF',ZUFIS) + CALL LCMLEN(KPMAC1,'CHI',LENGT,ITYLCM) + IF(LENGT.EQ.0) THEN + IF(IGR.EQ.IGRDEB) OUTR(:NZS,NREAC+4)=1.0 + ELSE + CALL LCMGET(KPMAC1,'CHI',CHI) + DO 240 K=1,NEL + IBM=IHOM(K) + L=MAT(K) + IF((IBM.NE.0).AND.(L.NE.0)) THEN + DO 230 IFISS=1,NBFIS + RATE(IBM)=RATE(IBM)+CHI(L,IFISS)*REAL(ACCUM(IBM,IFISS)) + DEN(IBM)=DEN(IBM)+REAL(ACCUM(IBM,IFISS)) + 230 CONTINUE + ENDIF + 240 CONTINUE + ENDIF + DO 260 IFISS=1,NBFIS + DO 250 K=1,NEL + IBM=IHOM(K) + L=MAT(K) + IPFL=IDL(K) + IF((IBM.NE.0).AND.(L.NE.0).AND.(IPFL.NE.0)) THEN + OUTR(IBM,3)=OUTR(IBM,3)+ADECT(IPFL,IGR)*EVECT(IPFL,IGR)* + 1 VOL(K)*ZUFIS(L,IFISS) + ENDIF + 250 CONTINUE + 260 CONTINUE + ENDIF +*---- +* CONDENSE PHYSICAL ALBEDOS. +*---- + IF(NALBP.GT.0) THEN + DO 280 IAL=1,NALBP + DO 270 IBM=1,NZS + ALBP(IAL,IGRC)=ALBP(IAL,IGRC)+ALBPGR(IAL,IGR)*AFLINT(IBM,IGR)* + 1 FLINT(IBM,IGR) + 270 CONTINUE + 280 CONTINUE + ENDIF +*---- +* RECOVER AND HOMOGENIZE STOPPING POWERS +*---- + CALL LCMLEN(KPMAC1,'ESTOPW',LENGT,ITYLCM) + IF(LENGT.EQ.2*NBMIX) THEN + ALLOCATE(DEN3(NBMIX,2)) + LESTOP=.TRUE. + CALL LCMGET(KPMAC1,'ESTOPW',DEN3) + DO 290 K=1,NEL + IBM=IHOM(K) + L=MAT(K) + IPFL=IDL(K) + IF((IBM.NE.0).AND.(L.NE.0).AND.(IPFL.NE.0)) THEN + IF(IGR.EQ.1) THEN + FACTOR=ADECT(IPFL,IGR)*EVECT(IPFL,IGR)/(AFLINT(IBM,IGR)* + 1 FLINT(IBM,IGR)) + ELSE + FACTOR=(ADECT(IPFL,IGR-1)*EVECT(IPFL,IGR-1)+ + 1 ADECT(IPFL,IGR)*EVECT(IPFL,IGR))/(AFLINT(IBM,IGR-1)* + 2 FLINT(IBM,IGR-1)+AFLINT(IBM,IGR)*FLINT(IBM,IGR)) + ENDIF + ESTOP(IBM,IGR)=ESTOP(IBM,IGR)+FACTOR*VOL(K)*DEN3(L,1) + ENDIF + 290 CONTINUE + IF(IGR.EQ.NGRP) THEN + DO 300 K=1,NEL + IBM=IHOM(K) + L=MAT(K) + IPFL=IDL(K) + IF((IBM.NE.0).AND.(L.NE.0).AND.(IPFL.NE.0)) THEN + FACTOR=ADECT(IPFL,IGR)*EVECT(IPFL,IGR)/(AFLINT(IBM,IGR)* + 1 FLINT(IBM,IGR)) + ESTOP(IBM,IGR+1)=ESTOP(IBM,IGR+1)+FACTOR*VOL(K)*DEN3(L,2) + ENDIF + 300 CONTINUE + ENDIF + DEALLOCATE(DEN3) + ENDIF + 310 CONTINUE +* + DO 340 K=1,NEL + IBM=IHOM(K) + L=MAT(K) + IPFL=IDL(K) + IF((IBM.NE.0).AND.(L.NE.0).AND.(IPFL.NE.0)) THEN + JGRFIN=0 + DO 330 JGRC=1,NGCOND + JGRDEB=JGRFIN+1 + JGRFIN=IGCOND(JGRC) + DO 320 JGR=JGRDEB,JGRFIN + OUTSC(IBM,NL+1,JGRC)=OUTSC(IBM,NL+1,JGRC)+EVECT(IPFL,JGR)*VOL(K) + OUTSC(IBM,NL+2,JGRC)=OUTSC(IBM,NL+2,JGRC)+ADECT(IPFL,JGR)*VOL(K) + 320 CONTINUE + 330 CONTINUE + ENDIF + 340 CONTINUE + IF(NBFIS.GT.0) THEN + DO 350 IBM=1,NZS + IF(DEN(IBM).NE.0.0) OUTR(IBM,NREAC+3)=RATEF(IBM)/DEN(IBM) + 350 CONTINUE + ENDIF + DEALLOCATE(DEN,RATEF) +*---- +* PRINT THE REACTION RATES: +*---- + IF(IMPX.GT.0) THEN + DO 360 I=1,NREAC+3 + OUTR(NZS+1,I)=0.0 + 360 CONTINUE + WRITE(6,520) IGRC,'VOLUME ','FLUX-INTG ', + 1 (HREAC(I),I=1,6),'CHI ' + DO 380 IBM=1,NZS + DO 370 I=1,NREAC+3 + OUTR(NZS+1,I)=OUTR(NZS+1,I)+OUTR(IBM,I) + 370 CONTINUE + WRITE(6,530) IBM,OUTR(IBM,NREAC+1),OUTR(IBM,NREAC+2), + 1 (OUTR(IBM,I),I=1,6),OUTR(IBM,NREAC+4) + 380 CONTINUE + WRITE(6,540) OUTR(NZS+1,NREAC+1),OUTR(NZS+1,NREAC+2), + 1 (OUTR(NZS+1,I),I=1,6) + ENDIF +*---- +* COMPUTE HOMOGENIZED-CONDENSED MACROLIB +*---- + KPMAC2=LCMDIL(JPMAC2,IGRC) + CALL LCMPUT(KPMAC2,'FLUX-INTG',NZS,2,OUTR(1,NREAC+2)) + CALL LCMPUT(KPMAC2,'NWAT0',NZS,2,OUTR(1,NREAC+3)) + DO 400 IREAC=1,NREAC + IF(LREAC(IREAC)) THEN + DO 390 IBM=1,NZS + RATE(IBM)=OUTR(IBM,IREAC) + IF(RATE(IBM).NE.0.0) RATE(IBM)=RATE(IBM)/(OUTR(IBM,NREAC+2)* + 1 OUTR(IBM,NREAC+3)) + 390 CONTINUE + CALL LCMPUT(KPMAC2,HREAC(IREAC),NZS,2,RATE) + IF(LNUSIG.AND.(IREAC.EQ.3)) THEN + CALL LCMPUT(KPMAC2,'H-FACTOR',NZS,2,RATE) + ENDIF + ENDIF + 400 CONTINUE + IF(LREAC(3)) CALL LCMPUT(KPMAC2,'CHI',NZS,2,OUTR(1,NREAC+4)) + IF(LFIXE) THEN + DO 410 IBM=1,NZS + RATE(IBM)=OUTR(IBM,NREAC+5) + IF(RATE(IBM).NE.0.0) RATE(IBM)=RATE(IBM)/OUTR(IBM,NREAC+3) + 410 CONTINUE + CALL LCMPUT(KPMAC2,'FIXE',NZS,2,RATE) + ENDIF +* + ALLOCATE(IJJ(NZS),NJJ(NZS),IPOS(NZS)) + ALLOCATE(SCAT(NZS*NGCOND)) + DO 460 IL=1,NL + WRITE(SUFF,'(I2.2)') IL-1 + DO 430 IBM=1,NZS + IGMIN=IGRC + IGMAX=IGRC + DO 420 JGRC=NGCOND,1,-1 + IF(OUTSC(IBM,IL,JGRC).NE.0.0) THEN + IGMIN=MIN(IGMIN,JGRC) + IGMAX=MAX(IGMAX,JGRC) + OUTSC(IBM,IL,JGRC)=OUTSC(IBM,IL,JGRC)/(OUTSC(IBM,NL+1,JGRC)* + 1 OUTSC(IBM,NL+2,JGRC)) + ENDIF + 420 CONTINUE + IJJ(IBM)=IGMAX + NJJ(IBM)=IGMAX-IGMIN+1 + 430 CONTINUE + IPOSDE=0 + DO 450 IBM=1,NZS + IPOS(IBM)=IPOSDE+1 + DO 440 JGRC=IJJ(IBM),IJJ(IBM)-NJJ(IBM)+1,-1 + IPOSDE=IPOSDE+1 + SCAT(IPOSDE)=OUTSC(IBM,IL,JGRC) + 440 CONTINUE + 450 CONTINUE + CALL LCMPUT(KPMAC2,'SCAT'//SUFF,IPOSDE,2,SCAT) + CALL LCMPUT(KPMAC2,'IPOS'//SUFF,NZS,1,IPOS) + CALL LCMPUT(KPMAC2,'NJJS'//SUFF,NZS,1,NJJ) + CALL LCMPUT(KPMAC2,'IJJS'//SUFF,NZS,1,IJJ) + CALL LCMPUT(KPMAC2,'SIGW'//SUFF,NZS,2,OUTSC(1,IL,IGRC)) + 460 CONTINUE + DEALLOCATE(SCAT) + DEALLOCATE(IJJ,NJJ,IPOS) +* + IF(NALBP.GT.0) THEN + DFI=0.0 + DO 470 IBM=1,NZS + DFI=DFI+OUTR(IBM,NREAC+2)*OUTR(IBM,NREAC+3) + 470 CONTINUE + DO 480 IAL=1,NALBP + ALBP(IAL,IGRC)=ALBP(IAL,IGRC)/DFI + 480 CONTINUE + ENDIF +*---- +* SAVE STOPPING POWERS +*---- + IF(LESTOP) THEN + ALLOCATE(DEN3(NZS,2)) + DO 490 IBM=1,NZS + IF(IGRC.EQ.1) THEN + DEN3(IBM,1)=ESTOP(IBM,1) + ELSE + DEN3(IBM,1)=ESTOP(IBM,IGCOND(IGRC-1)) + ENDIF + DEN3(IBM,2)=ESTOP(IBM,IGCOND(IGRC)+1) + 490 CONTINUE + CALL LCMPUT(KPMAC2,'ESTOPW',NZS*2,2,DEN3) + DEALLOCATE(DEN3) + ENDIF + 500 CONTINUE +*---- +* END OF LOOP OVER MACROGROUPS +*---- +*---- +* RECOVER AND CONDENSE ENERGY MESH +*---- + CALL LCMLEN(IPMAC1,'ENERGY',LENGT,ITYLCM) + IF(LENGT.EQ.NGRP+1) THEN + ALLOCATE(DEN(NGRP+1),DEN2(NGCOND+1)) + CALL LCMGET(IPMAC1,'ENERGY',DEN) + DEN2(1)=DEN(1) + DO 510 IGRC=1,NGCOND + DEN2(IGRC+1)=DEN(IGCOND(IGRC)+1) + 510 CONTINUE + CALL LCMPUT(IPMAC2,'ENERGY',NGCOND+1,2,DEN2) + DEALLOCATE(DEN2,DEN) + ENDIF +*---- +* SAVE ALBEDO AND STATE-VECTOR +*---- + IF(NALBP.GT.0) THEN + CALL LCMPUT(IPMAC2,'ALBEDO',NALBP*NGCOND,2,ALBP) + ENDIF + CALL LCMLEN(IPMAC1,'PARTICLE',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + CALL LCMGTC(IPMAC1,'PARTICLE',12,TEXT6) + CALL LCMPTC(IPMAC2,'PARTICLE',12,TEXT6) + ENDIF + IDATA(:NSTATE)=0 + IDATA(1)=NGCOND + IDATA(2)=NZS + IDATA(3)=NL + IDATA(4)=1 + IDATA(8)=NALBP + IF(LREAC(7)) THEN + IDATA(9)=1 + ELSE IF(LREAC(8)) THEN + IDATA(9)=2 + ENDIF + IDATA(15)=0 + CALL LCMPUT(IPMAC2,'STATE-VECTOR',NSTATE,1,IDATA) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(ACCUM) + DEALLOCATE(ESTOP,ALBP,ALBPGR,GAR,OUTSC,OUTR,ZUFIS,CHI,AFLINT, + 1 FLINT,RATE,WORK,VOLI) + RETURN +* + 520 FORMAT(/' G R O U P : ',I3/1X,'IHOM',9A14) + 530 FORMAT(1X,I4,1P,9E14.5) + 540 FORMAT(/5H SUM,1P,8E14.5) + END diff --git a/Trivac/src/PN3DXX.f b/Trivac/src/PN3DXX.f new file mode 100755 index 0000000..5f51913 --- /dev/null +++ b/Trivac/src/PN3DXX.f @@ -0,0 +1,455 @@ +*DECK PN3DXX + SUBROUTINE PN3DXX(NBMIX,IELEM,ICOL,NEL,NLF,NVD,NAN,LL4F,LL4X, + 1 SIGT,SIGTI,MAT,VOL,XX,YY,ZZ,KN,QFR,MUX,IPBBX,LC,R,V,BBX,TTF, + 2 AX,C11X) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Assembly of system matrices for a Thomas-Raviart (dual) finite element +* method in 3-D simplified PN approximation. Note: system matrices +* should be initialized by the calling program. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NBMIX number of mixtures. +* IELEM degree of the Lagrangian finite elements: =1 (linear); +* =2 (parabolic); =3 (cubic). +* ICOL type of quadrature: =1 (analytical integration); +* =2 (Gauss-Lobatto); =3 (Gauss-Legendre). +* NEL total number of finite elements. +* NLF number of Legendre orders for the flux (even number). +* NVD type of void boundary condition if NLF>0 and ICOL=3. +* NAN number of Legendre orders for the cross sections. +* LL4F number of flux components. +* LL4X number of X-directed currents. +* LL4Y number of Y-directed currents. +* LL4Z number of Z-directed currents. +* SIGT total minus self-scattering macroscopic cross sections. +* SIGT(:,NAN) generally contains the total cross section only. +* SIGTI inverse macroscopic cross sections ordered by mixture. +* SIGTI(:,NAN) generally contains the inverse total cross +* section only. +* MAT mixture index assigned to each element. +* VOL volume of each element. +* XX X-directed mesh spacings. +* YY Y-directed mesh spacings. +* ZZ Z-directed mesh spacings. +* KN element-ordered unknown list. +* QFR element-ordered boundary conditions. +* MUX X-directed compressed storage mode indices. +* MUY Y-directed compressed storage mode indices. +* MUZ Z-directed compressed storage mode indices. +* IPBBX X-directed perdue storage indices. +* IPBBY Y-directed perdue storage indices. +* IPBBZ Z-directed perdue storage indices. +* LC order of the unit matrices. +* R unit matrix. +* V unit matrix. +* BBX X-directed flux-current matrices. +* BBY Y-directed flux-current matrices. +* BBZ Z-directed flux-current matrices. +* +*Parameters: output +* TTF flux-flux matrices. +* AX X-directed main current-current matrices. Dimensionned to +* MUX(LL4X)*NLF/2. +* AY Y-directed main current-current matrices. Dimensionned to +* MUY(LL4Y)*NLF/2. +* AZ Z-directed main current-current matrices. Dimensionned to +* MUZ(LL4Z)*NLF/2. +* C11X X-directed main current-current matrices to be factorized. +* Dimensionned to MUX(LL4X)*NLF/2. +* C11Y Y-directed main current-current matrices to be factorized. +* Dimensionned to MUY(LL4Y)*NLF/2. +* C11Z Z-directed main current-current matrices to be factorized. +* Dimensionned to MUZ(LL4Z)*NLF/2. +* +*Reference(s): +* J.J. Lautard, D. Schneider, A.M. Baudron, "Mixed Dual Methods for +* Neutronic Reactor Core Calculations in the CRONOS System," Proc. +* Int. Conf. on Mathematics and Computation, Reactor Physics and +* Environmental Analysis in Nuclear Applications, Madrid, Spain, +* September 27-30, 1999. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NBMIX,IELEM,ICOL,NEL,NLF,NVD,NAN,LL4F,LL4X,MAT(NEL), + 1 KN(NEL*(1+6*IELEM**2)),MUX(LL4X),IPBBX(2*IELEM,LL4X),LC + REAL SIGT(NBMIX,NAN),SIGTI(NBMIX,NAN),VOL(NEL),XX(NEL),YY(NEL), + 1 ZZ(NEL),QFR(6*NEL),R(LC,LC),V(LC,LC-1),BBX(2*IELEM,LL4X), + 2 TTF(LL4F*NLF/2),AX(*),C11X(*) +*---- +* LOCAL VARIABLES +*---- + REAL QQ(5,5) +*---- +* X-ORIENTED COUPLINGS +*---- + ZMARS=0.0 + IF(ICOL.EQ.3) THEN + IF(NVD.EQ.0) THEN + NZMAR=NLF+1 + ELSE IF(NVD.EQ.1) THEN + NZMAR=NLF + ELSE IF(NVD.EQ.2) THEN + NZMAR=65 + ENDIF + ELSE + NZMAR=65 + ENDIF + DO 25 I0=1,IELEM + DO 20 J0=1,IELEM + FFF=0.0 + DO 10 K0=2,IELEM + FFF=FFF+V(K0,I0)*V(K0,J0)/R(K0,K0) + 10 CONTINUE + IF(ABS(FFF).LE.1.0E-6) FFF=0.0 + QQ(I0,J0)=FFF + 20 CONTINUE + 25 CONTINUE + MUMAX=MUX(LL4X) + DO 170 IL=0,NLF-1 + IF(MOD(IL,2).EQ.1) ZMARS=PNMAR2(NZMAR,IL,IL) + FACT=REAL(2*IL+1) +*---- +* ASSEMBLY OF THE X-ORIENTED COEFFICIENT MATRICES AT ORDER IL. +*---- + NUM1=0 + NUM2=0 + DO 120 IE=1,NEL + IBM=MAT(IE) + IF(IBM.EQ.0) GO TO 120 + VOL0=VOL(IE) + IF(VOL0.EQ.0.0) GO TO 110 + DX=XX(IE) + DY=YY(IE) + DZ=ZZ(IE) + GARS=SIGT(IBM,MIN(IL+1,NAN)) + IF(MOD(IL,2).EQ.0) THEN +* EVEN PARITY EQUATION. + DO 32 K3=0,IELEM-1 + DO 31 K2=0,IELEM-1 + DO 30 K1=0,IELEM-1 + KEY=(IL/2)*LL4F+KN(NUM1+1)+(K3*IELEM+K2)*IELEM+K1 + TTF(KEY)=TTF(KEY)+FACT*VOL0*GARS + 30 CONTINUE + 31 CONTINUE + 32 CONTINUE + ELSE + GARSI=SIGTI(IBM,MIN(IL+1,NAN)) + DO 105 K3=0,IELEM-1 + DO 100 K2=0,IELEM-1 +* PARTIAL INVERSION OF THE ODD PARITY EQUATION. MODIFICATION OF +* THE EVEN PARITY EQUATION. + DO 40 K1=0,IELEM-1 + JND1=KN(NUM1+1)+(K3*IELEM+K2)*IELEM+K1 + KEY=((IL-1)/2)*LL4F+JND1 + TTF(KEY)=TTF(KEY)+(REAL(IL)**2)*VOL0*QQ(K1+1,K1+1)*GARSI/(FACT* + 1 DX*DX) + IF(IL.LE.NLF-3) THEN + KEY=((IL+2)/2)*LL4F+JND1 + TTF(KEY)=TTF(KEY)+(REAL(IL+1)**2)*VOL0*QQ(K1+1,K1+1)*GARSI/ + 1 (FACT*DX*DX) + ENDIF + KEY=((IL-1)/2)*LL4F+JND1 + TTF(KEY)=TTF(KEY)+(REAL(IL)**2)*VOL0*QQ(K2+1,K2+1)*GARSI/ + 1 (FACT*DY*DY) + IF(IL.LE.NLF-3) THEN + KEY=((IL+2)/2)*LL4F+JND1 + TTF(KEY)=TTF(KEY)+(REAL(IL+1)**2)*VOL0*QQ(K2+1,K2+1)*GARSI/ + 1 (FACT*DY*DY) + ENDIF + KEY=((IL-1)/2)*LL4F+JND1 + TTF(KEY)=TTF(KEY)+(REAL(IL)**2)*VOL0*QQ(K3+1,K3+1)*GARSI/ + 1 (FACT*DZ*DZ) + IF(IL.LE.NLF-3) THEN + KEY=((IL+2)/2)*LL4F+JND1 + TTF(KEY)=TTF(KEY)+(REAL(IL+1)**2)*VOL0*QQ(K3+1,K3+1)*GARSI/ + 1 (FACT*DZ*DZ) + ENDIF + 40 CONTINUE +* +* ODD PARITY EQUATION. + DO 55 IC=1,2 + IF(IC.EQ.1) IIC=1 + IF(IC.EQ.2) IIC=IELEM+1 + KN1=KN(NUM1+2+(IC-1)*IELEM**2+K3*IELEM+K2) + IND1=ABS(KN1)-LL4F + S1=REAL(SIGN(1,KN1)) + DO 50 JC=1,2 + IF(JC.EQ.1) JJC=1 + IF(JC.EQ.2) JJC=IELEM+1 + KN2=KN(NUM1+2+(JC-1)*IELEM**2+K3*IELEM+K2) + IND2=ABS(KN2)-LL4F + IF((KN1.NE.0).AND.(KN2.NE.0).AND.(IND1.GE.IND2)) THEN + S2=REAL(SIGN(1,KN2)) + KEY=((IL-1)/2)*MUMAX+MUX(IND1)-IND1+IND2 + AX(KEY)=AX(KEY)-S1*S2*FACT*R(IIC,JJC)*VOL0*GARS + ENDIF + 50 CONTINUE + 55 CONTINUE +* + KN1=KN(NUM1+2+K3*IELEM+K2) + KN2=KN(NUM1+2+IELEM**2+K3*IELEM+K2) + IND1=ABS(KN1)-LL4F + IND2=ABS(KN2)-LL4F + IF((QFR(NUM2+1).NE.0.0).AND.(KN1.NE.0)) THEN + KEY=((IL-1)/2)*MUMAX+MUX(IND1) + AX(KEY)=AX(KEY)-0.5*FACT*QFR(NUM2+1)*ZMARS + ENDIF + IF((QFR(NUM2+2).NE.0.0).AND.(KN2.NE.0)) THEN + KEY=((IL-1)/2)*MUMAX+MUX(IND2) + AX(KEY)=AX(KEY)-0.5*FACT*QFR(NUM2+2)*ZMARS + ENDIF + 100 CONTINUE + 105 CONTINUE + ENDIF + 110 NUM1=NUM1+1+6*IELEM**2 + NUM2=NUM2+6 + 120 CONTINUE +* + IF(MOD(IL,2).EQ.1) THEN + DO 130 I0=1,MUMAX + C11X(((IL-1)/2)*MUMAX+I0)=-AX(((IL-1)/2)*MUMAX+I0) + 130 CONTINUE + MUIM1=0 + DO 160 I=1,LL4X + MUI=MUX(I) + DO 150 J=I-(MUI-MUIM1)+1,I + KEY=((IL-1)/2)*MUMAX+(MUI-I+J) + DO 145 I0=1,2*IELEM + II=IPBBX(I0,I) + IF(II.EQ.0) GO TO 150 + DO 140 J0=1,2*IELEM + JJ=IPBBX(J0,J) + IF(II.EQ.JJ) C11X(KEY)=C11X(KEY)+REAL(IL**2)*BBX(I0,I)* + 1 BBX(J0,J)/TTF(((IL-1)/2)*LL4F+II) + 140 CONTINUE + 145 CONTINUE + 150 CONTINUE + MUIM1=MUI + 160 CONTINUE + ENDIF + 170 CONTINUE + RETURN + END +* + SUBROUTINE PN3DXY(NBMIX,IELEM,ICOL,NEL,NLF,NVD,NAN,LL4F,LL4X,LL4Y, + 1 SIGT,MAT,VOL,YY,KN,QFR,MUY,IPBBY,LC,R,BBY,TTF,AY,C11Y) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NBMIX,IELEM,ICOL,NEL,NLF,NVD,NAN,LL4F,LL4X,LL4Y,MAT(NEL), + 1 KN(NEL*(1+6*IELEM**2)),MUY(LL4Y),IPBBY(2*IELEM,LL4Y),LC + REAL SIGT(NBMIX,NAN),VOL(NEL),YY(NEL),QFR(6*NEL),R(LC,LC), + 1 BBY(2*IELEM,LL4Y),TTF(LL4F*NLF/2),AY(*),C11Y(*) +*---- +* Y-ORIENTED COUPLINGS +*---- + ZMARS=0.0 + IF(ICOL.EQ.3) THEN + IF(NVD.EQ.0) THEN + NZMAR=NLF+1 + ELSE IF(NVD.EQ.1) THEN + NZMAR=NLF + ELSE IF(NVD.EQ.2) THEN + NZMAR=65 + ENDIF + ELSE + NZMAR=65 + ENDIF + MUMAX=MUY(LL4Y) + DO 320 IL=1,NLF-1,2 + ZMARS=PNMAR2(NZMAR,IL,IL) + FACT=REAL(2*IL+1) +*---- +* ASSEMBLY OF THE Y-ORIENTED COEFFICIENT MATRICES AT ODD ORDER IL. +*---- + NUM1=0 + NUM2=0 + DO 270 IE=1,NEL + IBM=MAT(IE) + IF(IBM.EQ.0) GO TO 270 + VOL0=VOL(IE) + IF(VOL0.EQ.0.0) GO TO 260 + DY=YY(IE) + GARS=SIGT(IBM,MIN(IL+1,NAN)) +* + DO 255 K3=0,IELEM-1 + DO 250 K1=0,IELEM-1 + DO 205 IC=3,4 + IF(IC.EQ.3) IIC=1 + IF(IC.EQ.4) IIC=IELEM+1 + KN1=KN(NUM1+2+(IC-1)*IELEM**2+K3*IELEM+K1) + IND1=ABS(KN1)-LL4F-LL4X + S1=REAL(SIGN(1,KN1)) + DO 200 JC=3,4 + IF(JC.EQ.3) JJC=1 + IF(JC.EQ.4) JJC=IELEM+1 + KN2=KN(NUM1+2+(JC-1)*IELEM**2+K3*IELEM+K1) + IND2=ABS(KN2)-LL4F-LL4X + IF((KN1.NE.0).AND.(KN2.NE.0).AND.(IND1.GE.IND2)) THEN + S2=REAL(SIGN(1,KN2)) + KEY=((IL-1)/2)*MUMAX+MUY(IND1)-IND1+IND2 + AY(KEY)=AY(KEY)-S1*S2*FACT*R(IIC,JJC)*VOL0*GARS + ENDIF + 200 CONTINUE + 205 CONTINUE +* + KN1=KN(NUM1+2+2*IELEM**2+K3*IELEM+K1) + KN2=KN(NUM1+2+3*IELEM**2+K3*IELEM+K1) + IND1=ABS(KN1)-LL4F-LL4X + IND2=ABS(KN2)-LL4F-LL4X + IF((QFR(NUM2+3).NE.0.0).AND.(KN1.NE.0)) THEN + KEY=((IL-1)/2)*MUMAX+MUY(IND1) + AY(KEY)=AY(KEY)-0.5*FACT*QFR(NUM2+3)*ZMARS + ENDIF + IF((QFR(NUM2+4).NE.0.0).AND.(KN2.NE.0)) THEN + KEY=((IL-1)/2)*MUMAX+MUY(IND2) + AY(KEY)=AY(KEY)-0.5*FACT*QFR(NUM2+4)*ZMARS + ENDIF + 250 CONTINUE + 255 CONTINUE + 260 NUM1=NUM1+1+6*IELEM**2 + NUM2=NUM2+6 + 270 CONTINUE +* + DO 280 I0=1,MUMAX + C11Y(((IL-1)/2)*MUMAX+I0)=-AY(((IL-1)/2)*MUMAX+I0) + 280 CONTINUE + MUIM1=0 + DO 310 I=1,LL4Y + MUI=MUY(I) + DO 300 J=I-(MUI-MUIM1)+1,I + KEY=((IL-1)/2)*MUMAX+(MUI-I+J) + DO 295 I0=1,2*IELEM + II=IPBBY(I0,I) + IF(II.EQ.0) GO TO 300 + DO 290 J0=1,2*IELEM + JJ=IPBBY(J0,J) + IF(II.EQ.JJ) C11Y(KEY)=C11Y(KEY)+REAL(IL**2)*BBY(I0,I)*BBY(J0,J)/ + 1 TTF(((IL-1)/2)*LL4F+II) + 290 CONTINUE + 295 CONTINUE + 300 CONTINUE + MUIM1=MUI + 310 CONTINUE + 320 CONTINUE + RETURN + END +* + SUBROUTINE PN3DXZ(NBMIX,IELEM,ICOL,NEL,NLF,NVD,NAN,LL4F,LL4X,LL4Y, + 1 LL4Z,SIGT,MAT,VOL,ZZ,KN,QFR,MUZ,IPBBZ,LC,R,BBZ,TTF,AZ,C11Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NBMIX,IELEM,ICOL,NEL,NLF,NVD,NAN,LL4F,LL4X,LL4Y,LL4Z, + 1 MAT(NEL),KN(NEL*(1+6*IELEM**2)),MUZ(LL4Z),IPBBZ(2*IELEM,LL4Z),LC + REAL SIGT(NBMIX,NAN),VOL(NEL),ZZ(NEL),QFR(6*NEL),R(LC,LC), + 1 BBZ(2*IELEM,LL4Z),TTF(LL4F*NLF/2),AZ(*),C11Z(*) +*---- +* Z-ORIENTED COUPLINGS +*---- + ZMARS=0.0 + IF(ICOL.EQ.3) THEN + IF(NVD.EQ.0) THEN + NZMAR=NLF+1 + ELSE IF(NVD.EQ.1) THEN + NZMAR=NLF + ELSE IF(NVD.EQ.2) THEN + NZMAR=65 + ENDIF + ELSE + NZMAR=65 + ENDIF + MUMAX=MUZ(LL4Z) + DO 470 IL=1,NLF-1,2 + ZMARS=PNMAR2(NZMAR,IL,IL) + FACT=REAL(2*IL+1) +*---- +* ASSEMBLY OF THE Z-ORIENTED COEFFICIENT MATRICES AT ORDER IL. +*---- + NUM1=0 + NUM2=0 + DO 420 IE=1,NEL + IBM=MAT(IE) + IF(IBM.EQ.0) GO TO 420 + VOL0=VOL(IE) + IF(VOL0.EQ.0.0) GO TO 410 + DZ=ZZ(IE) + GARS=SIGT(IBM,MIN(IL+1,NAN)) +* + DO 405 K2=0,IELEM-1 + DO 400 K1=0,IELEM-1 + DO 355 IC=5,6 + IF(IC.EQ.5) IIC=1 + IF(IC.EQ.6) IIC=IELEM+1 + KN1=KN(NUM1+2+(IC-1)*IELEM**2+K2*IELEM+K1) + IND1=ABS(KN1)-LL4F-LL4X-LL4Y + S1=REAL(SIGN(1,KN1)) + DO 350 JC=5,6 + IF(JC.EQ.5) JJC=1 + IF(JC.EQ.6) JJC=IELEM+1 + KN2=KN(NUM1+2+(JC-1)*IELEM**2+K2*IELEM+K1) + IND2=ABS(KN2)-LL4F-LL4X-LL4Y + IF((KN1.NE.0).AND.(KN2.NE.0).AND.(IND1.GE.IND2)) THEN + S2=REAL(SIGN(1,KN2)) + KEY=((IL-1)/2)*MUMAX+MUZ(IND1)-IND1+IND2 + AZ(KEY)=AZ(KEY)-S1*S2*FACT*R(IIC,JJC)*VOL0*GARS + ENDIF + 350 CONTINUE + 355 CONTINUE +* + KN1=KN(NUM1+2+4*IELEM**2+K2*IELEM+K1) + KN2=KN(NUM1+2+5*IELEM**2+K2*IELEM+K1) + IND1=ABS(KN1)-LL4F-LL4X-LL4Y + IND2=ABS(KN2)-LL4F-LL4X-LL4Y + IF((QFR(NUM2+5).NE.0.0).AND.(KN1.NE.0)) THEN + KEY=((IL-1)/2)*MUMAX+MUZ(IND1) + AZ(KEY)=AZ(KEY)-0.5*FACT*QFR(NUM2+5)*ZMARS + ENDIF + IF((QFR(NUM2+6).NE.0.0).AND.(KN2.NE.0)) THEN + KEY=((IL-1)/2)*MUMAX+MUZ(IND2) + AZ(KEY)=AZ(KEY)-0.5*FACT*QFR(NUM2+6)*ZMARS + ENDIF + 400 CONTINUE + 405 CONTINUE + 410 NUM1=NUM1+1+6*IELEM**2 + NUM2=NUM2+6 + 420 CONTINUE +* + DO 430 I0=1,MUMAX + C11Z(((IL-1)/2)*MUMAX+I0)=-AZ(((IL-1)/2)*MUMAX+I0) + 430 CONTINUE + MUIM1=0 + DO 460 I=1,LL4Z + MUI=MUZ(I) + DO 450 J=I-(MUI-MUIM1)+1,I + KEY=((IL-1)/2)*MUMAX+(MUI-I+J) + DO 445 I0=1,2*IELEM + II=IPBBZ(I0,I) + IF(II.EQ.0) GO TO 450 + DO 440 J0=1,2*IELEM + JJ=IPBBZ(J0,J) + IF(II.EQ.JJ) C11Z(KEY)=C11Z(KEY)+REAL(IL**2)*BBZ(I0,I)*BBZ(J0,J)/ + 1 TTF(((IL-1)/2)*LL4F+II) + 440 CONTINUE + 445 CONTINUE + 450 CONTINUE + MUIM1=MUI + 460 CONTINUE + 470 CONTINUE + RETURN + END diff --git a/Trivac/src/PN3HWW.f b/Trivac/src/PN3HWW.f new file mode 100755 index 0000000..bc49e10 --- /dev/null +++ b/Trivac/src/PN3HWW.f @@ -0,0 +1,560 @@ +*DECK PN3HWW + SUBROUTINE PN3HWW(NBMIX,NBLOS,IELEM,ICOL,NLF,NVD,NAN,LL4F,LL4W, + 1 MAT,SIGT,SIGTI,SIDE,ZZ,FRZ,QFR,IPERT,KN,MUW,IPBBW,LC,R,V,BBW, + 2 TTF,AW,C11W) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Assembly of system matrices for a Thomas-Raviart-Schneider (dual) +* finite element method in hexagonal 3-D simplified PN approximation. +* Note: system matrices should be initialized by the calling program. +* +*Copyright: +* Copyright (C) 2009 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NBMIX number of mixtures. +* NBLOS number of lozenges per direction, taking into account +* mesh-splitting. +* IELEM degree of the Lagrangian finite elements: =1 (linear); +* =2 (parabolic); =3 (cubic). +* ICOL type of quadrature: =1 (analytical integration); +* =2 (Gauss-Lobatto); =3 (Gauss-Legendre). +* NLF number of Legendre orders for the flux (even number). +* NVD type of void boundary condition if NLF>0 and ICOL=3. +* NAN number of Legendre orders for the cross sections. +* LL4F number of flux components. +* LL4W number of W-directed currents. +* LL4X number of X-directed currents. +* LL4Y number of Y-directed currents. +* LL4Z number of Z-directed currents. +* MAT mixture index assigned to each lozenge. +* SIGT total minus self-scattering macroscopic cross sections. +* SIGT(:,NAN) generally contains the total cross section only. +* SIGTI inverse macroscopic cross sections ordered by mixture. +* SIGTI(:,NAN) generally contains the inverse total cross +* section only. +* SIDE side of an hexagon. +* ZZ Z-directed mesh spacings. +* FRZ volume fractions for the axial SYME boundary condition. +* QFR element-ordered boundary conditions. +* IPERT mixture permutation index. +* KN ADI permutation indices for the volumes and currents. +* MUW W-directed compressed storage mode indices. +* MUX X-directed compressed storage mode indices. +* MUY Y-directed compressed storage mode indices. +* MUZ Z-directed compressed storage mode indices. +* IPBBW W-directed perdue storage indices. +* IPBBX X-directed perdue storage indices. +* IPBBY Y-directed perdue storage indices. +* IPBBZ Z-directed perdue storage indices. +* LC order of the unit matrices. +* R unit matrix. +* V unit matrix. +* BBW W-directed flux-current matrices. +* BBX X-directed flux-current matrices. +* BBY Y-directed flux-current matrices. +* BBZ Z-directed flux-current matrices. +* +*Parameters: output +* TTF flux-flux matrices. +* AW W-directed main current-current matrices. Dimensionned to +* MUW(LL4W)*NLF/2. +* AX X-directed main current-current matrices. Dimensionned to +* MUX(LL4X)*NLF/2. +* AY Y-directed main current-current matrices. Dimensionned to +* MUY(LL4Y)*NLF/2. +* AZ Z-directed main current-current matrices. Dimensionned to +* MUZ(LL4Z)*NLF/2. +* C11W W-directed main current-current matrices to be factorized. +* Dimensionned to MUW(LL4W)*NLF/2. +* C11X X-directed main current-current matrices to be factorized. +* Dimensionned to MUX(LL4X)*NLF/2. +* C11Y Y-directed main current-current matrices to be factorized. +* Dimensionned to MUY(LL4Y)*NLF/2. +* C11Z Z-directed main current-current matrices to be factorized. +* Dimensionned to MUZ(LL4Z)*NLF/2. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NBMIX,NBLOS,IELEM,ICOL,NLF,NVD,NAN,LL4F,LL4W, + 1 MAT(3,NBLOS),MUW(LL4W),IPBBW(2*IELEM,LL4W),LC,IPERT(NBLOS), + 2 KN(NBLOS,3+6*(IELEM+2)*IELEM**2) + REAL SIGT(NBMIX,NAN),SIGTI(NBMIX,NAN),SIDE,ZZ(3,NBLOS),FRZ(NBLOS), + 1 QFR(NBLOS,8),R(LC,LC),V(LC,LC-1),BBW(2*IELEM,LL4W), + 2 TTF(LL4F*NLF/2),AW(*),C11W(*) +*---- +* LOCAL VARIABLES +*---- + REAL QQ(5,5) + DOUBLE PRECISION FFF,TTTT,VOL0,GARS,GARSI,FACT,VAR1 +*---- +* W-ORIENTED COUPLINGS +*---- + ZMARS=0.0 + IF(ICOL.EQ.3) THEN + IF(NVD.EQ.0) THEN + NZMAR=NLF+1 + ELSE IF(NVD.EQ.1) THEN + NZMAR=NLF + ELSE IF(NVD.EQ.2) THEN + NZMAR=65 + ENDIF + ELSE + NZMAR=65 + ENDIF + DO 25 I0=1,IELEM + DO 20 J0=1,IELEM + FFF=0.0D0 + DO 10 K0=2,IELEM + FFF=FFF+V(K0,I0)*V(K0,J0)/R(K0,K0) + 10 CONTINUE + IF(ABS(FFF).LE.1.0E-6) FFF=0.0D0 + QQ(I0,J0)=REAL(FFF) + 20 CONTINUE + 25 CONTINUE + MUMAX=MUW(LL4W) + DO 120 IL=0,NLF-1 + IF(MOD(IL,2).EQ.1) ZMARS=PNMAR2(NZMAR,IL,IL) + FACT=REAL(2*IL+1) +*---- +* ASSEMBLY OF THE W-ORIENTED COEFFICIENT MATRICES AT ORDER IL. +*---- + NELEH=(IELEM+1)*IELEM**2 + TTTT=0.5D0*SQRT(3.D00)*SIDE*SIDE + NUM=0 + DO 70 KEL=1,NBLOS + IF(IPERT(KEL).EQ.0) GO TO 70 + IBM=MAT(1,IPERT(KEL)) + NUM=NUM+1 + IF(IBM.EQ.0) GO TO 70 + DZ=ZZ(1,IPERT(KEL)) + VOL0=TTTT*DZ*FRZ(KEL) + GARS=SIGT(IBM,MIN(IL+1,NAN)) + IF(MOD(IL,2).EQ.0) THEN +* EVEN PARITY EQUATION. + VAR1=FACT*VOL0*GARS + DO 32 K3=0,IELEM-1 + DO 31 K2=0,IELEM-1 + DO 30 K1=0,IELEM-1 + IOF=(IL/2)*LL4F + JND1=IOF+(((NUM-1)*IELEM+K3)*IELEM+K2)*IELEM+K1+1 + JND2=IOF+(((KN(NUM,1)-1)*IELEM+K3)*IELEM+K2)*IELEM+K1+1 + JND3=IOF+(((KN(NUM,2)-1)*IELEM+K3)*IELEM+K2)*IELEM+K1+1 + TTF(JND1)=TTF(JND1)+REAL(VAR1) + TTF(JND2)=TTF(JND2)+REAL(VAR1) + TTF(JND3)=TTF(JND3)+REAL(VAR1) + 30 CONTINUE + 31 CONTINUE + 32 CONTINUE + ELSE +* PARTIAL INVERSION OF THE ODD PARITY EQUATION. MODIFICATION OF +* THE EVEN PARITY EQUATION. + GARSI=SIGTI(IBM,MIN(IL+1,NAN)) + IF(IELEM.GT.1) THEN + KOFF=((IL-1)/2)*LL4F + DO 42 K3=0,IELEM-1 + DO 41 K2=0,IELEM-1 + DO 40 K1=0,IELEM-1 + JND1=KOFF+(((NUM-1)*IELEM+K3)*IELEM+K2)*IELEM+K1+1 + JND2=KOFF+(((KN(NUM,1)-1)*IELEM+K3)*IELEM+K2)*IELEM+K1+1 + JND3=KOFF+(((KN(NUM,2)-1)*IELEM+K3)*IELEM+K2)*IELEM+K1+1 + VAR1=(REAL(IL)**2)*VOL0*QQ(K3+1,K3+1)*GARSI/(FACT*DZ*DZ) + TTF(JND1)=TTF(JND1)+REAL(VAR1) + TTF(JND2)=TTF(JND2)+REAL(VAR1) + TTF(JND3)=TTF(JND3)+REAL(VAR1) + IF(IL.LE.NLF-3) THEN + JND1=JND1+LL4F + JND2=JND2+LL4F + JND3=JND3+LL4F + VAR1=(REAL(IL+1)**2)*VOL0*QQ(K3+1,K3+1)*GARSI/(FACT*DZ*DZ) + TTF(JND1)=TTF(JND1)+REAL(VAR1) + TTF(JND2)=TTF(JND2)+REAL(VAR1) + TTF(JND3)=TTF(JND3)+REAL(VAR1) + ENDIF + 40 CONTINUE + 41 CONTINUE + 42 CONTINUE + ENDIF +* +* ODD PARITY EQUATION. + DO 63 K5=0,1 ! TWO LOZENGES PER HEXAGON + DO 62 K4=0,IELEM-1 + DO 61 K3=0,IELEM-1 + DO 60 K2=1,IELEM+1 + KNW1=KN(NUM,3+K5*NELEH+(K4*IELEM+K3)*(IELEM+1)+K2) + INW1=ABS(KNW1) + DO 50 K1=1,IELEM+1 + KNW2=KN(NUM,3+K5*NELEH+(K4*IELEM+K3)*(IELEM+1)+K1) + INW2=ABS(KNW2) + IF((KNW2.NE.0).AND.(KNW1.NE.0).AND.(INW1.GE.INW2)) THEN + KEY=((IL-1)/2)*MUMAX+MUW(INW1)-INW1+INW2 + SG=REAL(SIGN(1,KNW1)*SIGN(1,KNW2)) + VAR1=(4./3.)*SG*FACT*VOL0*GARS*R(K2,K1) + AW(KEY)=AW(KEY)-REAL(VAR1) + ENDIF + 50 CONTINUE + IF(KNW1.NE.0) THEN + KEY=((IL-1)/2)*MUMAX+MUW(INW1) + IF((K2.EQ.1).AND.(K5.EQ.0)) THEN + VAR1=0.5*FACT*QFR(NUM,1)*ZMARS + AW(KEY)=AW(KEY)-REAL(VAR1) + ELSE IF((K2.EQ.IELEM+1).AND.(K5.EQ.1)) THEN + VAR1=0.5*FACT*QFR(NUM,2)*ZMARS + AW(KEY)=AW(KEY)-REAL(VAR1) + ENDIF + ENDIF + 60 CONTINUE + 61 CONTINUE + 62 CONTINUE + 63 CONTINUE + ENDIF + 70 CONTINUE +* + IF(MOD(IL,2).EQ.1) THEN + DO 80 I0=1,MUMAX + C11W(((IL-1)/2)*MUMAX+I0)=-AW(((IL-1)/2)*MUMAX+I0) + 80 CONTINUE + MUIM1=0 + DO 110 I=1,LL4W + MUI=MUW(I) + DO 100 J=I-(MUI-MUIM1)+1,I + KEY=((IL-1)/2)*MUMAX+(MUI-I+J) + DO 95 I0=1,2*IELEM + II=IPBBW(I0,I) + IF(II.EQ.0) GO TO 100 + DO 90 J0=1,2*IELEM + JJ=IPBBW(J0,J) + IF(II.EQ.JJ) C11W(KEY)=C11W(KEY)+REAL(IL**2)*BBW(I0,I)* + 1 BBW(J0,J)/TTF(((IL-1)/2)*LL4F+II) + 90 CONTINUE + 95 CONTINUE + 100 CONTINUE + MUIM1=MUI + 110 CONTINUE + ENDIF + 120 CONTINUE + RETURN + END +* + SUBROUTINE PN3HWX(NBMIX,NBLOS,IELEM,ICOL,NLF,NVD,NAN,LL4F,LL4W, + 1 LL4X,MAT,SIGT,SIDE,ZZ,FRZ,QFR,IPERT,KN,MUX,IPBBX,LC,R,BBX,TTF, + 2 AX,C11X) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NBMIX,NBLOS,IELEM,ICOL,NLF,NVD,NAN,LL4F,LL4W,LL4X, + 1 MAT(3,NBLOS),MUX(LL4X),IPBBX(2*IELEM,LL4X),LC,IPERT(NBLOS), + 2 KN(NBLOS,3+6*(IELEM+2)*IELEM**2) + REAL SIGT(NBMIX,NAN),SIDE,ZZ(3,NBLOS),FRZ(NBLOS),QFR(NBLOS,8), + 1 R(LC,LC),BBX(2*IELEM,LL4X),TTF(LL4F*NLF/2),AX(*),C11X(*) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION TTTT,VOL0,GARS,FACT,VAR1 +*---- +* X-ORIENTED COUPLINGS +*---- + ZMARS=0.0 + IF(ICOL.EQ.3) THEN + IF(NVD.EQ.0) THEN + NZMAR=NLF+1 + ELSE IF(NVD.EQ.1) THEN + NZMAR=NLF + ELSE IF(NVD.EQ.2) THEN + NZMAR=65 + ENDIF + ELSE + NZMAR=65 + ENDIF + MUMAX=MUX(LL4X) + DO 200 IL=1,NLF-1,2 + ZMARS=PNMAR2(NZMAR,IL,IL) + FACT=REAL(2*IL+1) +*---- +* ASSEMBLY OF THE X-ORIENTED COEFFICIENT MATRICES AT ODD ORDER IL. +*---- + NELEH=(IELEM+1)*IELEM**2 + TTTT=0.5D0*SQRT(3.D00)*SIDE*SIDE + NUM=0 + DO 150 KEL=1,NBLOS + IF(IPERT(KEL).EQ.0) GO TO 150 + IBM=MAT(1,IPERT(KEL)) + NUM=NUM+1 + IF(IBM.EQ.0) GO TO 150 + VOL0=TTTT*ZZ(1,IPERT(KEL))*FRZ(KEL) + GARS=SIGT(IBM,MIN(IL+1,NAN)) +* + DO 143 K5=0,1 ! TWO LOZENGES PER HEXAGON + DO 142 K4=0,IELEM-1 + DO 141 K3=0,IELEM-1 + DO 140 K2=1,IELEM+1 + KNX1=KN(NUM,3+(K5+2)*NELEH+(K4*IELEM+K3)*(IELEM+1)+K2) + INX1=ABS(KNX1)-LL4W + DO 130 K1=1,IELEM+1 + KNX2=KN(NUM,3+(K5+2)*NELEH+(K4*IELEM+K3)*(IELEM+1)+K1) + INX2=ABS(KNX2)-LL4W + IF((KNX2.NE.0).AND.(KNX1.NE.0).AND.(INX1.GE.INX2)) THEN + KEY=((IL-1)/2)*MUMAX+MUX(INX1)-INX1+INX2 + SG=REAL(SIGN(1,KNX1)*SIGN(1,KNX2)) + VAR1=(4./3.)*SG*FACT*VOL0*GARS*R(K2,K1) + AX(KEY)=AX(KEY)-REAL(VAR1) + ENDIF + 130 CONTINUE + IF(KNX1.NE.0) THEN + KEY=((IL-1)/2)*MUMAX+MUX(INX1) + IF((K2.EQ.1).AND.(K5.EQ.0)) THEN + VAR1=0.5*FACT*QFR(NUM,3)*ZMARS + AX(KEY)=AX(KEY)-REAL(VAR1) + ELSE IF((K2.EQ.IELEM+1).AND.(K5.EQ.1)) THEN + VAR1=0.5*FACT*QFR(NUM,4)*ZMARS + AX(KEY)=AX(KEY)-REAL(VAR1) + ENDIF + ENDIF + 140 CONTINUE + 141 CONTINUE + 142 CONTINUE + 143 CONTINUE + 150 CONTINUE +* + DO 160 I0=1,MUMAX + C11X(((IL-1)/2)*MUMAX+I0)=-AX(((IL-1)/2)*MUMAX+I0) + 160 CONTINUE + MUIM1=0 + DO 190 I=1,LL4X + MUI=MUX(I) + DO 180 J=I-(MUI-MUIM1)+1,I + KEY=((IL-1)/2)*MUMAX+(MUI-I+J) + DO 175 I0=1,2*IELEM + II=IPBBX(I0,I) + IF(II.EQ.0) GO TO 180 + DO 170 J0=1,2*IELEM + JJ=IPBBX(J0,J) + IF(II.EQ.JJ) THEN + VAR1=REAL(IL**2)*BBX(I0,I)*BBX(J0,J)/TTF(((IL-1)/2)*LL4F+II) + C11X(KEY)=C11X(KEY)+REAL(VAR1) + ENDIF + 170 CONTINUE + 175 CONTINUE + 180 CONTINUE + MUIM1=MUI + 190 CONTINUE + 200 CONTINUE + RETURN + END +* + SUBROUTINE PN3HWY(NBMIX,NBLOS,IELEM,ICOL,NLF,NVD,NAN,LL4F,LL4W, + 1 LL4X,LL4Y,MAT,SIGT,SIDE,ZZ,FRZ,QFR,IPERT,KN,MUY,IPBBY,LC,R,BBY, + 2 TTF,AY,C11Y) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NBMIX,NBLOS,IELEM,ICOL,NLF,NVD,NAN,LL4F,LL4W,LL4X,LL4Y, + 1 MAT(3,NBLOS),MUY(LL4Y),IPBBY(2*IELEM,LL4Y),LC,IPERT(NBLOS), + 2 KN(NBLOS,3+6*(IELEM+2)*IELEM**2) + REAL SIGT(NBMIX,NAN),SIDE,ZZ(3,NBLOS),FRZ(NBLOS),QFR(NBLOS,8), + 1 R(LC,LC),BBY(2*IELEM,LL4Y),TTF(LL4F*NLF/2),AY(*),C11Y(*) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION TTTT,VOL0,GARS,FACT,VAR1 +*---- +* Y-ORIENTED COUPLINGS +*---- + ZMARS=0.0 + IF(ICOL.EQ.3) THEN + IF(NVD.EQ.0) THEN + NZMAR=NLF+1 + ELSE IF(NVD.EQ.1) THEN + NZMAR=NLF + ELSE IF(NVD.EQ.2) THEN + NZMAR=65 + ENDIF + ELSE + NZMAR=65 + ENDIF + MUMAX=MUY(LL4Y) + DO 280 IL=1,NLF-1,2 + ZMARS=PNMAR2(NZMAR,IL,IL) + FACT=REAL(2*IL+1) +*---- +* ASSEMBLY OF THE Y-ORIENTED COEFFICIENT MATRICES AT ODD ORDER IL. +*---- + NELEH=(IELEM+1)*IELEM**2 + TTTT=0.5D0*SQRT(3.D00)*SIDE*SIDE + NUM=0 + DO 230 KEL=1,NBLOS + IF(IPERT(KEL).EQ.0) GO TO 230 + IBM=MAT(1,IPERT(KEL)) + NUM=NUM+1 + IF(IBM.EQ.0) GO TO 230 + VOL0=TTTT*ZZ(1,IPERT(KEL))*FRZ(KEL) + GARS=SIGT(IBM,MIN(IL+1,NAN)) +* + DO 223 K5=0,1 ! TWO LOZENGES PER HEXAGON + DO 222 K4=0,IELEM-1 + DO 221 K3=0,IELEM-1 + DO 220 K2=1,IELEM+1 + KNY1=KN(NUM,3+(K5+4)*NELEH+(K4*IELEM+K3)*(IELEM+1)+K2) + INY1=ABS(KNY1)-LL4W-LL4X + DO 210 K1=1,IELEM+1 + KNY2=KN(NUM,3+(K5+4)*NELEH+(K4*IELEM+K3)*(IELEM+1)+K1) + INY2=ABS(KNY2)-LL4W-LL4X + IF((KNY2.NE.0).AND.(KNY1.NE.0).AND.(INY1.GE.INY2)) THEN + KEY=((IL-1)/2)*MUMAX+MUY(INY1)-INY1+INY2 + SG=REAL(SIGN(1,KNY1)*SIGN(1,KNY2)) + VAR1=(4./3.)*SG*FACT*VOL0*GARS*R(K2,K1) + AY(KEY)=AY(KEY)-REAL(VAR1) + ENDIF + 210 CONTINUE + IF(KNY1.NE.0) THEN + KEY=((IL-1)/2)*MUMAX+MUY(INY1) + IF((K2.EQ.1).AND.(K5.EQ.0)) THEN + VAR1=0.5*FACT*QFR(NUM,5)*ZMARS + AY(KEY)=AY(KEY)-REAL(VAR1) + ELSE IF((K2.EQ.IELEM+1).AND.(K5.EQ.1)) THEN + VAR1=0.5*FACT*QFR(NUM,6)*ZMARS + AY(KEY)=AY(KEY)-REAL(VAR1) + ENDIF + ENDIF + 220 CONTINUE + 221 CONTINUE + 222 CONTINUE + 223 CONTINUE + 230 CONTINUE +* + DO 240 I0=1,MUMAX + C11Y(((IL-1)/2)*MUMAX+I0)=-AY(((IL-1)/2)*MUMAX+I0) + 240 CONTINUE + MUIM1=0 + DO 270 I=1,LL4Y + MUI=MUY(I) + DO 260 J=I-(MUI-MUIM1)+1,I + KEY=((IL-1)/2)*MUMAX+(MUI-I+J) + DO 255 I0=1,2*IELEM + II=IPBBY(I0,I) + IF(II.EQ.0) GO TO 260 + DO 250 J0=1,2*IELEM + JJ=IPBBY(J0,J) + IF(II.EQ.JJ) C11Y(KEY)=C11Y(KEY)+REAL(IL**2)*BBY(I0,I)* + 1 BBY(J0,J)/TTF(((IL-1)/2)*LL4F+II) + 250 CONTINUE + 255 CONTINUE + 260 CONTINUE + MUIM1=MUI + 270 CONTINUE + 280 CONTINUE + RETURN + END +* + SUBROUTINE PN3HWZ(NBMIX,NBLOS,IELEM,ICOL,NLF,NVD,NAN,LL4F,LL4W, + 1 LL4X,LL4Y,LL4Z,MAT,SIGT,SIDE,ZZ,FRZ,QFR,IPERT,KN,MUZ,IPBBZ,LC, + 2 R,BBZ,TTF,AZ,C11Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NBMIX,NBLOS,IELEM,ICOL,NLF,NVD,NAN,LL4F,LL4W,LL4X, + 1 LL4Y,LL4Z,MAT(3,NBLOS),MUZ(LL4Z),IPBBZ(2*IELEM,LL4Z),LC, + 2 IPERT(NBLOS),KN(NBLOS,3+6*(IELEM+2)*IELEM**2) + REAL SIGT(NBMIX,NAN),SIDE,ZZ(3,NBLOS),FRZ(NBLOS),QFR(NBLOS,8), + 1 R(LC,LC),BBZ(2*IELEM,LL4Z),TTF(LL4F*NLF/2),AZ(*),C11Z(*) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION TTTT,VOL0,GARS,FACT,VAR1 +*---- +* Z-ORIENTED COUPLINGS +*---- + ZMARS=0.0 + IF(ICOL.EQ.3) THEN + IF(NVD.EQ.0) THEN + NZMAR=NLF+1 + ELSE IF(NVD.EQ.1) THEN + NZMAR=NLF + ELSE IF(NVD.EQ.2) THEN + NZMAR=65 + ENDIF + ELSE + NZMAR=65 + ENDIF + MUMAX=MUZ(LL4Z) + DO 360 IL=1,NLF-1,2 + ZMARS=PNMAR2(NZMAR,IL,IL) + FACT=REAL(2*IL+1) +*---- +* ASSEMBLY OF THE Z-ORIENTED COEFFICIENT MATRICES AT ODD ORDER IL. +*---- + NELEH=(IELEM+1)*IELEM**2 + TTTT=0.5D0*SQRT(3.D00)*SIDE*SIDE + NUM=0 + DO 310 KEL=1,NBLOS + IF(IPERT(KEL).EQ.0) GO TO 310 + IBM=MAT(1,IPERT(KEL)) + IF(IBM.EQ.0) GO TO 310 + NUM=NUM+1 + VOL0=TTTT*ZZ(1,IPERT(KEL))*FRZ(KEL) + GARS=SIGT(IBM,MIN(IL+1,NAN)) +* + DO 302 K5=0,2 ! THREE LOZENGES PER HEXAGON + DO 301 K2=0,IELEM-1 + DO 300 K1=0,IELEM-1 + KNZ1=KN(NUM,3+6*NELEH+2*K5*IELEM**2+K2*IELEM+K1+1) + INZ1=ABS(KNZ1)-LL4W-LL4X-LL4Y + KNZ2=KN(NUM,3+6*NELEH+(2*K5+1)*IELEM**2+K2*IELEM+K1+1) + INZ2=ABS(KNZ2)-LL4W-LL4X-LL4Y + IF(KNZ1.NE.0) THEN + KEY=((IL-1)/2)*MUMAX+MUZ(INZ1) + VAR1=FACT*VOL0*GARS*R(1,1)+0.5*FACT*QFR(NUM,7)*ZMARS + AZ(KEY)=AZ(KEY)-REAL(VAR1) + ENDIF + IF(KNZ2.NE.0) THEN + KEY=((IL-1)/2)*MUMAX+MUZ(INZ2) + VAR1=FACT*VOL0*GARS*R(IELEM+1,IELEM+1)+0.5*FACT*QFR(NUM,8)*ZMARS + AZ(KEY)=AZ(KEY)-REAL(VAR1) + ENDIF + IF((ICOL.NE.2).AND.(KNZ1.NE.0).AND.(KNZ2.NE.0)) THEN + IF(INZ2.GT.INZ1) KEY=((IL-1)/2)*MUMAX+MUZ(INZ2)-INZ2+INZ1 + IF(INZ2.LE.INZ1) KEY=((IL-1)/2)*MUMAX+MUZ(INZ1)-INZ1+INZ2 + SG=REAL(SIGN(1,KNZ1)*SIGN(1,KNZ2)) + IF(INZ1.EQ.INZ2) SG=2.0*SG + VAR1=SG*FACT*VOL0*GARS*R(IELEM+1,1) + AZ(KEY)=AZ(KEY)-REAL(VAR1) + ENDIF + 300 CONTINUE + 301 CONTINUE + 302 CONTINUE + 310 CONTINUE +* + DO 320 I0=1,MUMAX + C11Z(((IL-1)/2)*MUMAX+I0)=-AZ(((IL-1)/2)*MUMAX+I0) + 320 CONTINUE + MUIM1=0 + DO 350 I=1,LL4Z + MUI=MUZ(I) + DO 340 J=I-(MUI-MUIM1)+1,I + KEY=((IL-1)/2)*MUMAX+(MUI-I+J) + DO 335 I0=1,2*IELEM + II=IPBBZ(I0,I) + IF(II.EQ.0) GO TO 340 + DO 330 J0=1,2*IELEM + JJ=IPBBZ(J0,J) + IF(II.EQ.JJ) C11Z(KEY)=C11Z(KEY)+REAL(IL**2)*BBZ(I0,I)* + 1 BBZ(J0,J)/TTF(((IL-1)/2)*LL4F+II) + 330 CONTINUE + 335 CONTINUE + 340 CONTINUE + MUIM1=MUI + 350 CONTINUE + 360 CONTINUE + RETURN + END diff --git a/Trivac/src/PNDH2E.f b/Trivac/src/PNDH2E.f new file mode 100755 index 0000000..9614391 --- /dev/null +++ b/Trivac/src/PNDH2E.f @@ -0,0 +1,300 @@ +*DECK PNDH2E + SUBROUTINE PNDH2E(ITY,IELEM,ICOL,NBLOS,L4,NBMIX,IIMAX,SIDE,MAT, + 1 IPERT,SIGT,KN,QFR,NLF,NVD,NAN,MU,LC,R,V,H,SYS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Assembly of a within-group (leakage and removal) or out-of-group +* system matrix in a Thomas-Raviart-Schneider (dual) finite element +* simplified PN method approximation (2D hexagonal geometry). +* +*Copyright: +* Copyright (C) 2009 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* ITY type of assembly: +* =0: leakage-removal matrix assembly; =1: cross section matrix +* assembly. +* IELEM degree of the Lagrangian finite elements: =1 (linear); +* =2 (parabolic); =3 (cubic); =4 (quartic). +* ICOL type of quadrature: =1 (analytical integration); +* =2 (Gauss-Lobatto); =3 (Gauss-Legendre). +* NBLOS number of lozenges per direction, taking into account +* mesh-splitting. +* L4 number of unknowns per energy group and per set of two +* Legendre orders. +* NBMIX number of mixtures. +* IIMAX allocated dimension of array SYS. +* SIDE side of the hexagons. +* MAT mixture index assigned to each element. +* SIGT total minus self-scattering macroscopic cross sections. +* SIGT(:,NAN) generally contains the total cross section only. +* KN element-ordered unknown list. +* QFR element-ordered boundary conditions. +* NLF number of Legendre orders for the flux (even number). +* NVD type of void boundary condition if NLF>0 and ICOL=3. +* NAN number of Legendre orders for the cross sections. +* MU indices used with compressed diagonal storage mode matrix SYS. +* LC order of the unit matrices. +* R Cartesian mass matrix. +* V nodal coupling matrix. +* H Piolat (hexagonal) coupling matrix. +* +*Parameters: output +* SYS system matrix. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER ITY,IELEM,ICOL,NBLOS,L4,NBMIX,IIMAX,MAT(3,NBLOS), + 1 IPERT(NBLOS),KN(NBLOS,4+6*IELEM*(IELEM+1)),NLF,NVD,NAN,MU(L4),LC + REAL SIDE,SIGT(NBMIX,NAN),QFR(NBLOS,6),R(LC,LC),V(LC,LC-1), + 1 H(LC,LC-1),SYS(IIMAX) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(MAXIEL=3) + DOUBLE PRECISION CTRAN(MAXIEL*(MAXIEL+1),MAXIEL*(MAXIEL+1)),VAR1 +* + TTTT=REAL(0.5D0*SQRT(3.D00)*SIDE*SIDE) + IF(IELEM.GT.MAXIEL) CALL XABORT('PNDH2E: MAXIEL OVERFLOW.') + NZMAR=65 + IF(ICOL.EQ.3) THEN + IF(NVD.EQ.0) THEN + NZMAR=NLF+1 + ELSE IF(NVD.EQ.1) THEN + NZMAR=NLF + ELSE IF(NVD.EQ.2) THEN + NZMAR=65 + ENDIF + ENDIF + MUMAX=MU(L4) + NELEM=IELEM*(IELEM+1) + COEF=REAL(2.0D0*SIDE*SIDE/SQRT(3.D00)) +*---- +* COMPUTE THE TRANVERSE COUPLING PIOLAT UNIT MATRIX +*---- + CTRAN(:MAXIEL*(MAXIEL+1),:MAXIEL*(MAXIEL+1))=0.0D0 + CNORM=REAL(SIDE*SIDE/SQRT(3.D00)) + I=0 + DO 22 JS=1,IELEM + DO 21 JT=1,IELEM+1 + J=0 + I=I+1 + SSS=1.0 + DO 20 IT=1,IELEM + DO 10 IS=1,IELEM+1 + J=J+1 + CTRAN(I,J)=SSS*CNORM*H(IS,JS)*H(JT,IT) + 10 CONTINUE + SSS=-SSS + 20 CONTINUE + 21 CONTINUE + 22 CONTINUE +*---- +* ASSEMBLY OF THE MAIN COEFFICIENT MATRIX AT ORDER IL. +*---- + DO 100 IL=0,NLF-1 + ZMARS=0.0 + IF(MOD(IL,2).EQ.1) ZMARS=PNMAR2(NZMAR,IL,IL) + FACT=REAL(2*IL+1) + NUM=0 + KEY=0 + DO 90 KEL=1,NBLOS + IF(IPERT(KEL).EQ.0) GO TO 90 + IBM=MAT(1,IPERT(KEL)) + IF(IBM.EQ.0) GO TO 90 + NUM=NUM+1 + GARS=SIGT(IBM,MIN(IL+1,NAN)) + IF(MOD(IL,2).EQ.0) THEN +* EVEN PARITY EQUATION. + DO 35 K2=0,IELEM-1 + DO 30 K1=0,IELEM-1 + JND1=KN(NUM,1)+K2*IELEM+K1 + JND2=KN(NUM,2)+K2*IELEM+K1 + JND3=KN(NUM,3)+K2*IELEM+K1 + KEY=(IL/2)*MUMAX+MU(JND1) + SYS(KEY)=SYS(KEY)+FACT*TTTT*GARS + KEY=(IL/2)*MUMAX+MU(JND2) + SYS(KEY)=SYS(KEY)+FACT*TTTT*GARS + KEY=(IL/2)*MUMAX+MU(JND3) + SYS(KEY)=SYS(KEY)+FACT*TTTT*GARS + 30 CONTINUE + 35 CONTINUE + ELSE +* ODD PARITY EQUATION. + DO 52 K4=0,1 + DO 51 K3=0,IELEM-1 + DO 50 K2=1,IELEM+1 + KNW1=KN(NUM,4+K4*NELEM+K3*(IELEM+1)+K2) + KNX1=KN(NUM,4+(K4+2)*NELEM+K3*(IELEM+1)+K2) + KNY1=KN(NUM,4+(K4+4)*NELEM+K3*(IELEM+1)+K2) + INW1=ABS(KNW1) + INX1=ABS(KNX1) + INY1=ABS(KNY1) + DO 40 K1=1,IELEM+1 + KNW2=KN(NUM,4+K4*NELEM+K3*(IELEM+1)+K1) + KNX2=KN(NUM,4+(K4+2)*NELEM+K3*(IELEM+1)+K1) + KNY2=KN(NUM,4+(K4+4)*NELEM+K3*(IELEM+1)+K1) + INW2=ABS(KNW2) + INX2=ABS(KNX2) + INY2=ABS(KNY2) + IF((KNW2.NE.0).AND.(KNW1.NE.0).AND.(INW1.GE.INW2)) THEN + KEY=(IL/2)*MUMAX+MU(INW1)-INW1+INW2 + SG=REAL(SIGN(1,KNW1)*SIGN(1,KNW2)) + SYS(KEY)=SYS(KEY)-SG*FACT*COEF*GARS*R(K2,K1) + ENDIF + IF((KNX2.NE.0).AND.(KNX1.NE.0).AND.(INX1.GE.INX2)) THEN + KEY=(IL/2)*MUMAX+MU(INX1)-INX1+INX2 + SG=REAL(SIGN(1,KNX1)*SIGN(1,KNX2)) + SYS(KEY)=SYS(KEY)-SG*FACT*COEF*GARS*R(K2,K1) + ENDIF + IF((KNY2.NE.0).AND.(KNY1.NE.0).AND.(INY1.GE.INY2)) THEN + KEY=(IL/2)*MUMAX+MU(INY1)-INY1+INY2 + SG=REAL(SIGN(1,KNY1)*SIGN(1,KNY2)) + SYS(KEY)=SYS(KEY)-SG*FACT*COEF*GARS*R(K2,K1) + ENDIF + 40 CONTINUE + IF(ITY.EQ.0) THEN + IF(KNW1.NE.0) THEN + KEY=(IL/2)*MUMAX+MU(INW1) + IF((K2.EQ.1).AND.(K4.EQ.0)) THEN + SYS(KEY)=SYS(KEY)-0.5*FACT*QFR(NUM,1)*ZMARS + ELSE IF((K2.EQ.IELEM+1).AND.(K4.EQ.1)) THEN + SYS(KEY)=SYS(KEY)-0.5*FACT*QFR(NUM,2)*ZMARS + ENDIF + ENDIF + IF(KNX1.NE.0) THEN + KEY=(IL/2)*MUMAX+MU(INX1) + IF((K2.EQ.1).AND.(K4.EQ.0)) THEN + SYS(KEY)=SYS(KEY)-0.5*FACT*QFR(NUM,3)*ZMARS + ELSE IF((K2.EQ.IELEM+1).AND.(K4.EQ.1)) THEN + SYS(KEY)=SYS(KEY)-0.5*FACT*QFR(NUM,4)*ZMARS + ENDIF + ENDIF + IF(KNY1.NE.0) THEN + KEY=(IL/2)*MUMAX+MU(INY1) + IF((K2.EQ.1).AND.(K4.EQ.0)) THEN + SYS(KEY)=SYS(KEY)-0.5*FACT*QFR(NUM,5)*ZMARS + ELSE IF((K2.EQ.IELEM+1).AND.(K4.EQ.1)) THEN + SYS(KEY)=SYS(KEY)-0.5*FACT*QFR(NUM,6)*ZMARS + ENDIF + ENDIF + ENDIF + 50 CONTINUE + 51 CONTINUE + 52 CONTINUE +* + ITRS=0 + DO I=1,NBLOS + IF(KN(I,1).EQ.KN(NUM,4)) THEN + ITRS=I + GO TO 60 + ENDIF + ENDDO + CALL XABORT('PNDH2E: ITRS FAILURE.') + 60 DO 75 I=1,NELEM + KNW1=KN(ITRS,4+I) + KNX1=KN(NUM,4+2*NELEM+I) + KNY1=KN(NUM,4+4*NELEM+I) + INW1=ABS(KNW1) + INX1=ABS(KNX1) + INY1=ABS(KNY1) + DO 70 J=1,NELEM + KNW2=KN(NUM,4+NELEM+J) + KNX2=KN(NUM,4+3*NELEM+J) + KNY2=KN(NUM,4+5*NELEM+J) + INW2=ABS(KNW2) + INX2=ABS(KNX2) + INY2=ABS(KNY2) + VAR1=FACT*GARS*CTRAN(I,J) + IF((KNY2.NE.0).AND.(KNW1.NE.0).AND.(INW1.LT.INY2)) THEN + KEY=(IL/2)*MUMAX+MU(INY2)-INY2+INW1 + SG=REAL(SIGN(1,KNW1)*SIGN(1,KNY2)) + SYS(KEY)=SYS(KEY)-SG*REAL(VAR1) ! y w + ELSE IF((KNY2.NE.0).AND.(KNW1.NE.0).AND.(INW1.GT.INY2)) THEN + KEY=(IL/2)*MUMAX+MU(INW1)-INW1+INY2 + SG=REAL(SIGN(1,KNW1)*SIGN(1,KNY2)) + SYS(KEY)=SYS(KEY)-SG*REAL(VAR1) ! w y + ENDIF + IF((KNW2.NE.0).AND.(KNX1.NE.0).AND.(INW2.LT.INX1)) THEN + KEY=(IL/2)*MUMAX+MU(INX1)-INX1+INW2 + SG=REAL(SIGN(1,KNX1)*SIGN(1,KNW2)) + SYS(KEY)=SYS(KEY)-SG*REAL(VAR1) ! x w + ELSE IF((KNW2.NE.0).AND.(KNX1.NE.0).AND.(INW2.GT.INX1)) THEN + KEY=(IL/2)*MUMAX+MU(INW2)-INW2+INX1 + SG=REAL(SIGN(1,KNX1)*SIGN(1,KNW2)) + SYS(KEY)=SYS(KEY)-SG*REAL(VAR1) ! w x + ENDIF + IF((KNX2.NE.0).AND.(KNY1.NE.0).AND.(INX2.LT.INY1)) THEN + KEY=(IL/2)*MUMAX+MU(INY1)-INY1+INX2 + SG=REAL(SIGN(1,KNY1)*SIGN(1,KNX2)) + SYS(KEY)=SYS(KEY)-SG*REAL(VAR1) ! y x + ELSE IF((KNX2.NE.0).AND.(KNY1.NE.0).AND.(INX2.GT.INY1)) THEN + KEY=(IL/2)*MUMAX+MU(INX2)-INX2+INY1 + SG=REAL(SIGN(1,KNY1)*SIGN(1,KNX2)) + SYS(KEY)=SYS(KEY)-SG*REAL(VAR1) ! x y + ENDIF + 70 CONTINUE + 75 CONTINUE +* + IF(ITY.EQ.0) THEN + DO 83 K4=0,1 + DO 82 K3=0,IELEM-1 + DO 81 K2=1,IELEM+1 + KNW1=KN(NUM,4+K4*NELEM+K3*(IELEM+1)+K2) + KNX1=KN(NUM,4+(K4+2)*NELEM+K3*(IELEM+1)+K2) + KNY1=KN(NUM,4+(K4+4)*NELEM+K3*(IELEM+1)+K2) + INW1=ABS(KNW1) + INX1=ABS(KNX1) + INY1=ABS(KNY1) + DO 80 K1=0,IELEM-1 + IF(V(K2,K1+1).EQ.0.0) GO TO 80 + IF(K4.EQ.0) THEN + SSS=(-1.0)**K1 + JND1=KN(NUM,1)+K3*IELEM+K1 + JND2=KN(NUM,2)+K3*IELEM+K1 + JND3=KN(NUM,3)+K3*IELEM+K1 + ELSE + SSS=1.0 + JND1=KN(NUM,2)+K1*IELEM+K3 + JND2=KN(NUM,3)+K1*IELEM+K3 + JND3=KN(NUM,4)+K1*IELEM+K3 + ENDIF + IF(KNW1.NE.0) THEN + IF(JND1.GT.INW1) KEY=(IL/2)*MUMAX+MU(JND1)-JND1+INW1 + IF(JND1.LT.INW1) KEY=(IL/2)*MUMAX+MU(INW1)-INW1+JND1 + SG=REAL(SIGN(1,KNW1)) + SYS(KEY)=SYS(KEY)+SG*SSS*REAL(IL)*SIDE*V(K2,K1+1) + ENDIF + IF(KNX1.NE.0) THEN + IF(JND2.GT.INX1) KEY=(IL/2)*MUMAX+MU(JND2)-JND2+INX1 + IF(JND2.LT.INX1) KEY=(IL/2)*MUMAX+MU(INX1)-INX1+JND2 + SG=REAL(SIGN(1,KNX1)) + SYS(KEY)=SYS(KEY)+SG*SSS*REAL(IL)*SIDE*V(K2,K1+1) + ENDIF + IF(KNY1.NE.0) THEN + IF(JND3.GT.INY1) KEY=(IL/2)*MUMAX+MU(JND3)-JND3+INY1 + IF(JND3.LT.INY1) KEY=(IL/2)*MUMAX+MU(INY1)-INY1+JND3 + SG=REAL(SIGN(1,KNY1)) + SYS(KEY)=SYS(KEY)+SG*SSS*REAL(IL)*SIDE*V(K2,K1+1) + ENDIF + 80 CONTINUE + 81 CONTINUE + 82 CONTINUE + 83 CONTINUE + ENDIF + ENDIF + 90 CONTINUE + 100 CONTINUE + RETURN + END diff --git a/Trivac/src/PNDM2E.f b/Trivac/src/PNDM2E.f new file mode 100755 index 0000000..a501b70 --- /dev/null +++ b/Trivac/src/PNDM2E.f @@ -0,0 +1,247 @@ +*DECK PNDM2E + SUBROUTINE PNDM2E(ITY,NEL,L4,IELEM,ICOL,MAT,VOL,NBMIX,NLF,NVD, + 1 NAN,SIGT,SIGTI,XX,YY,KN,QFR,MU,IIMAX,LC,R,V,SYS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Assembly of system matrices for a mixed-dual formulation of the +* simplified PN method in 2D Cartesian geometry. +* +*Copyright: +* Copyright (C) 2004 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* ITY type of assembly: +* =0: leakage-removal matrix assembly; =1: cross section matrix +* assembly. +* NEL number of finite elements. +* L4 number of unknowns per energy group and per set of two +* Legendre orders. +* IELEM degree of the Lagrangian finite elements: =1 (linear); +* =2 (parabolic); =3 (cubic); =4 (quartic). +* ICOL type of quadrature: =1 (analytical integration); +* =2 (Gauss-Lobatto); =3 (Gauss-Legendre). +* MAT mixture index assigned to each element. +* VOL volume of each element. +* NBMIX number of mixtures. +* NLF number of Legendre orders for the flux (even number). +* NVD type of void boundary condition if NLF>0 and ICOL=3. +* NAN number of Legendre orders for the cross sections. +* SIGT total minus self-scattering macroscopic cross sections. +* SIGT(:,NAN) generally contains the total cross section only. +* SIGTI inverse macroscopic cross sections ordered by mixture. +* SIGTI(:,NAN) generally contains the inverse total cross +* section only. +* XX X-directed mesh spacings. +* YY Y-directed mesh spacings. +* KN element-ordered unknown list. +* QFR element-ordered boundary conditions. +* MU compressed storage mode indices. +* IIMAX dimension of vector SYS. +* LC order of the unit matrices. +* R unit Cartesian mass matrix. +* V unit nodal coupling matrix. +* +*Parameters: output +* SYS system matrix. +* +*Reference: +* J.J. Lautard, D. Schneider, A.M. Baudron, "Mixed Dual Methods for +* Neutronic Reactor Core Calculations in the CRONOS System," +* Proc. Int. Conf. on Mathematics and Computation, Reactor +* Physics and Environmental Analysis in Nuclear Applications, +* Madrid, Spain, September 27-30, 1999. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER ITY,NEL,L4,IELEM,ICOL,MAT(NEL),NBMIX,NLF,NAN,KN(5*NEL), + 1 MU(L4),IIMAX,LC + REAL VOL(NEL),SIGT(NBMIX,NAN),SIGTI(NBMIX,NAN),XX(NEL),YY(NEL), + 1 QFR(4*NEL),R(LC,LC),V(LC,LC-1),SYS(IIMAX) +*---- +* LOCAL VARIABLES +*---- + REAL QQ(5,5) +* + IF(ICOL.EQ.3) THEN + IF(NVD.EQ.0) THEN + NZMAR=NLF+1 + ELSE IF(NVD.EQ.1) THEN + NZMAR=NLF + ELSE IF(NVD.EQ.2) THEN + NZMAR=65 + ENDIF + ELSE + NZMAR=65 + ENDIF + DO 12 I0=1,IELEM + DO 11 J0=1,IELEM + QQ(I0,J0)=0.0 + DO 10 K0=2,IELEM + QQ(I0,J0)=QQ(I0,J0)+V(K0,I0)*V(K0,J0)/R(K0,K0) + 10 CONTINUE + 11 CONTINUE + 12 CONTINUE + MUMAX=MU(L4) + DO 100 IL=0,NLF-1 + ZMARS=0.0 + IF(MOD(IL,2).EQ.1) ZMARS=PNMAR2(NZMAR,IL,IL) + FACT=REAL(2*IL+1) +*---- +* ASSEMBLY OF THE MAIN COEFFICIENT MATRIX AT ORDER IL. +*---- + NUM1=0 + NUM2=0 + KEY=0 + DO 90 K=1,NEL + IBM=MAT(K) + IF(IBM.EQ.0) GO TO 90 + VOL0=VOL(K) + GARS=SIGT(IBM,MIN(IL+1,NAN)) + IF(MOD(IL,2).EQ.0) THEN +* EVEN PARITY EQUATION. + DO 25 I0=1,IELEM + DO 20 J0=1,IELEM + JND1=KN(NUM1+1)+(I0-1)*IELEM+J0-1 + KEY=(IL/2)*MUMAX+MU(JND1) + SYS(KEY)=SYS(KEY)+FACT*VOL0*GARS + 20 CONTINUE + 25 CONTINUE + ELSE + GARSI=SIGTI(IBM,MIN(IL+1,NAN)) + DO 80 I0=1,IELEM +* PARTIAL INVERSION OF THE ODD PARITY EQUATION. MODIFICATION OF +* THE EVEN PARITY EQUATION. + DO 45 J0=1,IELEM + JND1=KN(NUM1+1)+(I0-1)*IELEM+J0-1 + DO 30 K0=1,J0 + IF(QQ(J0,K0).EQ.0.0) GO TO 30 + KND1=KN(NUM1+1)+(I0-1)*IELEM+K0-1 + KEY=(IL/2)*MUMAX+MU(JND1)-JND1+KND1 + SYS(KEY)=SYS(KEY)+(REAL(IL)**2)*VOL0*QQ(J0,K0)*GARSI/(FACT* + 1 XX(K)*XX(K)) + IF(IL.LE.NLF-3) THEN + KEY=((IL+2)/2)*MUMAX+MU(JND1)-JND1+KND1 + SYS(KEY)=SYS(KEY)+(REAL(IL+1)**2)*VOL0*QQ(J0,K0)*GARSI/ + 1 (FACT*XX(K)*XX(K)) + ENDIF + 30 CONTINUE + JND1=KN(NUM1+1)+(J0-1)*IELEM+I0-1 + DO 40 K0=1,J0 + IF(QQ(J0,K0).EQ.0.0) GO TO 40 + KND1=KN(NUM1+1)+(K0-1)*IELEM+I0-1 + KEY=(IL/2)*MUMAX+MU(JND1)-JND1+KND1 + SYS(KEY)=SYS(KEY)+(REAL(IL)**2)*VOL0*QQ(J0,K0)*GARSI/(FACT* + 1 YY(K)*YY(K)) + IF(IL.LE.NLF-3) THEN + KEY=((IL+2)/2)*MUMAX+MU(JND1)-JND1+KND1 + SYS(KEY)=SYS(KEY)+(REAL(IL+1)**2)*VOL0*QQ(J0,K0)*GARSI/ + 1 (FACT*YY(K)*YY(K)) + ENDIF + 40 CONTINUE + 45 CONTINUE +* +* ODD PARITY EQUATION. + DO 55 IC=1,2 + IIC=1 + IF(IC.EQ.2) IIC=IELEM+1 + IND1=ABS(KN(NUM1+1+IC))+I0-1 + S1=REAL(SIGN(1,KN(NUM1+1+IC))) + DO 50 JC=1,2 + JJC=1 + IF(JC.EQ.2) JJC=IELEM+1 + IND2=ABS(KN(NUM1+1+JC))+I0-1 + IF((KN(NUM1+1+IC).NE.0).AND.(KN(NUM1+1+JC).NE.0).AND. + 1 (IND1.GE.IND2)) THEN + S2=REAL(SIGN(1,KN(NUM1+1+JC))) + KEY=(IL/2)*MUMAX+MU(IND1)-IND1+IND2 + SYS(KEY)=SYS(KEY)-S1*S2*FACT*R(IIC,JJC)*VOL0*GARS + ENDIF + 50 CONTINUE + 55 CONTINUE + DO 65 IC=3,4 + IIC=1 + IF(IC.EQ.4) IIC=IELEM+1 + IND1=ABS(KN(NUM1+1+IC))+I0-1 + S1=REAL(SIGN(1,KN(NUM1+1+IC))) + DO 60 JC=3,4 + JJC=1 + IF(JC.EQ.4) JJC=IELEM+1 + IND2=ABS(KN(NUM1+1+JC))+I0-1 + IF((KN(NUM1+1+IC).NE.0).AND.(KN(NUM1+1+JC).NE.0).AND. + 1 (IND1.GE.IND2)) THEN + S2=REAL(SIGN(1,KN(NUM1+1+JC))) + KEY=(IL/2)*MUMAX+MU(IND1)-IND1+IND2 + SYS(KEY)=SYS(KEY)-S1*S2*FACT*R(IIC,JJC)*VOL0*GARS + ENDIF + 60 CONTINUE + 65 CONTINUE + IF(ITY.EQ.1) GO TO 80 +* + IND1=ABS(KN(NUM1+2))+I0-1 + IND2=ABS(KN(NUM1+3))+I0-1 + IND3=ABS(KN(NUM1+4))+I0-1 + IND4=ABS(KN(NUM1+5))+I0-1 + IF((QFR(NUM2+1).NE.0.0).AND.(KN(NUM1+2).NE.0)) THEN + KEY=(IL/2)*MUMAX+MU(IND1) + SYS(KEY)=SYS(KEY)-0.5*FACT*QFR(NUM2+1)*ZMARS + ENDIF + IF((QFR(NUM2+2).NE.0.0).AND.(KN(NUM1+3).NE.0)) THEN + KEY=(IL/2)*MUMAX+MU(IND2) + SYS(KEY)=SYS(KEY)-0.5*FACT*QFR(NUM2+2)*ZMARS + ENDIF + IF((QFR(NUM2+3).NE.0.0).AND.(KN(NUM1+4).NE.0)) THEN + KEY=(IL/2)*MUMAX+MU(IND3) + SYS(KEY)=SYS(KEY)-0.5*FACT*QFR(NUM2+3)*ZMARS + ENDIF + IF((QFR(NUM2+4).NE.0.0).AND.(KN(NUM1+5).NE.0)) THEN + KEY=(IL/2)*MUMAX+MU(IND4) + SYS(KEY)=SYS(KEY)-0.5*FACT*QFR(NUM2+4)*ZMARS + ENDIF +* + DO 70 J0=1,IELEM + JND1=KN(NUM1+1)+(I0-1)*IELEM+J0-1 + IF(KN(NUM1+2).NE.0) THEN + S1=REAL(SIGN(1,KN(NUM1+2))) + IF(JND1.GT.IND1) KEY=(IL/2)*MUMAX+MU(JND1)-JND1+IND1 + IF(JND1.LT.IND1) KEY=(IL/2)*MUMAX+MU(IND1)-IND1+JND1 + SYS(KEY)=SYS(KEY)+S1*REAL(IL)*VOL0*V(1,J0)/XX(K) + ENDIF + IF(KN(NUM1+3).NE.0) THEN + S2=REAL(SIGN(1,KN(NUM1+3))) + IF(JND1.GT.IND2) KEY=(IL/2)*MUMAX+MU(JND1)-JND1+IND2 + IF(JND1.LT.IND2) KEY=(IL/2)*MUMAX+MU(IND2)-IND2+JND1 + SYS(KEY)=SYS(KEY)+S2*REAL(IL)*VOL0*V(IELEM+1,J0)/XX(K) + ENDIF + JND1=KN(NUM1+1)+(J0-1)*IELEM+I0-1 + IF(KN(NUM1+4).NE.0) THEN + S3=REAL(SIGN(1,KN(NUM1+4))) + IF(JND1.GT.IND3) KEY=(IL/2)*MUMAX+MU(JND1)-JND1+IND3 + IF(JND1.LT.IND3) KEY=(IL/2)*MUMAX+MU(IND3)-IND3+JND1 + SYS(KEY)=SYS(KEY)+S3*REAL(IL)*VOL0*V(1,J0)/YY(K) + ENDIF + IF(KN(NUM1+5).NE.0) THEN + S4=REAL(SIGN(1,KN(NUM1+5))) + IF(JND1.GT.IND4) KEY=(IL/2)*MUMAX+MU(JND1)-JND1+IND4 + IF(JND1.LT.IND4) KEY=(IL/2)*MUMAX+MU(IND4)-IND4+JND1 + SYS(KEY)=SYS(KEY)+S4*REAL(IL)*VOL0*V(IELEM+1,J0)/YY(K) + ENDIF + 70 CONTINUE + 80 CONTINUE + ENDIF + NUM1=NUM1+5 + NUM2=NUM2+4 + 90 CONTINUE + 100 CONTINUE + RETURN + END diff --git a/Trivac/src/PNFH2E.f b/Trivac/src/PNFH2E.f new file mode 100755 index 0000000..ee0998e --- /dev/null +++ b/Trivac/src/PNFH2E.f @@ -0,0 +1,225 @@ +*DECK PNFH2E + SUBROUTINE PNFH2E (IELEM,ICOL,NBLOS,SIDE,NLF,NVD,L4,IPERT,KN, + 1 QFR,MU,IIMAX,LC,V,SYS,SUNKNO,FUNKNO,NADI) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform a one-group SPN flux iteration in hexagonal 2D geometry. +* Raviart-Thomas-Schneider method in hexagonal geometry. +* +*Copyright: +* Copyright (C) 2009 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IELEM degree of the Lagrangian finite elements: =1 (linear); +* =2 (parabolic); =3 (cubic); =4 (quartic). +* ICOL type of quadrature: =1 (analytical integration); +* =2 (Gauss-Lobatto); =3 (Gauss-Legendre). +* NBLOS number of lozenges per direction, taking into account +* mesh-splitting. +* SIDE side of the hexagons. +* NLF number of Legendre orders for the flux (even number). +* NVD type of void boundary condition if NLF>0 and ICOL=3. +* L4 number of unknowns per energy group and per set of two +* Legendre orders. +* IPERT mixture permutation index. +* KN element-ordered unknown list. +* QFR element-ordered boundary conditions. +* MU profiled storage indices for matrix SYS. +* IIMAX dimension of SYS. +* LC order of the unit matrices. +* V unit nodal coupling matrix. +* SYS LU factors of the system matrix. +* SUNKNO sources. +* FUNKNO initial fluxes. +* NADI number of inner ADI iterations. +* +*Parameters: output +* FUNKNO fluxes. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IELEM,ICOL,NBLOS,NLF,NVD,L4,IPERT(NBLOS), + 1 KN(NBLOS,4+6*IELEM*(IELEM+1)),MU(L4),IIMAX,LC,NADI + REAL SIDE,QFR(NBLOS,6),V(LC,LC-1),SYS(IIMAX),SUNKNO(L4*NLF/2), + 1 FUNKNO(L4*NLF/2) +* + IF(ICOL.EQ.3) THEN + IF(NVD.EQ.0) THEN + NZMAR=NLF+1 + ELSE IF(NVD.EQ.1) THEN + NZMAR=NLF + ELSE IF(NVD.EQ.2) THEN + NZMAR=65 + ENDIF + ELSE + NZMAR=65 + ENDIF + MUMAX=MU(L4) + NELEM=IELEM*(IELEM+1) + DO 170 IADI=1,MAX(1,NADI) + DO 160 IL=0,NLF-1 + FACT=REAL(2*IL+1) + IF(MOD(IL,2).EQ.0) THEN + DO 10 I=1,L4 + FUNKNO((IL/2)*L4+I)=SUNKNO((IL/2)*L4+I) + 10 CONTINUE + ENDIF +*---- +* COMPUTE THE SOLUTION AT ORDER IL. +*---- + NUM=0 + DO 150 KEL=1,NBLOS + IF(IPERT(KEL).EQ.0) GO TO 150 + NUM=NUM+1 + IF(MOD(IL,2).EQ.0) THEN +* EVEN PARITY EQUATION + IF(IL.GE.2) THEN + DO 33 K4=0,1 + DO 32 K3=0,IELEM-1 + DO 31 K2=1,IELEM+1 + KNW1=KN(NUM,4+K4*NELEM+K3*(IELEM+1)+K2) + KNX1=KN(NUM,4+(K4+2)*NELEM+K3*(IELEM+1)+K2) + KNY1=KN(NUM,4+(K4+4)*NELEM+K3*(IELEM+1)+K2) + INW1=((IL-2)/2)*L4+ABS(KNW1) + INX1=((IL-2)/2)*L4+ABS(KNX1) + INY1=((IL-2)/2)*L4+ABS(KNY1) + DO 30 K1=0,IELEM-1 + IF(V(K2,K1+1).EQ.0.0) GO TO 30 + IF(K4.EQ.0) THEN + SSS=(-1.0)**K1 + JND1=(IL/2)*L4+KN(NUM,1)+K3*IELEM+K1 + JND2=(IL/2)*L4+KN(NUM,2)+K3*IELEM+K1 + JND3=(IL/2)*L4+KN(NUM,3)+K3*IELEM+K1 + ELSE + SSS=1.0 + JND1=(IL/2)*L4+KN(NUM,2)+K1*IELEM+K3 + JND2=(IL/2)*L4+KN(NUM,3)+K1*IELEM+K3 + JND3=(IL/2)*L4+KN(NUM,4)+K1*IELEM+K3 + ENDIF + IF(KNW1.NE.0) THEN + SG=REAL(SIGN(1,KNW1)) + FUNKNO(JND1)=FUNKNO(JND1)-SG*SSS*REAL(IL)*SIDE* + 1 V(K2,K1+1)*FUNKNO(INW1) + ENDIF + IF(KNX1.NE.0) THEN + SG=REAL(SIGN(1,KNX1)) + FUNKNO(JND2)=FUNKNO(JND2)-SG*SSS*REAL(IL)*SIDE* + 1 V(K2,K1+1)*FUNKNO(INX1) + ENDIF + IF(KNY1.NE.0) THEN + SG=REAL(SIGN(1,KNY1)) + FUNKNO(JND3)=FUNKNO(JND3)-SG*SSS*REAL(IL)*SIDE* + 1 V(K2,K1+1)*FUNKNO(INY1) + ENDIF + 30 CONTINUE + 31 CONTINUE + 32 CONTINUE + 33 CONTINUE + ENDIF + ELSE +* ODD PARITY EQUATION + DO 142 K4=0,1 + DO 141 K3=0,IELEM-1 + DO 140 K2=1,IELEM+1 + KNW1=KN(NUM,4+K4*NELEM+K3*(IELEM+1)+K2) + KNX1=KN(NUM,4+(K4+2)*NELEM+K3*(IELEM+1)+K2) + KNY1=KN(NUM,4+(K4+4)*NELEM+K3*(IELEM+1)+K2) + INW1=(IL/2)*L4+ABS(KNW1) + INX1=(IL/2)*L4+ABS(KNX1) + INY1=(IL/2)*L4+ABS(KNY1) + IF(KNW1.NE.0) THEN + DO 90 IL2=1,NLF-1,2 + IF(IL2.EQ.IL) GO TO 90 + ZMARS=PNMAR2(NZMAR,IL2,IL) + INW2=(IL2/2)*L4+ABS(KNW1) + IF((K2.EQ.1).AND.(K4.EQ.0)) THEN + FUNKNO(INW1)=FUNKNO(INW1)+0.5*FACT*QFR(NUM,1)*ZMARS* + 1 FUNKNO(INW2) + ELSE IF((K2.EQ.IELEM+1).AND.(K4.EQ.1)) THEN + FUNKNO(INW1)=FUNKNO(INW1)+0.5*FACT*QFR(NUM,2)*ZMARS* + 1 FUNKNO(INW2) + ENDIF + 90 CONTINUE + ENDIF + IF(KNX1.NE.0) THEN + DO 100 IL2=1,NLF-1,2 + IF(IL2.EQ.IL) GO TO 100 + ZMARS=PNMAR2(NZMAR,IL2,IL) + INX2=(IL2/2)*L4+ABS(KNX1) + IF((K2.EQ.1).AND.(K4.EQ.0)) THEN + FUNKNO(INX1)=FUNKNO(INX1)+0.5*FACT*QFR(NUM,3)*ZMARS* + 1 FUNKNO(INX2) + ELSE IF((K2.EQ.IELEM+1).AND.(K4.EQ.1)) THEN + FUNKNO(INX1)=FUNKNO(INX1)+0.5*FACT*QFR(NUM,4)*ZMARS* + 1 FUNKNO(INX2) + ENDIF + 100 CONTINUE + ENDIF + IF(KNY1.NE.0) THEN + DO 110 IL2=1,NLF-1,2 + IF(IL2.EQ.IL) GO TO 110 + ZMARS=PNMAR2(NZMAR,IL2,IL) + INY2=(IL2/2)*L4+ABS(KNY1) + IF((K2.EQ.1).AND.(K4.EQ.0)) THEN + FUNKNO(INY1)=FUNKNO(INY1)+0.5*FACT*QFR(NUM,5)*ZMARS* + 1 FUNKNO(INY2) + ELSE IF((K2.EQ.IELEM+1).AND.(K4.EQ.1)) THEN + FUNKNO(INY1)=FUNKNO(INY1)+0.5*FACT*QFR(NUM,6)*ZMARS* + 1 FUNKNO(INY2) + ENDIF + 110 CONTINUE + ENDIF + IF(IL.LE.NLF-3) THEN + DO 130 K1=0,IELEM-1 + IF(V(K2,K1+1).EQ.0.0) GO TO 130 + IF(K4.EQ.0) THEN + SSS=(-1.0)**K1 + JND1=((IL+2)/2)*L4+KN(NUM,1)+K3*IELEM+K1 + JND2=((IL+2)/2)*L4+KN(NUM,2)+K3*IELEM+K1 + JND3=((IL+2)/2)*L4+KN(NUM,3)+K3*IELEM+K1 + ELSE + SSS=1.0 + JND1=((IL+2)/2)*L4+KN(NUM,2)+K1*IELEM+K3 + JND2=((IL+2)/2)*L4+KN(NUM,3)+K1*IELEM+K3 + JND3=((IL+2)/2)*L4+KN(NUM,4)+K1*IELEM+K3 + ENDIF + IF(KNW1.NE.0) THEN + SG=REAL(SIGN(1,KNW1)) + FUNKNO(INW1)=FUNKNO(INW1)-SG*SSS*REAL(IL+1)*SIDE* + 1 V(K2,K1+1)*FUNKNO(JND1) + ENDIF + IF(KNX1.NE.0) THEN + SG=REAL(SIGN(1,KNX1)) + FUNKNO(INX1)=FUNKNO(INX1)-SG*SSS*REAL(IL+1)*SIDE* + 1 V(K2,K1+1)*FUNKNO(JND2) + ENDIF + IF(KNY1.NE.0) THEN + SG=REAL(SIGN(1,KNY1)) + FUNKNO(INY1)=FUNKNO(INY1)-SG*SSS*REAL(IL+1)*SIDE* + 1 V(K2,K1+1)*FUNKNO(JND3) + ENDIF + 130 CONTINUE + ENDIF + 140 CONTINUE + 141 CONTINUE + 142 CONTINUE + ENDIF + 150 CONTINUE + IF(MOD(IL,2).EQ.1) THEN + CALL ALLDLS(L4,MU,SYS((IL/2)*MUMAX+1),FUNKNO((IL/2)*L4+1)) + ENDIF + 160 CONTINUE + 170 CONTINUE + RETURN + END diff --git a/Trivac/src/PNFH3E.f b/Trivac/src/PNFH3E.f new file mode 100755 index 0000000..622d895 --- /dev/null +++ b/Trivac/src/PNFH3E.f @@ -0,0 +1,384 @@ +*DECK PNFH3E + SUBROUTINE PNFH3E (IL,NBMIX,NBLOS,IELEM,ICOL,NLF,NVD,NAN,L4,LL4F, + 1 MAT,SIGTI,SIDE,ZZ,FRZ,QFR,IPERT,KN,LC,R,V,SUNKNO,FUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform a one-group SPN flux iteration in hexagonal 3D geometry. +* Raviart-Thomas-Schneider method in hexagonal geometry. +* +*Copyright: +* Copyright (C) 2009 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IL current Legendre order. +* NBMIX number of mixtures. +* NBLOS number of lozenges per direction, taking into account +* mesh-splitting. +* IELEM degree of the Lagrangian finite elements: =1 (linear); +* =2 (parabolic); =3 (cubic); =4 (quartic). +* ICOL type of quadrature: =1 (analytical integration); +* =2 (Gauss-Lobatto); =3 (Gauss-Legendre). +* NLF number of Legendre orders for the flux (even number). +* NVD type of void boundary condition if NLF>0 and ICOL=3. +* NAN number of Legendre orders for the cross sections. +* L4 number of unknowns per energy group and per set of two +* Legendre orders. +* LL4F number of flux components. +* MAT index-number of the mixture type assigned to each volume. +* SIGTI inverse macroscopic cross sections ordered by mixture. +* SIGTI(:,NAN) generally contains the inverse total cross +* section only. +* SIDE side of an hexagon. +* ZZ Z-directed mesh spacings. +* FRZ volume fractions for the axial SYME boundary condition. +* QFR element-ordered boundary conditions. +* IPERT mixture permutation index. +* KN ADI permutation indices for the volumes and currents. +* LC order of the unit matrices. +* R unit Cartesian mass matrix. +* V unit nodal coupling matrix. +* SUNKNO sources. +* FUNKNO initial fluxes. +* +*Parameters: output +* FUNKNO right-hand-side of the linear system. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IL,NBMIX,NBLOS,IELEM,ICOL,NLF,NVD,NAN,L4,LL4F, + 1 MAT(3,NBLOS),IPERT(NBLOS),KN(NBLOS,3+6*(IELEM+2)*IELEM**2),LC + REAL SIGTI(NBMIX,NAN),SIDE,ZZ(3,NBLOS),FRZ(NBLOS),QFR(NBLOS,8), + 1 R(LC,LC),V(LC,LC-1),SUNKNO(L4*NLF/2),FUNKNO(L4*NLF/2) +*---- +* LOCAL VARIABLES +*---- + REAL QQ(5,5) + DOUBLE PRECISION FFF,TTTT,UUUU,VOL0,GARSI,FACT,VAR1 +* + IF(ICOL.EQ.3) THEN + IF(NVD.EQ.0) THEN + NZMAR=NLF+1 + ELSE IF(NVD.EQ.1) THEN + NZMAR=NLF + ELSE IF(NVD.EQ.2) THEN + NZMAR=65 + ENDIF + ELSE + NZMAR=65 + ENDIF + DO 16 I0=1,IELEM + DO 15 J0=1,IELEM + FFF=0.0D0 + DO 10 K0=2,IELEM + FFF=FFF+V(K0,I0)*V(K0,J0)/R(K0,K0) + 10 CONTINUE + IF(ABS(FFF).LE.1.0E-6) FFF=0.0D0 + QQ(I0,J0)=REAL(FFF) + 15 CONTINUE + 16 CONTINUE + JOFF=(IL/2)*L4 + FACT=REAL(2*IL+1) + IF(MOD(IL,2).EQ.0) THEN + DO 20 I=1,L4 + FUNKNO(JOFF+I)=SUNKNO(JOFF+I) + 20 CONTINUE + ENDIF +*---- +* COMPUTE THE SOLUTION AT ORDER IL. +*---- + NELEH=(IELEM+1)*IELEM**2 + TTTT=0.5D0*SQRT(3.D00)*SIDE*SIDE + NUM=0 + DO 150 KEL=1,NBLOS + IF(IPERT(KEL).EQ.0) GO TO 150 + NUM=NUM+1 + DZ=ZZ(1,IPERT(KEL)) + VOL0=TTTT*DZ*FRZ(KEL) + UUUU=SIDE*DZ*FRZ(KEL) + IF(MOD(IL,2).EQ.0) THEN +* EVEN PARITY EQUATION + IF(IL.GE.2) THEN + DO 34 K5=0,1 ! TWO LOZENGES PER HEXAGON + DO 33 K4=0,IELEM-1 + DO 32 K3=0,IELEM-1 + DO 31 K2=1,IELEM+1 + KNW1=KN(NUM,3+K5*NELEH+(K4*IELEM+K3)*(IELEM+1)+K2) + KNX1=KN(NUM,3+(K5+2)*NELEH+(K4*IELEM+K3)*(IELEM+1)+K2) + KNY1=KN(NUM,3+(K5+4)*NELEH+(K4*IELEM+K3)*(IELEM+1)+K2) + INW1=JOFF+LL4F+ABS(KNW1) + INX1=JOFF+LL4F+ABS(KNX1) + INY1=JOFF+LL4F+ABS(KNY1) + DO 30 K1=0,IELEM-1 + IF(V(K2,K1+1).EQ.0.0) GO TO 30 + IF(K5.EQ.0) THEN + SSS=(-1.0)**K1 + JND1=JOFF+(((NUM-1)*IELEM+K4)*IELEM+K3)*IELEM+K1+1 + JND2=JOFF+(((KN(NUM,1)-1)*IELEM+K4)*IELEM+K3)*IELEM+K1+1 + JND3=JOFF+(((KN(NUM,2)-1)*IELEM+K4)*IELEM+K3)*IELEM+K1+1 + ELSE + SSS=1.0 + JND1=JOFF+(((KN(NUM,1)-1)*IELEM+K4)*IELEM+K1)*IELEM+K3+1 + JND2=JOFF+(((KN(NUM,2)-1)*IELEM+K4)*IELEM+K1)*IELEM+K3+1 + JND3=JOFF+(((KN(NUM,3)-1)*IELEM+K4)*IELEM+K1)*IELEM+K3+1 + ENDIF + VAR1=SSS*REAL(IL)*UUUU*V(K2,K1+1) + IF(KNW1.NE.0) THEN + SG=REAL(SIGN(1,KNW1)) + FUNKNO(JND1)=FUNKNO(JND1)-SG*REAL(VAR1)*FUNKNO(INW1-L4) + ENDIF + IF(KNX1.NE.0) THEN + SG=REAL(SIGN(1,KNX1)) + FUNKNO(JND2)=FUNKNO(JND2)-SG*REAL(VAR1)*FUNKNO(INX1-L4) + ENDIF + IF(KNY1.NE.0) THEN + SG=REAL(SIGN(1,KNY1)) + FUNKNO(JND3)=FUNKNO(JND3)-SG*REAL(VAR1)*FUNKNO(INY1-L4) + ENDIF + 30 CONTINUE + 31 CONTINUE + 32 CONTINUE + 33 CONTINUE + 34 CONTINUE + DO 43 K5=0,2 ! THREE LOZENGES PER HEXAGON + DO 42 K2=0,IELEM-1 + DO 41 K1=0,IELEM-1 + KNZ1=KN(NUM,3+6*NELEH+2*K5*IELEM**2+K2*IELEM+K1+1) + KNZ2=KN(NUM,3+6*NELEH+(2*K5+1)*IELEM**2+K2*IELEM+K1+1) + INZ1=JOFF+LL4F+ABS(KNZ1) + INZ2=JOFF+LL4F+ABS(KNZ2) + DO 40 K3=0,IELEM-1 + IF(K5.EQ.0) THEN + JND1=JOFF+((((NUM-1)*IELEM)+K3)*IELEM+K2)*IELEM+K1+1 + ELSE + JND1=JOFF+(((KN(NUM,K5)-1)*IELEM+K3)*IELEM+K2)*IELEM+K1+1 + ENDIF + IF(KNZ1.NE.0) THEN + SG=REAL(SIGN(1,KNZ1)) + VAR1=SG*(VOL0/DZ)*REAL(IL)*V(1,K3+1)*FUNKNO(INZ1-L4) + FUNKNO(JND1)=FUNKNO(JND1)-REAL(VAR1) + ENDIF + IF(KNZ2.NE.0) THEN + SG=REAL(SIGN(1,KNZ2)) + VAR1=SG*(VOL0/DZ)*REAL(IL)*V(IELEM+1,K3+1)* + 1 FUNKNO(INZ2-L4) + FUNKNO(JND1)=FUNKNO(JND1)-REAL(VAR1) + ENDIF + 40 CONTINUE + 41 CONTINUE + 42 CONTINUE + 43 CONTINUE + ENDIF + ELSE +* PARTIAL INVERSION OF THE ODD PARITY EQUATION. MODIFICATION +* OF THE EVEN PARITY EQUATION. + IBM=MAT(1,IPERT(KEL)) + IF(IBM.EQ.0) GO TO 150 + IF(IELEM.GT.1) THEN + DO 52 K3=0,IELEM-1 + DO 51 K2=0,IELEM-1 + DO 50 K1=0,IELEM-1 + IF(QQ(K3+1,K3+1).EQ.0.0) GO TO 50 + JND1=JOFF+(NUM-1)*IELEM**3+K3*IELEM**2+K2*IELEM+K1+1 + JND2=JOFF+(KN(NUM,1)-1)*IELEM**3+K3*IELEM**2+K2*IELEM+K1+1 + JND3=JOFF+(KN(NUM,2)-1)*IELEM**3+K3*IELEM**2+K2*IELEM+K1+1 + IF(IL.GE.3) THEN + GARSI=SIGTI(IBM,MIN(IL-1,NAN)) + KND1=JND1-L4 + KND2=JND2-L4 + KND3=JND3-L4 + VAR1=(REAL(IL-1)*REAL(IL-2))*VOL0*QQ(K3+1,K3+1)*GARSI + 1 /(REAL(2*IL-3)*DZ*DZ) + FUNKNO(JND1)=FUNKNO(JND1)-REAL(VAR1)*FUNKNO(KND1) + FUNKNO(JND2)=FUNKNO(JND2)-REAL(VAR1)*FUNKNO(KND2) + FUNKNO(JND3)=FUNKNO(JND3)-REAL(VAR1)*FUNKNO(KND3) + ENDIF + IF(IL.LE.NLF-3) THEN + GARSI=SIGTI(IBM,MIN(IL+1,NAN)) + KND1=JND1+L4 + KND2=JND2+L4 + KND3=JND3+L4 + VAR1=(REAL(IL)*REAL(IL+1))*VOL0*QQ(K3+1,K3+1)*GARSI + 1 /(FACT*DZ*DZ) + FUNKNO(JND1)=FUNKNO(JND1)-REAL(VAR1)*FUNKNO(KND1) + FUNKNO(JND2)=FUNKNO(JND2)-REAL(VAR1)*FUNKNO(KND2) + FUNKNO(JND3)=FUNKNO(JND3)-REAL(VAR1)*FUNKNO(KND3) + ENDIF + 50 CONTINUE + 51 CONTINUE + 52 CONTINUE + ENDIF +* +* ODD PARITY EQUATION + DO 93 K5=0,1 ! TWO LOZENGES PER HEXAGON + DO 92 K4=0,IELEM-1 + DO 91 K3=0,IELEM-1 + DO 90 K2=1,IELEM+1 + KNW1=KN(NUM,3+K5*NELEH+(K4*IELEM+K3)*(IELEM+1)+K2) + KNX1=KN(NUM,3+(K5+2)*NELEH+(K4*IELEM+K3)*(IELEM+1)+K2) + KNY1=KN(NUM,3+(K5+4)*NELEH+(K4*IELEM+K3)*(IELEM+1)+K2) + INW1=JOFF+LL4F+ABS(KNW1) + INX1=JOFF+LL4F+ABS(KNX1) + INY1=JOFF+LL4F+ABS(KNY1) + IF(KNW1.NE.0) THEN + DO 60 IL2=1,NLF-1,2 + IF(IL2.EQ.IL) GO TO 60 + ZMARS=PNMAR2(NZMAR,IL2,IL) + INW2=(IL2/2)*L4+LL4F+ABS(KNW1) + IF((K2.EQ.1).AND.(K5.EQ.0)) THEN + VAR1=0.5*FACT*QFR(NUM,1)*ZMARS*FUNKNO(INW2) + FUNKNO(INW1)=FUNKNO(INW1)+REAL(VAR1) + ELSE IF((K2.EQ.IELEM+1).AND.(K5.EQ.1)) THEN + VAR1=0.5*FACT*QFR(NUM,2)*ZMARS*FUNKNO(INW2) + FUNKNO(INW1)=FUNKNO(INW1)+REAL(VAR1) + ENDIF + 60 CONTINUE + ENDIF + IF(KNX1.NE.0) THEN + DO 70 IL2=1,NLF-1,2 + IF(IL2.EQ.IL) GO TO 70 + ZMARS=PNMAR2(NZMAR,IL2,IL) + INX2=(IL2/2)*L4+LL4F+ABS(KNX1) + IF((K2.EQ.1).AND.(K5.EQ.0)) THEN + VAR1=0.5*FACT*QFR(NUM,3)*ZMARS*FUNKNO(INX2) + FUNKNO(INX1)=FUNKNO(INX1)+REAL(VAR1) + ELSE IF((K2.EQ.IELEM+1).AND.(K5.EQ.1)) THEN + VAR1=0.5*FACT*QFR(NUM,4)*ZMARS*FUNKNO(INX2) + FUNKNO(INX1)=FUNKNO(INX1)+REAL(VAR1) + ENDIF + 70 CONTINUE + ENDIF + IF(KNY1.NE.0) THEN + DO 80 IL2=1,NLF-1,2 + IF(IL2.EQ.IL) GO TO 80 + ZMARS=PNMAR2(NZMAR,IL2,IL) + INY2=(IL2/2)*L4+LL4F+ABS(KNY1) + IF((K2.EQ.1).AND.(K5.EQ.0)) THEN + VAR1=0.5*FACT*QFR(NUM,5)*ZMARS*FUNKNO(INY2) + FUNKNO(INY1)=FUNKNO(INY1)+REAL(VAR1) + ELSE IF((K2.EQ.IELEM+1).AND.(K5.EQ.1)) THEN + VAR1=0.5*FACT*QFR(NUM,6)*ZMARS*FUNKNO(INY2) + FUNKNO(INY1)=FUNKNO(INY1)+REAL(VAR1) + ENDIF + 80 CONTINUE + ENDIF + 90 CONTINUE + 91 CONTINUE + 92 CONTINUE + 93 CONTINUE + DO 122 K5=0,2 ! THREE LOZENGES PER HEXAGON + DO 121 K2=0,IELEM-1 + DO 120 K1=0,IELEM-1 + KNZ1=KN(NUM,3+6*NELEH+2*K5*IELEM**2+K2*IELEM+K1+1) + KNZ2=KN(NUM,3+6*NELEH+(2*K5+1)*IELEM**2+K2*IELEM+K1+1) + INZ1=JOFF+LL4F+ABS(KNZ1) + INZ2=JOFF+LL4F+ABS(KNZ2) + IF((QFR(NUM,7).NE.0.0).AND.(KNZ1.NE.0)) THEN +* ZINF SIDE. + DO 100 IL2=1,NLF-1,2 + IF(IL2.EQ.IL) GO TO 100 + ZMARS=PNMAR2(NZMAR,IL2,IL) + INDL=(IL2/2)*L4+LL4F+ABS(KNZ1) + VAR1=0.5*FACT*QFR(NUM,7)*ZMARS*FUNKNO(INDL) + FUNKNO(INZ1)=FUNKNO(INZ1)+REAL(VAR1) + 100 CONTINUE + ENDIF + IF((QFR(NUM,8).NE.0.0).AND.(KNZ2.NE.0)) THEN +* ZSUP SIDE. + DO 110 IL2=1,NLF-1,2 + IF(IL2.EQ.IL) GO TO 110 + ZMARS=PNMAR2(NZMAR,IL2,IL) + INDL=(IL2/2)*L4+LL4F+ABS(KNZ2) + VAR1=0.5*FACT*QFR(NUM,8)*ZMARS*FUNKNO(INDL) + FUNKNO(INZ2)=FUNKNO(INZ2)+REAL(VAR1) + 110 CONTINUE + ENDIF + 120 CONTINUE + 121 CONTINUE + 122 CONTINUE +* + IF(IL.LE.NLF-3) THEN + DO 134 K5=0,1 ! TWO LOZENGES PER HEXAGON + DO 133 K4=0,IELEM-1 + DO 132 K3=0,IELEM-1 + DO 131 K2=1,IELEM+1 + KNW1=KN(NUM,3+K5*NELEH+(K4*IELEM+K3)*(IELEM+1)+K2) + KNX1=KN(NUM,3+(K5+2)*NELEH+(K4*IELEM+K3)*(IELEM+1)+K2) + KNY1=KN(NUM,3+(K5+4)*NELEH+(K4*IELEM+K3)*(IELEM+1)+K2) + INW1=JOFF+LL4F+ABS(KNW1) + INX1=JOFF+LL4F+ABS(KNX1) + INY1=JOFF+LL4F+ABS(KNY1) + DO 130 K1=0,IELEM-1 + IF(V(K2,K1+1).EQ.0.0) GO TO 130 + IF(K5.EQ.0) THEN + SSS=(-1.0)**K1 + JND1=JOFF+(((NUM-1)*IELEM+K4)*IELEM+K3)*IELEM+K1+1 + JND2=JOFF+(((KN(NUM,1)-1)*IELEM+K4)*IELEM+K3)*IELEM+K1+1 + JND3=JOFF+(((KN(NUM,2)-1)*IELEM+K4)*IELEM+K3)*IELEM+K1+1 + ELSE + SSS=1.0 + JND1=JOFF+(((KN(NUM,1)-1)*IELEM+K4)*IELEM+K1)*IELEM+K3+1 + JND2=JOFF+(((KN(NUM,2)-1)*IELEM+K4)*IELEM+K1)*IELEM+K3+1 + JND3=JOFF+(((KN(NUM,3)-1)*IELEM+K4)*IELEM+K1)*IELEM+K3+1 + ENDIF + VAR1=SSS*REAL(IL+1)*UUUU*V(K2,K1+1) + IF(KNW1.NE.0) THEN + SG=REAL(SIGN(1,KNW1)) + FUNKNO(INW1)=FUNKNO(INW1)-SG*REAL(VAR1)*FUNKNO(JND1+L4) + ENDIF + IF(KNX1.NE.0) THEN + SG=REAL(SIGN(1,KNX1)) + FUNKNO(INX1)=FUNKNO(INX1)-SG*REAL(VAR1)*FUNKNO(JND2+L4) + ENDIF + IF(KNY1.NE.0) THEN + SG=REAL(SIGN(1,KNY1)) + FUNKNO(INY1)=FUNKNO(INY1)-SG*REAL(VAR1)*FUNKNO(JND3+L4) + ENDIF + 130 CONTINUE + 131 CONTINUE + 132 CONTINUE + 133 CONTINUE + 134 CONTINUE + DO 143 K5=0,2 ! THREE LOZENGES PER HEXAGON + DO 142 K2=0,IELEM-1 + DO 141 K1=0,IELEM-1 + KNZ1=KN(NUM,3+6*NELEH+2*K5*IELEM**2+K2*IELEM+K1+1) + KNZ2=KN(NUM,3+6*NELEH+(2*K5+1)*IELEM**2+K2*IELEM+K1+1) + INZ1=JOFF+LL4F+ABS(KNZ1) + INZ2=JOFF+LL4F+ABS(KNZ2) + DO 140 K3=0,IELEM-1 + IF(K5.EQ.0) THEN + JND1=JOFF+((((NUM-1)*IELEM)+K3)*IELEM+K2)*IELEM+K1+1 + ELSE + JND1=JOFF+(((KN(NUM,K5)-1)*IELEM+K3)*IELEM+K2)*IELEM+K1+1 + ENDIF + IF(KNZ1.NE.0) THEN + SG=REAL(SIGN(1,KNZ1)) + VAR1=SG*(VOL0/DZ)*REAL(IL+1)*V(1,K3+1)*FUNKNO(JND1+L4) + FUNKNO(INZ1)=FUNKNO(INZ1)-REAL(VAR1) + ENDIF + IF(KNZ2.NE.0) THEN + SG=REAL(SIGN(1,KNZ2)) + VAR1=SG*(VOL0/DZ)*REAL(IL+1)*V(IELEM+1,K3+1)* + 1 FUNKNO(JND1+L4) + FUNKNO(INZ2)=FUNKNO(INZ2)-REAL(VAR1) + ENDIF + 140 CONTINUE + 141 CONTINUE + 142 CONTINUE + 143 CONTINUE + ENDIF + ENDIF + 150 CONTINUE + RETURN + END diff --git a/Trivac/src/PNFL2E.f b/Trivac/src/PNFL2E.f new file mode 100755 index 0000000..2527ef4 --- /dev/null +++ b/Trivac/src/PNFL2E.f @@ -0,0 +1,264 @@ +*DECK PNFL2E + SUBROUTINE PNFL2E (NREG,IELEM,ICOL,XX,YY,MAT,VOL,NBMIX,NLF,NVD, + 1 NAN,SIGTI,L4,KN,QFR,MU,IIMAX,LC,R,V,SYS,SUNKNO,FUNKNO,NADI) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform a one-group SPN flux iteration in Cartesian 2D geometry. +* Raviart-Thomas method in Cartesian geometry. +* +*Copyright: +* Copyright (C) 2004 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NREG total number of regions. +* IELEM degree of the Lagrangian finite elements: =1 (linear); +* =2 (parabolic); =3 (cubic); =4 (quartic). +* ICOL type of quadrature: =1 (analytical integration); +* =2 (Gauss-Lobatto); =3 (Gauss-Legendre). +* XX X-directed mesh spacings. +* YY Y-directed mesh spacings. +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* NBMIX number of mixtures. +* NLF number of Legendre orders for the flux (even number). +* NVD type of void boundary condition if NLF>0 and ICOL=3. +* NAN number of Legendre orders for the cross sections. +* SIGTI inverse macroscopic cross sections ordered by mixture. +* SIGTI(:,NAN) generally contains the inverse total cross +* section only. +* L4 number of unknowns per energy group and per set of two +* Legendre orders. +* KN element-ordered unknown list. +* QFR element-ordered boundary conditions. +* MU profiled storage indices for matrix SYS. +* IIMAX dimension of SYS. +* LC order of the unit matrices. +* R unit Cartesian mass matrix. +* V unit nodal coupling matrix. +* SYS LU factors of the system matrix. +* SUNKNO sources. +* FUNKNO initial fluxes. +* NADI number of inner ADI iterations. +* +*Parameters: output +* FUNKNO fluxes. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NREG,IELEM,ICOL,MAT(NREG),NBMIX,NLF,NVD,NAN,L4,KN(5*NREG), + 1 MU(L4),IIMAX,LC,NADI + REAL XX(NREG),YY(NREG),VOL(NREG),SIGTI(NBMIX,NAN),QFR(4*NREG), + 1 R(LC,LC),V(LC,LC-1),SYS(IIMAX),SUNKNO(L4*NLF/2),FUNKNO(L4*NLF/2) +*---- +* LOCAL VARIABLES +*---- + REAL QQ(5,5) +* + IF(ICOL.EQ.3) THEN + IF(NVD.EQ.0) THEN + NZMAR=NLF+1 + ELSE IF(NVD.EQ.1) THEN + NZMAR=NLF + ELSE IF(NVD.EQ.2) THEN + NZMAR=65 + ENDIF + ELSE + NZMAR=65 + ENDIF + DO 12 I0=1,IELEM + DO 11 J0=1,IELEM + QQ(I0,J0)=0.0 + DO 10 K0=2,IELEM + QQ(I0,J0)=QQ(I0,J0)+V(K0,I0)*V(K0,J0)/R(K0,K0) + 10 CONTINUE + 11 CONTINUE + 12 CONTINUE + MUMAX=MU(L4) + DO 170 IADI=1,MAX(1,NADI) + DO 160 IL=0,NLF-1 + FACT=REAL(2*IL+1) + IF(MOD(IL,2).EQ.0) THEN + DO 20 I=1,L4 + FUNKNO((IL/2)*L4+I)=SUNKNO((IL/2)*L4+I) + 20 CONTINUE + ENDIF +*---- +* COMPUTE THE SOLUTION AT ORDER IL. +*---- + NUM1=0 + NUM2=0 + DO 150 K=1,NREG + IBM=MAT(K) + IF(IBM.EQ.0) GO TO 150 + VOL0=VOL(K) + IF(MOD(IL,2).EQ.0) THEN +* EVEN PARITY EQUATION + IF(IL.GE.2) THEN + DO 35 I0=1,IELEM + IND1=((IL-2)/2)*L4+ABS(KN(NUM1+2))+I0-1 + IND2=((IL-2)/2)*L4+ABS(KN(NUM1+3))+I0-1 + IND3=((IL-2)/2)*L4+ABS(KN(NUM1+4))+I0-1 + IND4=((IL-2)/2)*L4+ABS(KN(NUM1+5))+I0-1 + DO 30 J0=1,IELEM + JND1=(IL/2)*L4+KN(NUM1+1)+(I0-1)*IELEM+J0-1 + IF(KN(NUM1+2).NE.0) THEN + SG=REAL(SIGN(1,KN(NUM1+2))) + FUNKNO(JND1)=FUNKNO(JND1)-SG*REAL(IL)*VOL0*V(1,J0)* + 1 FUNKNO(IND1)/XX(K) + ENDIF + IF(KN(NUM1+3).NE.0) THEN + SG=REAL(SIGN(1,KN(NUM1+3))) + FUNKNO(JND1)=FUNKNO(JND1)-SG*REAL(IL)*VOL0*V(IELEM+1,J0)* + 1 FUNKNO(IND2)/XX(K) + ENDIF + JND1=(IL/2)*L4+KN(NUM1+1)+(J0-1)*IELEM+I0-1 + IF(KN(NUM1+4).NE.0) THEN + SG=REAL(SIGN(1,KN(NUM1+4))) + FUNKNO(JND1)=FUNKNO(JND1)-SG*REAL(IL)*VOL0*V(1,J0)* + 1 FUNKNO(IND3)/YY(K) + ENDIF + IF(KN(NUM1+5).NE.0) THEN + SG=REAL(SIGN(1,KN(NUM1+5))) + FUNKNO(JND1)=FUNKNO(JND1)-SG*REAL(IL)*VOL0*V(IELEM+1,J0)* + 1 FUNKNO(IND4)/YY(K) + ENDIF + 30 CONTINUE + 35 CONTINUE + ENDIF + ELSE + DO 140 I0=1,IELEM +* PARTIAL INVERSION OF THE ODD PARITY EQUATION. MODIFICATION +* OF THE EVEN PARITY EQUATION. + IF((IL.GE.3).AND.(IELEM.GT.1)) THEN + GARSI=SIGTI(IBM,MIN(IL-1,NAN)) + DO 65 J0=1,IELEM + DO 50 K0=1,IELEM + IF(QQ(J0,K0).EQ.0.0) GO TO 50 + JND1=(IL/2)*L4+KN(NUM1+1)+(I0-1)*IELEM+J0-1 + KND1=((IL-2)/2)*L4+KN(NUM1+1)+(I0-1)*IELEM+K0-1 + FUNKNO(JND1)=FUNKNO(JND1)-(REAL(IL-1)*REAL(IL-2))*VOL0* + 1 QQ(J0,K0)*GARSI*FUNKNO(KND1)/(REAL(2*IL-3)*XX(K)*XX(K)) + 50 CONTINUE + DO 60 K0=1,IELEM + IF(QQ(J0,K0).EQ.0.0) GO TO 60 + JND1=(IL/2)*L4+KN(NUM1+1)+(J0-1)*IELEM+I0-1 + KND1=((IL-2)/2)*L4+KN(NUM1+1)+(K0-1)*IELEM+I0-1 + FUNKNO(JND1)=FUNKNO(JND1)-(REAL(IL-1)*REAL(IL-2))*VOL0* + 1 QQ(J0,K0)*GARSI*FUNKNO(KND1)/(REAL(2*IL-3)*YY(K)*YY(K)) + 60 CONTINUE + 65 CONTINUE + ENDIF + IF((IL.LE.NLF-3).AND.(IELEM.GT.1)) THEN + GARSI=SIGTI(IBM,MIN(IL+1,NAN)) + DO 85 J0=1,IELEM + DO 70 K0=1,IELEM + IF(QQ(J0,K0).EQ.0.0) GO TO 70 + JND1=(IL/2)*L4+KN(NUM1+1)+(I0-1)*IELEM+J0-1 + KND1=((IL+2)/2)*L4+KN(NUM1+1)+(I0-1)*IELEM+K0-1 + FUNKNO(JND1)=FUNKNO(JND1)-(REAL(IL)*REAL(IL+1))*VOL0* + 1 QQ(J0,K0)*GARSI*FUNKNO(KND1)/(FACT*XX(K)*XX(K)) + 70 CONTINUE + DO 80 K0=1,IELEM + IF(QQ(J0,K0).EQ.0.0) GO TO 80 + JND1=(IL/2)*L4+KN(NUM1+1)+(J0-1)*IELEM+I0-1 + KND1=((IL+2)/2)*L4+KN(NUM1+1)+(K0-1)*IELEM+I0-1 + FUNKNO(JND1)=FUNKNO(JND1)-(REAL(IL)*REAL(IL+1))*VOL0* + 1 QQ(J0,K0)*GARSI*FUNKNO(KND1)/(FACT*YY(K)*YY(K)) + 80 CONTINUE + 85 CONTINUE + ENDIF +* +* ODD PARITY EQUATION + IND1=(IL/2)*L4+ABS(KN(NUM1+2))+I0-1 + IND2=(IL/2)*L4+ABS(KN(NUM1+3))+I0-1 + IND3=(IL/2)*L4+ABS(KN(NUM1+4))+I0-1 + IND4=(IL/2)*L4+ABS(KN(NUM1+5))+I0-1 + IF((QFR(NUM2+1).NE.0.0).AND.(KN(NUM1+2).NE.0)) THEN +* XINF SIDE. + DO 90 IL2=1,NLF-1,2 + IF(IL2.EQ.IL) GO TO 90 + ZMARS=PNMAR2(NZMAR,IL2,IL) + IND5=(IL2/2)*L4+ABS(KN(NUM1+2))+I0-1 + FUNKNO(IND1)=FUNKNO(IND1)+0.5*FACT*QFR(NUM2+1)*ZMARS* + 1 FUNKNO(IND5) + 90 CONTINUE + ENDIF + IF((QFR(NUM2+2).NE.0.0).AND.(KN(NUM1+3).NE.0)) THEN +* XSUP SIDE. + DO 100 IL2=1,NLF-1,2 + IF(IL2.EQ.IL) GO TO 100 + ZMARS=PNMAR2(NZMAR,IL2,IL) + IND5=(IL2/2)*L4+ABS(KN(NUM1+3))+I0-1 + FUNKNO(IND2)=FUNKNO(IND2)+0.5*FACT*QFR(NUM2+2)*ZMARS* + 1 FUNKNO(IND5) + 100 CONTINUE + ENDIF + IF((QFR(NUM2+3).NE.0.0).AND.(KN(NUM1+4).NE.0)) THEN +* YINF SIDE. + DO 110 IL2=1,NLF-1,2 + IF(IL2.EQ.IL) GO TO 110 + ZMARS=PNMAR2(NZMAR,IL2,IL) + IND5=(IL2/2)*L4+ABS(KN(NUM1+4))+I0-1 + FUNKNO(IND3)=FUNKNO(IND3)+0.5*FACT*QFR(NUM2+3)*ZMARS* + 1 FUNKNO(IND5) + 110 CONTINUE + ENDIF + IF((QFR(NUM2+4).NE.0.0).AND.(KN(NUM1+5).NE.0)) THEN +* YSUP SIDE. + DO 120 IL2=1,NLF-1,2 + IF(IL2.EQ.IL) GO TO 120 + ZMARS=PNMAR2(NZMAR,IL2,IL) + IND5=(IL2/2)*L4+ABS(KN(NUM1+5))+I0-1 + FUNKNO(IND4)=FUNKNO(IND4)+0.5*FACT*QFR(NUM2+4)*ZMARS* + 1 FUNKNO(IND5) + 120 CONTINUE + ENDIF + IF(IL.LE.NLF-3) THEN + DO 130 J0=1,IELEM + JND1=((IL+2)/2)*L4+KN(NUM1+1)+(I0-1)*IELEM+J0-1 + IF(KN(NUM1+2).NE.0) THEN + SG=REAL(SIGN(1,KN(NUM1+2))) + FUNKNO(IND1)=FUNKNO(IND1)-SG*REAL(IL+1)*VOL0*V(1,J0)* + 1 FUNKNO(JND1)/XX(K) + ENDIF + IF(KN(NUM1+3).NE.0) THEN + SG=REAL(SIGN(1,KN(NUM1+3))) + FUNKNO(IND2)=FUNKNO(IND2)-SG*REAL(IL+1)*VOL0* + 1 V(IELEM+1,J0)*FUNKNO(JND1)/XX(K) + ENDIF + JND1=((IL+2)/2)*L4+KN(NUM1+1)+(J0-1)*IELEM+I0-1 + IF(KN(NUM1+4).NE.0) THEN + SG=REAL(SIGN(1,KN(NUM1+4))) + FUNKNO(IND3)=FUNKNO(IND3)-SG*REAL(IL+1)*VOL0*V(1,J0)* + 1 FUNKNO(JND1)/YY(K) + ENDIF + IF(KN(NUM1+5).NE.0) THEN + SG=REAL(SIGN(1,KN(NUM1+5))) + FUNKNO(IND4)=FUNKNO(IND4)-SG*REAL(IL+1)*VOL0* + 1 V(IELEM+1,J0)*FUNKNO(JND1)/YY(K) + ENDIF + 130 CONTINUE + ENDIF + 140 CONTINUE + ENDIF + NUM1=NUM1+5 + NUM2=NUM2+4 + 150 CONTINUE + IF(MOD(IL,2).EQ.1) THEN + CALL ALLDLS(L4,MU,SYS((IL/2)*MUMAX+1),FUNKNO((IL/2)*L4+1)) + ENDIF + 160 CONTINUE + 170 CONTINUE + RETURN + END diff --git a/Trivac/src/PNFL3E.f b/Trivac/src/PNFL3E.f new file mode 100755 index 0000000..8b737bb --- /dev/null +++ b/Trivac/src/PNFL3E.f @@ -0,0 +1,317 @@ +*DECK PNFL3E + SUBROUTINE PNFL3E (IL,NREG,IELEM,ICOL,XX,YY,ZZ,MAT,VOL,NBMIX,NLF, + 1 NVD,NAN,SIGTI,L4,KN,QFR,LC,R,V,SUNKNO,FUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Perform a one-group SPN flux iteration in Cartesian 3D geometry. +* +*Copyright: +* Copyright (C) 2004 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IL current Legendre order. +* NREG total number of regions. +* IELEM degree of the Lagrangian finite elements: =1 (linear); +* =2 (parabolic); =3 (cubic); =4 (quartic). +* ICOL type of quadrature: =1 (analytical integration); +* =2 (Gauss-Lobatto); =3 (Gauss-Legendre). +* XX X-directed mesh spacings. +* YY Y-directed mesh spacings. +* ZZ Z-directed mesh spacings. +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* NBMIX number of mixtures. +* NLF number of Legendre orders for the flux (even number). +* NVD type of void boundary condition if NLF>0 and ICOL=3. +* NAN number of Legendre orders for the cross sections. +* SIGTI inverse macroscopic cross sections ordered by mixture. +* SIGTI(:,NAN) generally contains the inverse total cross +* section only. +* L4 number of unknowns per energy group and per set of two +* Legendre orders. +* KN element-ordered unknown list. +* QFR element-ordered boundary conditions. +* LC order of the unit matrices. +* R unit Cartesian mass matrix. +* V unit nodal coupling matrix. +* SUNKNO sources. +* FUNKNO initial fluxes. +* +*Parameters: output +* FUNKNO right-hand-side of the linear system. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IL,NREG,IELEM,ICOL,MAT(NREG),NBMIX,NLF,NVD,NAN,L4, + 1 KN(NREG*(1+6*IELEM**2)),LC + REAL XX(NREG),YY(NREG),ZZ(NREG),VOL(NREG),SIGTI(NBMIX,NAN), + 1 QFR(6*NREG),R(LC,LC),V(LC,LC-1),SUNKNO(L4*NLF/2),FUNKNO(L4*NLF/2) +*---- +* LOCAL VARIABLES +*---- + REAL QQ(5,5) +* + IF(ICOL.EQ.3) THEN + IF(NVD.EQ.0) THEN + NZMAR=NLF+1 + ELSE IF(NVD.EQ.1) THEN + NZMAR=NLF + ELSE IF(NVD.EQ.2) THEN + NZMAR=65 + ENDIF + ELSE + NZMAR=65 + ENDIF + DO 12 I0=1,IELEM + DO 11 J0=1,IELEM + QQ(I0,J0)=0.0 + DO 10 K0=2,IELEM + QQ(I0,J0)=QQ(I0,J0)+V(K0,I0)*V(K0,J0)/R(K0,K0) + 10 CONTINUE + 11 CONTINUE + 12 CONTINUE + FACT=REAL(2*IL+1) + IF(MOD(IL,2).EQ.0) THEN + DO 20 I=1,L4 + FUNKNO((IL/2)*L4+I)=SUNKNO((IL/2)*L4+I) + 20 CONTINUE + ENDIF +*---- +* COMPUTE THE SOLUTION AT ORDER IL. +*---- + NUM1=0 + NUM2=0 + DO 150 K=1,NREG + IBM=MAT(K) + IF(IBM.EQ.0) GO TO 150 + VOL0=VOL(K) + IF(MOD(IL,2).EQ.0) THEN +* EVEN PARITY EQUATION + IF(IL.GE.2) THEN + DO 32 K3=0,IELEM-1 + DO 31 K2=0,IELEM-1 + KN1=KN(NUM1+2+K3*IELEM+K2) + KN2=KN(NUM1+2+IELEM**2+K3*IELEM+K2) + KN3=KN(NUM1+2+2*IELEM**2+K3*IELEM+K2) + KN4=KN(NUM1+2+3*IELEM**2+K3*IELEM+K2) + KN5=KN(NUM1+2+4*IELEM**2+K3*IELEM+K2) + KN6=KN(NUM1+2+5*IELEM**2+K3*IELEM+K2) + IND1=((IL-2)/2)*L4+ABS(KN1) + IND2=((IL-2)/2)*L4+ABS(KN2) + IND3=((IL-2)/2)*L4+ABS(KN3) + IND4=((IL-2)/2)*L4+ABS(KN4) + IND5=((IL-2)/2)*L4+ABS(KN5) + IND6=((IL-2)/2)*L4+ABS(KN6) + DO 30 K1=0,IELEM-1 + JND1=(IL/2)*L4+KN(NUM1+1)+(K3*IELEM+K2)*IELEM+K1 + IF(KN1.NE.0) THEN + SG=REAL(SIGN(1,KN1)) + FUNKNO(JND1)=FUNKNO(JND1)-SG*REAL(IL)*VOL0*V(1,K1+1)* + 1 FUNKNO(IND1)/XX(K) + ENDIF + IF(KN2.NE.0) THEN + SG=REAL(SIGN(1,KN2)) + FUNKNO(JND1)=FUNKNO(JND1)-SG*REAL(IL)*VOL0* + 1 V(IELEM+1,K1+1)*FUNKNO(IND2)/XX(K) + ENDIF + JND1=(IL/2)*L4+KN(NUM1+1)+(K3*IELEM+K1)*IELEM+K2 + IF(KN3.NE.0) THEN + SG=REAL(SIGN(1,KN3)) + FUNKNO(JND1)=FUNKNO(JND1)-SG*REAL(IL)*VOL0*V(1,K1+1)* + 1 FUNKNO(IND3)/YY(K) + ENDIF + IF(KN4.NE.0) THEN + SG=REAL(SIGN(1,KN4)) + FUNKNO(JND1)=FUNKNO(JND1)-SG*REAL(IL)*VOL0* + 1 V(IELEM+1,K1+1)*FUNKNO(IND4)/YY(K) + ENDIF + JND1=(IL/2)*L4+KN(NUM1+1)+(K1*IELEM+K3)*IELEM+K2 + IF(KN5.NE.0) THEN + SG=REAL(SIGN(1,KN5)) + FUNKNO(JND1)=FUNKNO(JND1)-SG*REAL(IL)*VOL0*V(1,K1+1)* + 1 FUNKNO(IND5)/ZZ(K) + ENDIF + IF(KN6.NE.0) THEN + SG=REAL(SIGN(1,KN6)) + FUNKNO(JND1)=FUNKNO(JND1)-SG*REAL(IL)*VOL0* + 1 V(IELEM+1,K1+1)*FUNKNO(IND6)/ZZ(K) + ENDIF + 30 CONTINUE + 31 CONTINUE + 32 CONTINUE + ENDIF + ELSE + DO 145 K3=0,IELEM-1 + DO 140 K2=0,IELEM-1 +* PARTIAL INVERSION OF THE ODD PARITY EQUATION. MODIFICATION +* OF THE EVEN PARITY EQUATION. + IF((IL.GE.3).AND.(IELEM.GT.1)) THEN + GARSI=SIGTI(IBM,MIN(IL-1,NAN)) + DO 40 K1=0,IELEM-1 + IF(QQ(K1+1,K1+1).EQ.0.0) GO TO 40 + JND1=(IL/2)*L4+KN(NUM1+1)+(K3*IELEM+K2)*IELEM+K1 + KND1=((IL-2)/2)*L4+KN(NUM1+1)+(K3*IELEM+K2)*IELEM+K1 + FUNKNO(JND1)=FUNKNO(JND1)-(REAL(IL-1)*REAL(IL-2))*VOL0* + 1 QQ(K1+1,K1+1)*GARSI*FUNKNO(KND1)/(REAL(2*IL-3)*XX(K)*XX(K)) +* + JND1=(IL/2)*L4+KN(NUM1+1)+(K3*IELEM+K1)*IELEM+K2 + KND1=((IL-2)/2)*L4+KN(NUM1+1)+(K3*IELEM+K1)*IELEM+K2 + FUNKNO(JND1)=FUNKNO(JND1)-(REAL(IL-1)*REAL(IL-2))*VOL0* + 1 QQ(K1+1,K1+1)*GARSI*FUNKNO(KND1)/(REAL(2*IL-3)*YY(K)*YY(K)) +* + JND1=(IL/2)*L4+KN(NUM1+1)+(K1*IELEM+K3)*IELEM+K2 + KND1=((IL-2)/2)*L4+KN(NUM1+1)+(K1*IELEM+K3)*IELEM+K2 + FUNKNO(JND1)=FUNKNO(JND1)-(REAL(IL-1)*REAL(IL-2))*VOL0* + 1 QQ(K1+1,K1+1)*GARSI*FUNKNO(KND1)/(REAL(2*IL-3)*ZZ(K)*ZZ(K)) + 40 CONTINUE + ENDIF + IF((IL.LE.NLF-3).AND.(IELEM.GT.1)) THEN + GARSI=SIGTI(IBM,MIN(IL+1,NAN)) + DO 50 K1=0,IELEM-1 + IF(QQ(K1+1,K1+1).EQ.0.0) GO TO 50 + JND1=(IL/2)*L4+KN(NUM1+1)+(K3*IELEM+K2)*IELEM+K1 + KND1=((IL+2)/2)*L4+KN(NUM1+1)+(K3*IELEM+K2)*IELEM+K1 + FUNKNO(JND1)=FUNKNO(JND1)-(REAL(IL)*REAL(IL+1))*VOL0* + 1 QQ(K1+1,K1+1)*GARSI*FUNKNO(KND1)/(FACT*XX(K)*XX(K)) +* + JND1=(IL/2)*L4+KN(NUM1+1)+(K3*IELEM+K1)*IELEM+K2 + KND1=((IL+2)/2)*L4+KN(NUM1+1)+(K3*IELEM+K1)*IELEM+K2 + FUNKNO(JND1)=FUNKNO(JND1)-(REAL(IL)*REAL(IL+1))*VOL0* + 1 QQ(K1+1,K1+1)*GARSI*FUNKNO(KND1)/(FACT*YY(K)*YY(K)) +* + JND1=(IL/2)*L4+KN(NUM1+1)+(K1*IELEM+K3)*IELEM+K2 + KND1=((IL+2)/2)*L4+KN(NUM1+1)+(K1*IELEM+K3)*IELEM+K2 + FUNKNO(JND1)=FUNKNO(JND1)-(REAL(IL)*REAL(IL+1))*VOL0* + 1 QQ(K1+1,K1+1)*GARSI*FUNKNO(KND1)/(FACT*ZZ(K)*ZZ(K)) + 50 CONTINUE + ENDIF +* +* ODD PARITY EQUATION + KN1=KN(NUM1+2+K3*IELEM+K2) + KN2=KN(NUM1+2+IELEM**2+K3*IELEM+K2) + KN3=KN(NUM1+2+2*IELEM**2+K3*IELEM+K2) + KN4=KN(NUM1+2+3*IELEM**2+K3*IELEM+K2) + KN5=KN(NUM1+2+4*IELEM**2+K3*IELEM+K2) + KN6=KN(NUM1+2+5*IELEM**2+K3*IELEM+K2) + IND1=(IL/2)*L4+ABS(KN1) + IND2=(IL/2)*L4+ABS(KN2) + IND3=(IL/2)*L4+ABS(KN3) + IND4=(IL/2)*L4+ABS(KN4) + IND5=(IL/2)*L4+ABS(KN5) + IND6=(IL/2)*L4+ABS(KN6) + IF((QFR(NUM2+1).NE.0.0).AND.(KN1.NE.0)) THEN +* XINF SIDE. + DO 60 IL2=1,NLF-1,2 + IF(IL2.EQ.IL) GO TO 60 + ZMARS=PNMAR2(NZMAR,IL2,IL) + INDL=(IL2/2)*L4+ABS(KN1) + FUNKNO(IND1)=FUNKNO(IND1)+0.5*FACT*QFR(NUM2+1)*ZMARS* + 1 FUNKNO(INDL) + 60 CONTINUE + ENDIF + IF((QFR(NUM2+2).NE.0.0).AND.(KN2.NE.0)) THEN +* XSUP SIDE. + DO 70 IL2=1,NLF-1,2 + IF(IL2.EQ.IL) GO TO 70 + ZMARS=PNMAR2(NZMAR,IL2,IL) + INDL=(IL2/2)*L4+ABS(KN2) + FUNKNO(IND2)=FUNKNO(IND2)+0.5*FACT*QFR(NUM2+2)*ZMARS* + 1 FUNKNO(INDL) + 70 CONTINUE + ENDIF + IF((QFR(NUM2+3).NE.0.0).AND.(KN3.NE.0)) THEN +* YINF SIDE. + DO 80 IL2=1,NLF-1,2 + IF(IL2.EQ.IL) GO TO 80 + ZMARS=PNMAR2(NZMAR,IL2,IL) + INDL=(IL2/2)*L4+ABS(KN3) + FUNKNO(IND3)=FUNKNO(IND3)+0.5*FACT*QFR(NUM2+3)*ZMARS* + 1 FUNKNO(INDL) + 80 CONTINUE + ENDIF + IF((QFR(NUM2+4).NE.0.0).AND.(KN4.NE.0)) THEN +* YSUP SIDE. + DO 90 IL2=1,NLF-1,2 + IF(IL2.EQ.IL) GO TO 90 + ZMARS=PNMAR2(NZMAR,IL2,IL) + INDL=(IL2/2)*L4+ABS(KN4) + FUNKNO(IND4)=FUNKNO(IND4)+0.5*FACT*QFR(NUM2+4)*ZMARS* + 1 FUNKNO(INDL) + 90 CONTINUE + ENDIF + IF((QFR(NUM2+5).NE.0.0).AND.(KN5.NE.0)) THEN +* ZINF SIDE. + DO 100 IL2=1,NLF-1,2 + IF(IL2.EQ.IL) GO TO 100 + ZMARS=PNMAR2(NZMAR,IL2,IL) + INDL=(IL2/2)*L4+ABS(KN5) + FUNKNO(IND5)=FUNKNO(IND5)+0.5*FACT*QFR(NUM2+5)*ZMARS* + 1 FUNKNO(INDL) + 100 CONTINUE + ENDIF + IF((QFR(NUM2+6).NE.0.0).AND.(KN6.NE.0)) THEN +* ZSUP SIDE. + DO 110 IL2=1,NLF-1,2 + IF(IL2.EQ.IL) GO TO 110 + ZMARS=PNMAR2(NZMAR,IL2,IL) + INDL=(IL2/2)*L4+ABS(KN6) + FUNKNO(IND6)=FUNKNO(IND6)+0.5*FACT*QFR(NUM2+6)*ZMARS* + 1 FUNKNO(INDL) + 110 CONTINUE + ENDIF + IF(IL.LE.NLF-3) THEN + DO 130 K1=0,IELEM-1 + JND1=((IL+2)/2)*L4+KN(NUM1+1)+(K3*IELEM+K2)*IELEM+K1 + IF(KN1.NE.0) THEN + SG=REAL(SIGN(1,KN1)) + FUNKNO(IND1)=FUNKNO(IND1)-SG*REAL(IL+1)*VOL0*V(1,K1+1)* + 1 FUNKNO(JND1)/XX(K) + ENDIF + IF(KN2.NE.0) THEN + SG=REAL(SIGN(1,KN2)) + FUNKNO(IND2)=FUNKNO(IND2)-SG*REAL(IL+1)*VOL0* + 1 V(IELEM+1,K1+1)*FUNKNO(JND1)/XX(K) + ENDIF + JND1=((IL+2)/2)*L4+KN(NUM1+1)+(K3*IELEM+K1)*IELEM+K2 + IF(KN3.NE.0) THEN + SG=REAL(SIGN(1,KN3)) + FUNKNO(IND3)=FUNKNO(IND3)-SG*REAL(IL+1)*VOL0*V(1,K1+1)* + 1 FUNKNO(JND1)/YY(K) + ENDIF + IF(KN4.NE.0) THEN + SG=REAL(SIGN(1,KN4)) + FUNKNO(IND4)=FUNKNO(IND4)-SG*REAL(IL+1)*VOL0* + 1 V(IELEM+1,K1+1)*FUNKNO(JND1)/YY(K) + ENDIF + JND1=((IL+2)/2)*L4+KN(NUM1+1)+(K1*IELEM+K3)*IELEM+K2 + IF(KN5.NE.0) THEN + SG=REAL(SIGN(1,KN5)) + FUNKNO(IND5)=FUNKNO(IND5)-SG*REAL(IL+1)*VOL0*V(1,K1+1)* + 1 FUNKNO(JND1)/ZZ(K) + ENDIF + IF(KN6.NE.0) THEN + SG=REAL(SIGN(1,KN6)) + FUNKNO(IND6)=FUNKNO(IND6)-SG*REAL(IL+1)*VOL0* + 1 V(IELEM+1,K1+1)*FUNKNO(JND1)/ZZ(K) + ENDIF + 130 CONTINUE + ENDIF + 140 CONTINUE + 145 CONTINUE + ENDIF + NUM1=NUM1+1+6*IELEM**2 + NUM2=NUM2+6 + 150 CONTINUE + RETURN + END diff --git a/Trivac/src/PNMAR2.f b/Trivac/src/PNMAR2.f new file mode 100755 index 0000000..e874d63 --- /dev/null +++ b/Trivac/src/PNMAR2.f @@ -0,0 +1,118 @@ +*DECK PNMAR2 + FUNCTION PNMAR2(NGPT,L1,L2) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Return the dual Marshak boundary coefficients in plane geometry. +* These coefficients are specific to the left boundary. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NGPT number of Gauss-Legendre base points for the integration of +* the direction cosine. Set to 65 for exact integration. +* L1 first Legendre order (even number in mixed dual cases). +* L2 second Legendre order (odd number in mixed dual cases). + +*Parameters: output +* PNMAR2 Marshak coefficient. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NGPT,L1,L2 + REAL PNMAR2 +*---- +* LOCAL VARIABLES +*---- + PARAMETER(MAXGPT=64) + REAL ZGKSI(MAXGPT),WGKSI(MAXGPT) + DOUBLE PRECISION SUM,PNL1,PNL2,P1,P2 +* + IF(MOD(L1,2).EQ.0) THEN + CALL XABORT('PNMAR2: ODD FIRST INDEX EXPECTED.') + ENDIF + PNL1=0.0D0 + PNL2=0.0D0 + IF(NGPT.LE.64) THEN +* USE A GAUSS-LEGENDRE QUADRATURE. + CALL ALGPT(NGPT,-1.0,1.0,ZGKSI,WGKSI) + SUM=0.0 + DO 30 I=NGPT/2+1,NGPT + P1=1.0D0 + P2=ZGKSI(I) + IF(L1.EQ.0) THEN + PNL1=1.0D0 + ELSE IF(L1.EQ.1) THEN + PNL1=P2 + ELSE + DO 10 LL=2,L1 + PNL1=(ZGKSI(I)*REAL(2*LL-1)*P2-REAL(LL-1)*P1)/REAL(LL) + P1=P2 + P2=PNL1 + 10 CONTINUE + ENDIF + P1=1.0D0 + P2=ZGKSI(I) + IF(L2.EQ.0) THEN + PNL2=1.0D0 + ELSE IF(L2.EQ.1) THEN + PNL2=P2 + ELSE + DO 20 LL=2,L2 + PNL2=(ZGKSI(I)*REAL(2*LL-1)*P2-REAL(LL-1)*P1)/REAL(LL) + P1=P2 + P2=PNL2 + 20 CONTINUE + ENDIF + SUM=SUM+WGKSI(I)*ZGKSI(I)*(PNL1*PNL2) + 30 CONTINUE + PNMAR2=REAL(SUM*REAL(2*L1+1)) + ELSE +* USE EXACT INTEGRATION. + NGPTE=16 + CALL ALGPT(NGPTE,0.0,1.0,ZGKSI,WGKSI) + SUM=0.0D0 + DO 60 I=1,NGPTE + P1=1.0D0 + P2=ZGKSI(I) + IF(L1.EQ.0) THEN + PNL1=1.0D0 + ELSE IF(L1.EQ.1) THEN + PNL1=P2 + ELSE + DO 40 LL=2,L1 + PNL1=(ZGKSI(I)*REAL(2*LL-1)*P2-REAL(LL-1)*P1)/REAL(LL) + P1=P2 + P2=PNL1 + 40 CONTINUE + ENDIF + P1=1.0D0 + P2=ZGKSI(I) + IF(L2.EQ.0) THEN + PNL2=1.0D0 + ELSE IF(L2.EQ.1) THEN + PNL2=P2 + ELSE + DO 50 LL=2,L2 + PNL2=(ZGKSI(I)*REAL(2*LL-1)*P2-REAL(LL-1)*P1)/REAL(LL) + P1=P2 + P2=PNL2 + 50 CONTINUE + ENDIF + SUM=SUM+WGKSI(I)*ZGKSI(I)*(PNL1*PNL2) + 60 CONTINUE + PNMAR2=REAL(SUM*REAL(2*L1+1)) + ENDIF + RETURN + END diff --git a/Trivac/src/PNSH2D.f b/Trivac/src/PNSH2D.f new file mode 100755 index 0000000..d47e73d --- /dev/null +++ b/Trivac/src/PNSH2D.f @@ -0,0 +1,362 @@ +*DECK PNSH2D + SUBROUTINE PNSH2D(ITY,IELEM,ICOL,NBLOS,SIDE,MAT,NBMIX,NLF,NVD, + 1 NAN,SIGT,L4,IPERT,KN,QFR,LC,R,V,H,FUNKNO,SUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Source calculation for a SPN approximation in BIVAC, including +* neighbour Legendre and out-of-group contributions. +* Raviart-Thomas-Schneider method in hexagonal geometry. +* +*Copyright: +* Copyright (C) 2009 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* ITY type of assembly: +* =0: leakage-removal matrix assembly; =1: cross section matrix +* assembly. +* IELEM degree of the Lagrangian finite elements: =1 (linear); +* =2 (parabolic); =3 (cubic); =4 (quartic). +* ICOL type of quadrature: =1 (analytical integration); +* =2 (Gauss-Lobatto); =3 (Gauss-Legendre). +* NBLOS number of lozenges per direction, taking into account +* mesh-splitting. +* SIDE side of the hexagons. +* MAT index-number of the mixture type assigned to each volume. +* NBMIX number of mixtures. +* NLF number of Legendre orders for the flux (even number). +* NVD type of void boundary condition if NLF>0 and ICOL=3. +* NAN number of Legendre orders for the cross sections. +* SIGT macroscopic cross sections ordered by mixture. +* SIGT(:,NAN) generally contains the total cross section only. +* L4 order of the profiled system matrices. +* IPERT mixture permutation index. +* KN element-ordered unknown list. +* QFR element-ordered boundary conditions. +* LC order of the unit matrices. +* R unit Cartesian mass matrix. +* V unit nodal coupling matrix. +* H Piolat (hexagonal) coupling matrix. +* FUNKNO initial fluxes. +* SUNKNO initial sources. +* +*Parameters: output +* SUNKNO modified sources. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER ITY,IELEM,ICOL,NBLOS,MAT(3,NBLOS),NBMIX,NLF,NVD,NAN,L4, + 1 IPERT(NBLOS),KN(NBLOS,4+6*IELEM*(IELEM+1)),LC + REAL SIDE,SIGT(NBMIX,NAN),QFR(NBLOS,6),R(LC,LC),V(LC,LC-1), + 1 H(LC,LC-1),SUNKNO(L4*NLF/2),FUNKNO(L4*NLF/2) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(MAXIEL=3) + DOUBLE PRECISION CTRAN(MAXIEL*(MAXIEL+1),MAXIEL*(MAXIEL+1)),VAR1 +* + TTTT=REAL(0.5D0*SQRT(3.D00)*SIDE*SIDE) + IF(ICOL.EQ.3) THEN + IF(NVD.EQ.0) THEN + NZMAR=NLF+1 + ELSE IF(NVD.EQ.1) THEN + NZMAR=NLF + ELSE IF(NVD.EQ.2) THEN + NZMAR=65 + ENDIF + ELSE + NZMAR=65 + ENDIF + NELEM=IELEM*(IELEM+1) + COEF=REAL(2.0D0*SIDE*SIDE/SQRT(3.D00)) +*---- +* COMPUTE THE TRANVERSE COUPLING PIOLAT UNIT MATRIX +*---- + CTRAN(:MAXIEL*(MAXIEL+1),:MAXIEL*(MAXIEL+1))=0.0D0 + CNORM=REAL(SIDE*SIDE/SQRT(3.D00)) + I=0 + DO 22 JS=1,IELEM + DO 21 JT=1,IELEM+1 + J=0 + I=I+1 + SSS=1.0 + DO 20 IT=1,IELEM + DO 10 IS=1,IELEM+1 + J=J+1 + CTRAN(I,J)=SSS*CNORM*H(IS,JS)*H(JT,IT) + 10 CONTINUE + SSS=-SSS + 20 CONTINUE + 21 CONTINUE + 22 CONTINUE +* + DO 160 IL=0,NLF-1 + IF((ITY.EQ.1).AND.(IL.GE.NAN)) GO TO 160 + FACT=REAL(2*IL+1) +*---- +* COMPUTE THE SOURCE AT ORDER IL. +*---- + NUM=0 + DO 150 KEL=1,NBLOS + IF(IPERT(KEL).EQ.0) GO TO 150 + NUM=NUM+1 + IBM=MAT(1,IPERT(KEL)) + IF(IBM.EQ.0) GO TO 150 + GARS=SIGT(IBM,MIN(IL+1,NAN)) + IF(MOD(IL,2).EQ.0) THEN +* EVEN PARITY EQUATION. + DO 35 K2=0,IELEM-1 + DO 30 K1=0,IELEM-1 + JND1=(IL/2)*L4+KN(NUM,1)+K2*IELEM+K1 ! w-oriented flux + JND2=(IL/2)*L4+KN(NUM,2)+K2*IELEM+K1 + JND3=(IL/2)*L4+KN(NUM,3)+K2*IELEM+K1 + SUNKNO(JND1)=SUNKNO(JND1)+FACT*TTTT*GARS*FUNKNO(JND1) + SUNKNO(JND2)=SUNKNO(JND2)+FACT*TTTT*GARS*FUNKNO(JND2) + SUNKNO(JND3)=SUNKNO(JND3)+FACT*TTTT*GARS*FUNKNO(JND3) + 30 CONTINUE + 35 CONTINUE + IF(ITY.EQ.1) GO TO 150 +* + DO 43 K4=0,1 + DO 42 K3=0,IELEM-1 + DO 41 K2=1,IELEM+1 + KNW1=KN(NUM,4+K4*NELEM+K3*(IELEM+1)+K2) + KNX1=KN(NUM,4+(K4+2)*NELEM+K3*(IELEM+1)+K2) + KNY1=KN(NUM,4+(K4+4)*NELEM+K3*(IELEM+1)+K2) + INW1=(IL/2)*L4+ABS(KNW1) ! w-oriented current + INX1=(IL/2)*L4+ABS(KNX1) + INY1=(IL/2)*L4+ABS(KNY1) + DO 40 K1=0,IELEM-1 + IF(V(K2,K1+1).EQ.0.0) GO TO 40 + IF(K4.EQ.0) THEN + SSS=(-1.0)**K1 + JND1=(IL/2)*L4+KN(NUM,1)+K3*IELEM+K1 ! w-oriented flux + JND2=(IL/2)*L4+KN(NUM,2)+K3*IELEM+K1 + JND3=(IL/2)*L4+KN(NUM,3)+K3*IELEM+K1 + ELSE + SSS=1.0 + JND1=(IL/2)*L4+KN(NUM,2)+K1*IELEM+K3 + JND2=(IL/2)*L4+KN(NUM,3)+K1*IELEM+K3 + JND3=(IL/2)*L4+KN(NUM,4)+K1*IELEM+K3 + ENDIF + VAR1=SSS*REAL(IL+1)*SIDE*V(K2,K1+1) + IF(KNW1.NE.0) THEN + SG=REAL(SIGN(1,KNW1)) + SUNKNO(JND1)=SUNKNO(JND1)+SG*REAL(VAR1)*FUNKNO(INW1) + ENDIF + IF(KNX1.NE.0) THEN + SG=REAL(SIGN(1,KNX1)) + SUNKNO(JND2)=SUNKNO(JND2)+SG*REAL(VAR1)*FUNKNO(INX1) + ENDIF + IF(KNY1.NE.0) THEN + SG=REAL(SIGN(1,KNY1)) + SUNKNO(JND3)=SUNKNO(JND3)+SG*REAL(VAR1)*FUNKNO(INY1) + ENDIF + IF(IL.GE.2) THEN + VAR1=SSS*REAL(IL)*SIDE*V(K2,K1+1) + IF(KNW1.NE.0) THEN + SG=REAL(SIGN(1,KNW1)) + SUNKNO(JND1)=SUNKNO(JND1)+SG*REAL(VAR1)*FUNKNO(INW1-L4) + ENDIF + IF(KNX1.NE.0) THEN + SG=REAL(SIGN(1,KNX1)) + SUNKNO(JND2)=SUNKNO(JND2)+SG*REAL(VAR1)*FUNKNO(INX1-L4) + ENDIF + IF(KNY1.NE.0) THEN + SG=REAL(SIGN(1,KNY1)) + SUNKNO(JND3)=SUNKNO(JND3)+SG*REAL(VAR1)*FUNKNO(INY1-L4) + ENDIF + ENDIF + 40 CONTINUE + 41 CONTINUE + 42 CONTINUE + 43 CONTINUE + ELSE IF(MOD(IL,2).EQ.1) THEN +* ODD PARITY EQUATION. + DO 112 K4=0,1 ! TWO LOZENGES PER HEXAGON + DO 111 K3=0,IELEM-1 + DO 110 K2=1,IELEM+1 + KNW1=KN(NUM,4+K4*NELEM+K3*(IELEM+1)+K2) ! w-oriented current + KNX1=KN(NUM,4+(K4+2)*NELEM+K3*(IELEM+1)+K2) + KNY1=KN(NUM,4+(K4+4)*NELEM+K3*(IELEM+1)+K2) + INW1=(IL/2)*L4+ABS(KNW1) + INX1=(IL/2)*L4+ABS(KNX1) + INY1=(IL/2)*L4+ABS(KNY1) + DO 70 K1=1,IELEM+1 + KNW2=KN(NUM,4+K4*NELEM+K3*(IELEM+1)+K1) ! w-oriented current + KNX2=KN(NUM,4+(K4+2)*NELEM+K3*(IELEM+1)+K1) + KNY2=KN(NUM,4+(K4+4)*NELEM+K3*(IELEM+1)+K1) + INW2=(IL/2)*L4+ABS(KNW2) + INX2=(IL/2)*L4+ABS(KNX2) + INY2=(IL/2)*L4+ABS(KNY2) + VAR1=FACT*COEF*GARS*R(K2,K1) + IF((KNW2.NE.0).AND.(KNW1.NE.0)) THEN + SG=REAL(SIGN(1,KNW1)*SIGN(1,KNW2)) + SUNKNO(INW1)=SUNKNO(INW1)-SG*REAL(VAR1)*FUNKNO(INW2) + ENDIF + IF((KNX2.NE.0).AND.(KNX1.NE.0)) THEN + SG=REAL(SIGN(1,KNX1)*SIGN(1,KNX2)) + SUNKNO(INX1)=SUNKNO(INX1)-SG*REAL(VAR1)*FUNKNO(INX2) + ENDIF + IF((KNY2.NE.0).AND.(KNY1.NE.0)) THEN + SG=REAL(SIGN(1,KNY1)*SIGN(1,KNY2)) + SUNKNO(INY1)=SUNKNO(INY1)-SG*REAL(VAR1)*FUNKNO(INY2) + ENDIF + 70 CONTINUE + IF(ITY.EQ.0) THEN +* BOUNDARY CONDITIONS. + IF(KNW1.NE.0) THEN + DO 80 IL2=1,NLF-1,2 + ZMARS=PNMAR2(NZMAR,IL2,IL) + INW2=(IL2/2)*L4+ABS(KNW1) + IF((K2.EQ.1).AND.(K4.EQ.0)) THEN + VAR1=0.5*FACT*QFR(NUM,1)*ZMARS*FUNKNO(INW2) + SUNKNO(INW1)=SUNKNO(INW1)-REAL(VAR1) + ELSE IF((K2.EQ.IELEM+1).AND.(K4.EQ.1)) THEN + VAR1=0.5*FACT*QFR(NUM,2)*ZMARS*FUNKNO(INW2) + SUNKNO(INW1)=SUNKNO(INW1)-REAL(VAR1) + ENDIF + 80 CONTINUE + ENDIF + IF(KNX1.NE.0) THEN + DO 90 IL2=1,NLF-1,2 + ZMARS=PNMAR2(NZMAR,IL2,IL) + INX2=(IL2/2)*L4+ABS(KNX1) + IF((K2.EQ.1).AND.(K4.EQ.0)) THEN + VAR1=0.5*FACT*QFR(NUM,3)*ZMARS*FUNKNO(INX2) + SUNKNO(INX1)=SUNKNO(INX1)-REAL(VAR1) + ELSE IF((K2.EQ.IELEM+1).AND.(K4.EQ.1)) THEN + VAR1=0.5*FACT*QFR(NUM,4)*ZMARS*FUNKNO(INX2) + SUNKNO(INX1)=SUNKNO(INX1)-REAL(VAR1) + ENDIF + 90 CONTINUE + ENDIF + IF(KNY1.NE.0) THEN + DO 100 IL2=1,NLF-1,2 + ZMARS=PNMAR2(NZMAR,IL2,IL) + INY2=(IL2/2)*L4+ABS(KNY1) + IF((K2.EQ.1).AND.(K4.EQ.0)) THEN + VAR1=0.5*FACT*QFR(NUM,5)*ZMARS*FUNKNO(INY2) + SUNKNO(INY1)=SUNKNO(INY1)-REAL(VAR1) + ELSE IF((K2.EQ.IELEM+1).AND.(K4.EQ.1)) THEN + VAR1=0.5*FACT*QFR(NUM,6)*ZMARS*FUNKNO(INY2) + SUNKNO(INY1)=SUNKNO(INY1)-REAL(VAR1) + ENDIF + 100 CONTINUE + ENDIF + ENDIF + 110 CONTINUE + 111 CONTINUE + 112 CONTINUE +* + ITRS=0 + DO I=1,NBLOS + IF(KN(I,1).EQ.KN(NUM,4)) THEN + ITRS=I + GO TO 120 + ENDIF + ENDDO + CALL XABORT('PNDH2E: ITRS FAILURE.') + 120 DO 135 I=1,NELEM + KNW1=KN(ITRS,4+I) + KNX1=KN(NUM,4+2*NELEM+I) + KNY1=KN(NUM,4+4*NELEM+I) + INW1=(IL/2)*L4+ABS(KNW1) + INX1=(IL/2)*L4+ABS(KNX1) + INY1=(IL/2)*L4+ABS(KNY1) + DO 130 J=1,NELEM + KNW2=KN(NUM,4+NELEM+J) + KNX2=KN(NUM,4+3*NELEM+J) + KNY2=KN(NUM,4+5*NELEM+J) + INW2=(IL/2)*L4+ABS(KNW2) + INX2=(IL/2)*L4+ABS(KNX2) + INY2=(IL/2)*L4+ABS(KNY2) + VAR1=FACT*GARS*CTRAN(I,J) + IF((KNY2.NE.0).AND.(KNW1.NE.0)) THEN + SG=REAL(SIGN(1,KNW1)*SIGN(1,KNY2)) + SUNKNO(INY2)=SUNKNO(INY2)-SG*REAL(VAR1)*FUNKNO(INW1) ! y w + SUNKNO(INW1)=SUNKNO(INW1)-SG*REAL(VAR1)*FUNKNO(INY2) ! w y + ENDIF + IF((KNW2.NE.0).AND.(KNX1.NE.0)) THEN + SG=REAL(SIGN(1,KNX1)*SIGN(1,KNW2)) + SUNKNO(INX1)=SUNKNO(INX1)-SG*REAL(VAR1)*FUNKNO(INW2) ! x w + SUNKNO(INW2)=SUNKNO(INW2)-SG*REAL(VAR1)*FUNKNO(INX1) ! w x + ENDIF + IF((KNX2.NE.0).AND.(KNY1.NE.0)) THEN + SG=REAL(SIGN(1,KNY1)*SIGN(1,KNX2)) + SUNKNO(INY1)=SUNKNO(INY1)-SG*REAL(VAR1)*FUNKNO(INX2) ! y x + SUNKNO(INX2)=SUNKNO(INX2)-SG*REAL(VAR1)*FUNKNO(INY1) ! x y + ENDIF + 130 CONTINUE + 135 CONTINUE + IF(ITY.EQ.1) GO TO 150 +* + DO 143 K4=0,1 + DO 142 K3=0,IELEM-1 + DO 141 K2=1,IELEM+1 + KNW1=KN(NUM,4+K4*NELEM+K3*(IELEM+1)+K2) + KNX1=KN(NUM,4+(K4+2)*NELEM+K3*(IELEM+1)+K2) + KNY1=KN(NUM,4+(K4+4)*NELEM+K3*(IELEM+1)+K2) + INW1=(IL/2)*L4+ABS(KNW1) ! w-oriented current + INX1=(IL/2)*L4+ABS(KNX1) + INY1=(IL/2)*L4+ABS(KNY1) + DO 140 K1=0,IELEM-1 + IF(V(K2,K1+1).EQ.0.0) GO TO 140 + IF(K4.EQ.0) THEN + SSS=(-1.0)**K1 + JND1=(IL/2)*L4+KN(NUM,1)+K3*IELEM+K1 ! w-oriented flux + JND2=(IL/2)*L4+KN(NUM,2)+K3*IELEM+K1 + JND3=(IL/2)*L4+KN(NUM,3)+K3*IELEM+K1 + ELSE + SSS=1.0 + JND1=(IL/2)*L4+KN(NUM,2)+K1*IELEM+K3 + JND2=(IL/2)*L4+KN(NUM,3)+K1*IELEM+K3 + JND3=(IL/2)*L4+KN(NUM,4)+K1*IELEM+K3 + ENDIF + VAR1=SSS*REAL(IL)*SIDE*V(K2,K1+1) + IF(KNW1.NE.0) THEN + SG=REAL(SIGN(1,KNW1)) + SUNKNO(INW1)=SUNKNO(INW1)+SG*REAL(VAR1)*FUNKNO(JND1) + ENDIF + IF(KNX1.NE.0) THEN + SG=REAL(SIGN(1,KNX1)) + SUNKNO(INX1)=SUNKNO(INX1)+SG*REAL(VAR1)*FUNKNO(JND2) + ENDIF + IF(KNY1.NE.0) THEN + SG=REAL(SIGN(1,KNY1)) + SUNKNO(INY1)=SUNKNO(INY1)+SG*REAL(VAR1)*FUNKNO(JND3) + ENDIF + IF(IL.LE.NLF-3) THEN + VAR1=SSS*REAL(IL+1)*SIDE*V(K2,K1+1) + IF(KNW1.NE.0) THEN + SG=REAL(SIGN(1,KNW1)) + SUNKNO(INW1)=SUNKNO(INW1)+SG*REAL(VAR1)*FUNKNO(JND1+L4) + ENDIF + IF(KNX1.NE.0) THEN + SG=REAL(SIGN(1,KNX1)) + SUNKNO(INX1)=SUNKNO(INX1)+SG*REAL(VAR1)*FUNKNO(JND2+L4) + ENDIF + IF(KNY1.NE.0) THEN + SG=REAL(SIGN(1,KNY1)) + SUNKNO(INY1)=SUNKNO(INY1)+SG*REAL(VAR1)*FUNKNO(JND3+L4) + ENDIF + ENDIF + 140 CONTINUE + 141 CONTINUE + 142 CONTINUE + 143 CONTINUE + ENDIF + 150 CONTINUE + 160 CONTINUE + RETURN + END diff --git a/Trivac/src/PNSH3D.f b/Trivac/src/PNSH3D.f new file mode 100755 index 0000000..6b4eebf --- /dev/null +++ b/Trivac/src/PNSH3D.f @@ -0,0 +1,577 @@ +*DECK PNSH3D + SUBROUTINE PNSH3D (ITY,IPR,NBMIX,NBLOS,IELEM,ICOL,NLF,NVD,NAN,L4, + 1 LL4F,LL4W,LL4X,LL4Y,MAT,SIGT,SIGTI,SIDE,ZZ,FRZ,QFR,IPERT,KN,LC, + 2 R,V,CTRAN,FUNKNO,SUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Source calculation for a SPN approximation in TRIVAC, including +* neighbour Legendre and out-of-group contributions. +* Raviart-Thomas-Schneider method in hexagonal geometry. +* +*Copyright: +* Copyright (C) 2009 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* ITY type of assembly: +* =0: leakage-removal matrix assembly; =1: cross section matrix +* assembly. +* IPR type of assembly: +* =0: contains system matrices; +* =1: contains derivative of these matrices; +* =2: contains first variation of these matrices; +* =3: contains addition of first vatiation to unperturbed +* system matrices. +* NBMIX number of mixtures. +* NBLOS number of lozenges per direction, taking into account +* mesh-splitting. +* IELEM degree of the Lagrangian finite elements: =1 (linear); +* =2 (parabolic); =3 (cubic); =4 (quartic). +* ICOL type of quadrature: =1 (analytical integration); +* =2 (Gauss-Lobatto); =3 (Gauss-Legendre). +* NLF number of Legendre orders for the flux (even number). +* NVD type of void boundary condition if NLF>0 and ICOL=3. +* NAN number of Legendre orders for the cross sections. +* L4 number of unknowns per energy group and per set of two +* Legendre orders. +* LL4F number of flux components. +* LL4W number of W-directed currents. +* LL4X number of X-directed currents. +* LL4Y number of Y-directed currents. +* MAT index-number of the mixture type assigned to each volume. +* SIGT macroscopic cross sections ordered by mixture. +* SIGT(:,NAN) generally contains the total cross section only. +* SIGTI inverse macroscopic cross sections ordered by mixture. +* SIGTI(:,NAN) generally contains the inverse total cross +* section only. +* SIDE side of an hexagon. +* ZZ Z-directed mesh spacings. +* FRZ volume fractions for the axial SYME boundary condition. +* QFR element-ordered boundary conditions. +* IPERT mixture permutation index. +* KN ADI permutation indices for the volumes and currents. +* LC order of the unit matrices. +* R unit Cartesian mass matrix. +* V unit nodal coupling matrix. +* CTRAN tranverse coupling Piolat unit matrix. +* FUNKNO initial fluxes. +* SUNKNO initial sources. +* +*Parameters: output +* SUNKNO modified sources. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER ITY,IPR,NBMIX,NBLOS,IELEM,ICOL,NLF,NVD,NAN,L4,LL4F,LL4W, + 1 LL4X,LL4Y,MAT(3,NBLOS),IPERT(NBLOS), + 2 KN(NBLOS,3+6*(IELEM+2)*IELEM**2),LC + REAL SIGT(NBMIX,NAN),SIGTI(NBMIX,NAN),SIDE,ZZ(3,NBLOS), + 1 FRZ(NBLOS),QFR(NBLOS,8),R(LC,LC),V(LC,LC-1),SUNKNO(L4*NLF/2), + 2 FUNKNO(L4*NLF/2) + DOUBLE PRECISION CTRAN((IELEM+1)*IELEM,(IELEM+1)*IELEM) +*---- +* LOCAL VARIABLES +*---- + REAL QQ(5,5) + DOUBLE PRECISION FFF,TTTT,UUUU,VOL0,GARS,GARSI,FACT,VAR1 + REAL, DIMENSION(:), ALLOCATABLE :: DIFF +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(DIFF(NBLOS)) +* + IF(ICOL.EQ.3) THEN + IF(NVD.EQ.0) THEN + NZMAR=NLF+1 + ELSE IF(NVD.EQ.1) THEN + NZMAR=NLF + ELSE IF(NVD.EQ.2) THEN + NZMAR=65 + ENDIF + ELSE + NZMAR=65 + ENDIF + DO 16 I0=1,IELEM + DO 15 J0=1,IELEM + FFF=0.0D0 + DO 10 K0=2,IELEM + FFF=FFF+V(K0,I0)*V(K0,J0)/R(K0,K0) + 10 CONTINUE + IF(ABS(FFF).LE.1.0E-6) FFF=0.0D0 + QQ(I0,J0)=REAL(FFF) + 15 CONTINUE + 16 CONTINUE +*---- +* MAIN LOOP OVER LEGENDRE ORDERS FOR THE FLUX. +*---- + DO 200 IL=0,NLF-1 + IF((ITY.EQ.1).AND.(IL.GE.NAN)) GO TO 200 + FACT=REAL(2*IL+1) +*---- +* RECOVER CROSS SECTIONS FOR THE PIOLAT TERMS. +*---- + IF(MOD(IL,2).EQ.1) THEN + DO 20 KEL=1,NBLOS + DIFF(KEL)=0.0 + IF(IPERT(KEL).GT.0) THEN + IBM=MAT(1,IPERT(KEL)) + IF(IBM.GT.0) THEN + GARS=SIGT(IBM,MIN(IL+1,NAN)) + VAR1=FACT*ZZ(1,IPERT(KEL))*FRZ(KEL)*GARS + DIFF(KEL)=REAL(VAR1) + ENDIF + ENDIF + 20 CONTINUE + ENDIF +*---- +* COMPUTE THE SOURCE AT ORDER IL. +*---- + NELEH=(IELEM+1)*IELEM**2 + TTTT=0.5D0*SQRT(3.D00)*SIDE*SIDE + JOFF=(IL/2)*L4 + NUM=0 + DO 180 KEL=1,NBLOS + IF(IPERT(KEL).EQ.0) GO TO 180 + NUM=NUM+1 + IBM=MAT(1,IPERT(KEL)) + IF(IBM.EQ.0) GO TO 180 + DZ=ZZ(1,IPERT(KEL)) + VOL0=TTTT*DZ*FRZ(KEL) + UUUU=SIDE*DZ*FRZ(KEL) + GARS=SIGT(IBM,MIN(IL+1,NAN)) + IF(MOD(IL,2).EQ.0) THEN +* EVEN PARITY EQUATION + DO 27 K3=0,IELEM-1 + DO 26 K2=0,IELEM-1 + DO 25 K1=0,IELEM-1 + JND1=JOFF+(((NUM-1)*IELEM+K3)*IELEM+K2)*IELEM+K1+1 + JND2=JOFF+(((KN(NUM,1)-1)*IELEM+K3)*IELEM+K2)*IELEM+K1+1 + JND3=JOFF+(((KN(NUM,2)-1)*IELEM+K3)*IELEM+K2)*IELEM+K1+1 + SUNKNO(JND1)=SUNKNO(JND1)+REAL(FACT*VOL0*GARS*FUNKNO(JND1)) + SUNKNO(JND2)=SUNKNO(JND2)+REAL(FACT*VOL0*GARS*FUNKNO(JND2)) + SUNKNO(JND3)=SUNKNO(JND3)+REAL(FACT*VOL0*GARS*FUNKNO(JND3)) + 25 CONTINUE + 26 CONTINUE + 27 CONTINUE + IF(ITY.EQ.1) GO TO 180 + IF((IPR.EQ.1).OR.(IPR.EQ.2)) GO TO 180 +* + DO 34 K5=0,1 ! TWO LOZENGES PER HEXAGON + DO 33 K4=0,IELEM-1 + DO 32 K3=0,IELEM-1 + DO 31 K2=1,IELEM+1 + KNW1=KN(NUM,3+K5*NELEH+(K4*IELEM+K3)*(IELEM+1)+K2) + KNX1=KN(NUM,3+(K5+2)*NELEH+(K4*IELEM+K3)*(IELEM+1)+K2) + KNY1=KN(NUM,3+(K5+4)*NELEH+(K4*IELEM+K3)*(IELEM+1)+K2) + INW1=JOFF+LL4F+ABS(KNW1) + INX1=JOFF+LL4F+ABS(KNX1) + INY1=JOFF+LL4F+ABS(KNY1) + DO 30 K1=0,IELEM-1 + IF(V(K2,K1+1).EQ.0.0) GO TO 30 + IF(K5.EQ.0) THEN + SSS=(-1.0)**K1 + JND1=JOFF+(((NUM-1)*IELEM+K4)*IELEM+K3)*IELEM+K1+1 + JND2=JOFF+(((KN(NUM,1)-1)*IELEM+K4)*IELEM+K3)*IELEM+K1+1 + JND3=JOFF+(((KN(NUM,2)-1)*IELEM+K4)*IELEM+K3)*IELEM+K1+1 + ELSE + SSS=1.0 + JND1=JOFF+(((KN(NUM,1)-1)*IELEM+K4)*IELEM+K1)*IELEM+K3+1 + JND2=JOFF+(((KN(NUM,2)-1)*IELEM+K4)*IELEM+K1)*IELEM+K3+1 + JND3=JOFF+(((KN(NUM,3)-1)*IELEM+K4)*IELEM+K1)*IELEM+K3+1 + ENDIF + IF(KNW1.NE.0) THEN + SG=REAL(SIGN(1,KNW1)) + VAR1=SG*SSS*REAL(IL+1)*UUUU*V(K2,K1+1)*FUNKNO(INW1) + SUNKNO(JND1)=SUNKNO(JND1)+REAL(VAR1) + ENDIF + IF(KNX1.NE.0) THEN + SG=REAL(SIGN(1,KNX1)) + VAR1=SG*SSS*REAL(IL+1)*UUUU*V(K2,K1+1)*FUNKNO(INX1) + SUNKNO(JND2)=SUNKNO(JND2)+REAL(VAR1) + ENDIF + IF(KNY1.NE.0) THEN + SG=REAL(SIGN(1,KNY1)) + VAR1=SG*SSS*REAL(IL+1)*UUUU*V(K2,K1+1)*FUNKNO(INY1) + SUNKNO(JND3)=SUNKNO(JND3)+REAL(VAR1) + ENDIF + IF(IL.GE.2) THEN + IF(KNW1.NE.0) THEN + SG=REAL(SIGN(1,KNW1)) + VAR1=SG*SSS*REAL(IL)*UUUU*V(K2,K1+1)*FUNKNO(INW1-L4) + SUNKNO(JND1)=SUNKNO(JND1)+REAL(VAR1) + ENDIF + IF(KNX1.NE.0) THEN + SG=REAL(SIGN(1,KNX1)) + VAR1=SG*SSS*REAL(IL)*UUUU*V(K2,K1+1)*FUNKNO(INX1-L4) + SUNKNO(JND2)=SUNKNO(JND2)+REAL(VAR1) + ENDIF + IF(KNY1.NE.0) THEN + SG=REAL(SIGN(1,KNY1)) + VAR1=SG*SSS*REAL(IL)*UUUU*V(K2,K1+1)*FUNKNO(INY1-L4) + SUNKNO(JND3)=SUNKNO(JND3)+REAL(VAR1) + ENDIF + ENDIF + 30 CONTINUE + 31 CONTINUE + 32 CONTINUE + 33 CONTINUE + 34 CONTINUE + DO 43 K5=0,2 ! THREE LOZENGES PER HEXAGON + DO 42 K2=0,IELEM-1 + DO 41 K1=0,IELEM-1 + KNZ1=KN(NUM,3+6*NELEH+2*K5*IELEM**2+K2*IELEM+K1+1) + KNZ2=KN(NUM,3+6*NELEH+(2*K5+1)*IELEM**2+K2*IELEM+K1+1) + INZ1=JOFF+LL4F+ABS(KNZ1) + INZ2=JOFF+LL4F+ABS(KNZ2) + DO 40 K3=0,IELEM-1 + IF(K5.EQ.0) THEN + JND1=JOFF+((((NUM-1)*IELEM)+K3)*IELEM+K2)*IELEM+K1+1 + ELSE + JND1=JOFF+(((KN(NUM,K5)-1)*IELEM+K3)*IELEM+K2)*IELEM+K1+1 + ENDIF + IF(KNZ1.NE.0) THEN + SG=REAL(SIGN(1,KNZ1)) + VAR1=SG*(VOL0/DZ)*REAL(IL+1)*V(1,K3+1)*FUNKNO(INZ1) + SUNKNO(JND1)=SUNKNO(JND1)+REAL(VAR1) + ENDIF + IF(KNZ2.NE.0) THEN + SG=REAL(SIGN(1,KNZ2)) + VAR1=SG*(VOL0/DZ)*REAL(IL+1)*V(IELEM+1,K3+1)*FUNKNO(INZ2) + SUNKNO(JND1)=SUNKNO(JND1)+REAL(VAR1) + ENDIF + IF(IL.GE.2) THEN + IF(KNZ1.NE.0) THEN + SG=REAL(SIGN(1,KNZ1)) + VAR1=SG*(VOL0/DZ)*REAL(IL)*V(1,K3+1)*FUNKNO(INZ1-L4) + SUNKNO(JND1)=SUNKNO(JND1)+REAL(VAR1) + ENDIF + IF(KNZ2.NE.0) THEN + SG=REAL(SIGN(1,KNZ2)) + VAR1=SG*(VOL0/DZ)*REAL(IL)*V(IELEM+1,K3+1)* + 1 FUNKNO(INZ2-L4) + SUNKNO(JND1)=SUNKNO(JND1)+REAL(VAR1) + ENDIF + ENDIF + 40 CONTINUE + 41 CONTINUE + 42 CONTINUE + 43 CONTINUE + ELSE IF(MOD(IL,2).EQ.1) THEN +* PARTIAL INVERSION OF THE ODD PARITY EQUATION. MODIFICATION OF +* THE EVEN PARITY EQUATION. + GARSI=SIGTI(IBM,MIN(IL+1,NAN)) + IF(IELEM.GT.1) THEN + DO 72 K3=0,IELEM-1 + DO 71 K2=0,IELEM-1 + DO 70 K1=0,IELEM-1 + IF(QQ(K3+1,K3+1).EQ.0.0) GO TO 70 + JND1=JOFF+(NUM-1)*IELEM**3+K3*IELEM**2+K2*IELEM+K1+1 + JND2=JOFF+(KN(NUM,1)-1)*IELEM**3+K3*IELEM**2+K2*IELEM+K1+1 + JND3=JOFF+(KN(NUM,2)-1)*IELEM**3+K3*IELEM**2+K2*IELEM+K1+1 + VAR1=(REAL(IL)**2)*VOL0*QQ(K3+1,K3+1)*GARSI/(FACT*DZ*DZ) + SUNKNO(JND1)=SUNKNO(JND1)+REAL(VAR1)*FUNKNO(JND1) + SUNKNO(JND2)=SUNKNO(JND2)+REAL(VAR1)*FUNKNO(JND2) + SUNKNO(JND3)=SUNKNO(JND3)+REAL(VAR1)*FUNKNO(JND3) + IF(IL.LE.NLF-3) THEN + KND1=JND1+L4 + KND2=JND2+L4 + KND3=JND3+L4 + VAR1=(REAL(IL)*REAL(IL+1))*VOL0*QQ(K3+1,K3+1)*GARSI/ + 1 (FACT*DZ*DZ) + SUNKNO(KND1)=SUNKNO(KND1)+REAL(VAR1)*FUNKNO(JND1) + SUNKNO(KND2)=SUNKNO(KND2)+REAL(VAR1)*FUNKNO(JND2) + SUNKNO(KND3)=SUNKNO(KND3)+REAL(VAR1)*FUNKNO(JND3) +* + SUNKNO(JND1)=SUNKNO(JND1)+REAL(VAR1)*FUNKNO(KND1) + SUNKNO(JND2)=SUNKNO(JND2)+REAL(VAR1)*FUNKNO(KND2) + SUNKNO(JND3)=SUNKNO(JND3)+REAL(VAR1)*FUNKNO(KND3) +* + VAR1=(REAL(IL+1)**2)*VOL0*QQ(K3+1,K3+1)*GARSI/ + 1 (FACT*DZ*DZ) + SUNKNO(KND1)=SUNKNO(KND1)+REAL(VAR1)*FUNKNO(KND1) + SUNKNO(KND2)=SUNKNO(KND2)+REAL(VAR1)*FUNKNO(KND2) + SUNKNO(KND3)=SUNKNO(KND3)+REAL(VAR1)*FUNKNO(KND3) + ENDIF + 70 CONTINUE + 71 CONTINUE + 72 CONTINUE + ENDIF +* ODD PARITY EQUATION. + DO 84 K5=0,1 ! TWO LOZENGES PER HEXAGON + DO 83 K4=0,IELEM-1 + DO 82 K3=0,IELEM-1 + DO 81 K2=1,IELEM+1 + KNW1=KN(NUM,3+K5*NELEH+(K4*IELEM+K3)*(IELEM+1)+K2) + KNX1=KN(NUM,3+(K5+2)*NELEH+(K4*IELEM+K3)*(IELEM+1)+K2) + KNY1=KN(NUM,3+(K5+4)*NELEH+(K4*IELEM+K3)*(IELEM+1)+K2) + INW1=JOFF+LL4F+ABS(KNW1) + INX1=JOFF+LL4F+ABS(KNX1) + INY1=JOFF+LL4F+ABS(KNY1) + DO 80 K1=1,IELEM+1 + KNW2=KN(NUM,3+K5*NELEH+(K4*IELEM+K3)*(IELEM+1)+K1) + KNX2=KN(NUM,3+(K5+2)*NELEH+(K4*IELEM+K3)*(IELEM+1)+K1) + KNY2=KN(NUM,3+(K5+4)*NELEH+(K4*IELEM+K3)*(IELEM+1)+K1) + INW2=JOFF+LL4F+ABS(KNW2) + INX2=JOFF+LL4F+ABS(KNX2) + INY2=JOFF+LL4F+ABS(KNY2) + IF((KNW2.NE.0).AND.(KNW1.NE.0)) THEN + SG=REAL(SIGN(1,KNW1)*SIGN(1,KNW2)) + VAR1=(4./3.)*SG*FACT*VOL0*GARS*R(K2,K1)*FUNKNO(INW2) + SUNKNO(INW1)=SUNKNO(INW1)-REAL(VAR1) + ENDIF + IF((KNX2.NE.0).AND.(KNX1.NE.0)) THEN + SG=REAL(SIGN(1,KNX1)*SIGN(1,KNX2)) + VAR1=(4./3.)*SG*FACT*VOL0*GARS*R(K2,K1)*FUNKNO(INX2) + SUNKNO(INX1)=SUNKNO(INX1)-REAL(VAR1) + ENDIF + IF((KNY2.NE.0).AND.(KNY1.NE.0)) THEN + SG=REAL(SIGN(1,KNY1)*SIGN(1,KNY2)) + VAR1=(4./3.)*SG*FACT*VOL0*GARS*R(K2,K1)*FUNKNO(INY2) + SUNKNO(INY1)=SUNKNO(INY1)-REAL(VAR1) + ENDIF + 80 CONTINUE + 81 CONTINUE + 82 CONTINUE + 83 CONTINUE + 84 CONTINUE + DO 94 K5=0,2 ! THREE LOZENGES PER HEXAGON + DO 93 K2=0,IELEM-1 + DO 92 K1=0,IELEM-1 + DO 91 IC=1,2 + IF(IC.EQ.1) IIC=1 + IF(IC.EQ.2) IIC=IELEM+1 + KNZ1=KN(NUM,3+6*NELEH+((2*K5+IC-1)*IELEM+K2)*IELEM+K1+1) + INZ1=JOFF+LL4F+ABS(KNZ1) + DO 90 JC=1,2 + IF(JC.EQ.1) JJC=1 + IF(JC.EQ.2) JJC=IELEM+1 + KNZ2=KN(NUM,3+6*NELEH+((2*K5+JC-1)*IELEM+K2)*IELEM+K1+1) + INZ2=JOFF+LL4F+ABS(KNZ2) + IF((KNZ1.NE.0).AND.(KNZ2.NE.0)) THEN + SG=REAL(SIGN(1,KNZ1)*SIGN(1,KNZ2)) + VAR1=SG*FACT*VOL0*GARS*R(IIC,JJC)*FUNKNO(INZ2) + SUNKNO(INZ1)=SUNKNO(INZ1)-REAL(VAR1) + ENDIF + 90 CONTINUE + 91 CONTINUE + 92 CONTINUE + 93 CONTINUE + 94 CONTINUE + IF(ITY.EQ.1) GO TO 180 +*---- +* BOUNDARY CONDITIONS. +*---- + DO 133 K5=0,1 ! TWO LOZENGES PER HEXAGON + DO 132 K4=0,IELEM-1 + DO 131 K3=0,IELEM-1 + DO 130 K2=1,IELEM+1,IELEM + KNW1=KN(NUM,3+K5*NELEH+(K4*IELEM+K3)*(IELEM+1)+K2) + KNX1=KN(NUM,3+(K5+2)*NELEH+(K4*IELEM+K3)*(IELEM+1)+K2) + KNY1=KN(NUM,3+(K5+4)*NELEH+(K4*IELEM+K3)*(IELEM+1)+K2) + INW1=JOFF+LL4F+ABS(KNW1) + INX1=JOFF+LL4F+ABS(KNX1) + INY1=JOFF+LL4F+ABS(KNY1) + IF(KNW1.NE.0) THEN + DO 100 IL2=1,NLF-1,2 + ZMARS=PNMAR2(NZMAR,IL2,IL) + INW2=(IL2/2)*L4+LL4F+ABS(KNW1) + IF((K2.EQ.1).AND.(K5.EQ.0)) THEN + VAR1=0.5*FACT*QFR(NUM,1)*ZMARS*FUNKNO(INW2) + SUNKNO(INW1)=SUNKNO(INW1)-REAL(VAR1) + ELSE IF((K2.EQ.IELEM+1).AND.(K5.EQ.1)) THEN + VAR1=0.5*FACT*QFR(NUM,2)*ZMARS*FUNKNO(INW2) + SUNKNO(INW1)=SUNKNO(INW1)-REAL(VAR1) + ENDIF + 100 CONTINUE + ENDIF + IF(KNX1.NE.0) THEN + DO 110 IL2=1,NLF-1,2 + ZMARS=PNMAR2(NZMAR,IL2,IL) + INX2=(IL2/2)*L4+LL4F+ABS(KNX1) + IF((K2.EQ.1).AND.(K5.EQ.0)) THEN + VAR1=0.5*FACT*QFR(NUM,3)*ZMARS*FUNKNO(INX2) + SUNKNO(INX1)=SUNKNO(INX1)-REAL(VAR1) + ELSE IF((K2.EQ.IELEM+1).AND.(K5.EQ.1)) THEN + VAR1=0.5*FACT*QFR(NUM,4)*ZMARS*FUNKNO(INX2) + SUNKNO(INX1)=SUNKNO(INX1)-REAL(VAR1) + ENDIF + 110 CONTINUE + ENDIF + IF(KNY1.NE.0) THEN + DO 120 IL2=1,NLF-1,2 + ZMARS=PNMAR2(NZMAR,IL2,IL) + INY2=(IL2/2)*L4+LL4F+ABS(KNY1) + IF((K2.EQ.1).AND.(K5.EQ.0)) THEN + VAR1=0.5*FACT*QFR(NUM,5)*ZMARS*FUNKNO(INY2) + SUNKNO(INY1)=SUNKNO(INY1)-REAL(VAR1) + ELSE IF((K2.EQ.IELEM+1).AND.(K5.EQ.1)) THEN + VAR1=0.5*FACT*QFR(NUM,6)*ZMARS*FUNKNO(INY2) + SUNKNO(INY1)=SUNKNO(INY1)-REAL(VAR1) + ENDIF + 120 CONTINUE + ENDIF + 130 CONTINUE + 131 CONTINUE + 132 CONTINUE + 133 CONTINUE + IF((IPR.EQ.1).OR.(IPR.EQ.2)) GO TO 180 + DO 153 K5=0,2 ! THREE LOZENGES PER HEXAGON + DO 152 K2=0,IELEM-1 + DO 151 K1=0,IELEM-1 + DO 150 IC=1,2 + KNZ1=KN(NUM,3+6*NELEH+((2*K5+IC-1)*IELEM+K2)*IELEM+K1+1) + INZ1=JOFF+LL4F+ABS(KNZ1) + IF(KNZ1.NE.0) THEN + DO 140 IL2=1,NLF-1,2 + ZMARS=PNMAR2(NZMAR,IL2,IL) + INZ2=(IL2/2)*L4+LL4F+ABS(KNZ1) + IF(IC.EQ.1) THEN + VAR1=0.5*FACT*QFR(NUM,7)*ZMARS*FUNKNO(INZ2) + SUNKNO(INZ1)=SUNKNO(INZ1)-REAL(VAR1) + ELSE IF(IC.EQ.2) THEN + VAR1=0.5*FACT*QFR(NUM,8)*ZMARS*FUNKNO(INZ2) + SUNKNO(INZ1)=SUNKNO(INZ1)-REAL(VAR1) + ENDIF + 140 CONTINUE + ENDIF + 150 CONTINUE + 151 CONTINUE + 152 CONTINUE + 153 CONTINUE +* + DO 164 K5=0,1 ! TWO LOZENGES PER HEXAGON + DO 163 K4=0,IELEM-1 + DO 162 K3=0,IELEM-1 + DO 161 K2=1,IELEM+1 + KNW1=KN(NUM,3+K5*NELEH+(K4*IELEM+K3)*(IELEM+1)+K2) + KNX1=KN(NUM,3+(K5+2)*NELEH+(K4*IELEM+K3)*(IELEM+1)+K2) + KNY1=KN(NUM,3+(K5+4)*NELEH+(K4*IELEM+K3)*(IELEM+1)+K2) + INW1=JOFF+LL4F+ABS(KNW1) + INX1=JOFF+LL4F+ABS(KNX1) + INY1=JOFF+LL4F+ABS(KNY1) + DO 160 K1=0,IELEM-1 + IF(V(K2,K1+1).EQ.0.0) GO TO 160 + IF(K5.EQ.0) THEN + SSS=(-1.0)**K1 + JND1=JOFF+(((NUM-1)*IELEM+K4)*IELEM+K3)*IELEM+K1+1 + JND2=JOFF+(((KN(NUM,1)-1)*IELEM+K4)*IELEM+K3)*IELEM+K1+1 + JND3=JOFF+(((KN(NUM,2)-1)*IELEM+K4)*IELEM+K3)*IELEM+K1+1 + ELSE + SSS=1.0 + JND1=JOFF+(((KN(NUM,1)-1)*IELEM+K4)*IELEM+K1)*IELEM+K3+1 + JND2=JOFF+(((KN(NUM,2)-1)*IELEM+K4)*IELEM+K1)*IELEM+K3+1 + JND3=JOFF+(((KN(NUM,3)-1)*IELEM+K4)*IELEM+K1)*IELEM+K3+1 + ENDIF + IF(KNW1.NE.0) THEN + SG=REAL(SIGN(1,KNW1)) + VAR1=SG*SSS*REAL(IL)*UUUU*V(K2,K1+1)*FUNKNO(JND1) + SUNKNO(INW1)=SUNKNO(INW1)+REAL(VAR1) + ENDIF + IF(KNX1.NE.0) THEN + SG=REAL(SIGN(1,KNX1)) + VAR1=SG*SSS*REAL(IL)*UUUU*V(K2,K1+1)*FUNKNO(JND2) + SUNKNO(INX1)=SUNKNO(INX1)+REAL(VAR1) + ENDIF + IF(KNY1.NE.0) THEN + SG=REAL(SIGN(1,KNY1)) + VAR1=SG*SSS*REAL(IL)*UUUU*V(K2,K1+1)*FUNKNO(JND3) + SUNKNO(INY1)=SUNKNO(INY1)+REAL(VAR1) + ENDIF + IF(IL.LE.NLF-3) THEN + IF(KNW1.NE.0) THEN + SG=REAL(SIGN(1,KNW1)) + VAR1=SG*SSS*REAL(IL+1)*UUUU*V(K2,K1+1)*FUNKNO(JND1+L4) + SUNKNO(INW1)=SUNKNO(INW1)+REAL(VAR1) + ENDIF + IF(KNX1.NE.0) THEN + SG=REAL(SIGN(1,KNX1)) + VAR1=SG*SSS*REAL(IL+1)*UUUU*V(K2,K1+1)*FUNKNO(JND2+L4) + SUNKNO(INX1)=SUNKNO(INX1)+REAL(VAR1) + ENDIF + IF(KNY1.NE.0) THEN + SG=REAL(SIGN(1,KNY1)) + VAR1=SG*SSS*REAL(IL+1)*UUUU*V(K2,K1+1)*FUNKNO(JND3+L4) + SUNKNO(INY1)=SUNKNO(INY1)+REAL(VAR1) + ENDIF + ENDIF + 160 CONTINUE + 161 CONTINUE + 162 CONTINUE + 163 CONTINUE + 164 CONTINUE + DO 173 K5=0,2 ! THREE LOZENGES PER HEXAGON + DO 172 K2=0,IELEM-1 + DO 171 K1=0,IELEM-1 + KNZ1=KN(NUM,3+6*NELEH+2*K5*IELEM**2+K2*IELEM+K1+1) + KNZ2=KN(NUM,3+6*NELEH+(2*K5+1)*IELEM**2+K2*IELEM+K1+1) + INZ1=JOFF+LL4F+ABS(KNZ1) + INZ2=JOFF+LL4F+ABS(KNZ2) + DO 170 K3=0,IELEM-1 + IF(K5.EQ.0) THEN + JND1=JOFF+((((NUM-1)*IELEM)+K3)*IELEM+K2)*IELEM+K1+1 + ELSE + JND1=JOFF+(((KN(NUM,K5)-1)*IELEM+K3)*IELEM+K2)*IELEM+K1+1 + ENDIF + IF(KNZ1.NE.0) THEN + SG=REAL(SIGN(1,KNZ1)) + VAR1=SG*(VOL0/DZ)*REAL(IL)*V(1,K3+1)*FUNKNO(JND1) + SUNKNO(INZ1)=SUNKNO(INZ1)+REAL(VAR1) + ENDIF + IF(KNZ2.NE.0) THEN + SG=REAL(SIGN(1,KNZ2)) + VAR1=SG*(VOL0/DZ)*REAL(IL)*V(IELEM+1,K3+1)*FUNKNO(JND1) + SUNKNO(INZ2)=SUNKNO(INZ2)+REAL(VAR1) + ENDIF + IF(IL.LE.NLF-3) THEN + IF(KNZ1.NE.0) THEN + SG=REAL(SIGN(1,KNZ1)) + VAR1=SG*(VOL0/DZ)*REAL(IL+1)*V(1,K3+1)*FUNKNO(JND1+L4) + SUNKNO(INZ1)=SUNKNO(INZ1)+REAL(VAR1) + ENDIF + IF(KNZ2.NE.0) THEN + SG=REAL(SIGN(1,KNZ2)) + VAR1=SG*(VOL0/DZ)*REAL(IL+1)*V(IELEM+1,K3+1)* + 1 FUNKNO(JND1+L4) + SUNKNO(INZ2)=SUNKNO(INZ2)+REAL(VAR1) + ENDIF + ENDIF + 170 CONTINUE + 171 CONTINUE + 172 CONTINUE + 173 CONTINUE + ENDIF + 180 CONTINUE + IF(MOD(IL,2).EQ.1) THEN + IOFW=JOFF+LL4F + IOFX=JOFF+LL4F+LL4W + IOFY=JOFF+LL4F+LL4W+LL4X + CALL FLDPWY(LL4W,LL4X,LL4Y,NBLOS,IELEM,CTRAN,IPERT,KN,DIFF, + 1 FUNKNO(IOFY+1),SUNKNO(IOFW+1)) + CALL FLDPWX(LL4W,LL4X,NBLOS,IELEM,CTRAN,IPERT,KN,DIFF, + 1 FUNKNO(IOFX+1),SUNKNO(IOFW+1)) + CALL FLDPXW(LL4W,LL4X,NBLOS,IELEM,CTRAN,IPERT,KN,DIFF, + 1 FUNKNO(IOFW+1),SUNKNO(IOFX+1)) + CALL FLDPXY(LL4W,LL4X,LL4Y,NBLOS,IELEM,CTRAN,IPERT,KN,DIFF, + 1 FUNKNO(IOFY+1),SUNKNO(IOFX+1)) + CALL FLDPYX(LL4W,LL4X,LL4Y,NBLOS,IELEM,CTRAN,IPERT,KN,DIFF, + 1 FUNKNO(IOFX+1),SUNKNO(IOFY+1)) + CALL FLDPYW(LL4W,LL4X,LL4Y,NBLOS,IELEM,CTRAN,IPERT,KN,DIFF, + 1 FUNKNO(IOFW+1),SUNKNO(IOFY+1)) + ENDIF + 200 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(DIFF) + RETURN + END diff --git a/Trivac/src/PNSZ2D.f b/Trivac/src/PNSZ2D.f new file mode 100755 index 0000000..6310cb5 --- /dev/null +++ b/Trivac/src/PNSZ2D.f @@ -0,0 +1,347 @@ +*DECK PNSZ2D + SUBROUTINE PNSZ2D(ITY,NREG,IELEM,ICOL,XX,YY,MAT,VOL,NBMIX,NLF, + 1 NVD,NAN,SIGT,SIGTI,L4,KN,QFR,LC,R,V,FUNKNO,SUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Source calculation for a SPN approximation in BIVAC, including +* neighbour Legendre and out-of-group contributions. +* Raviart-Thomas method in Cartesian geometry. +* +*Copyright: +* Copyright (C) 2004 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* ITY type of assembly: +* =0: leakage-removal matrix assembly; =1: cross section matrix +* assembly. +* NREG total number of regions. +* IELEM degree of the Lagrangian finite elements: =1 (linear); +* =2 (parabolic); =3 (cubic); =4 (quartic). +* ICOL type of quadrature: =1 (analytical integration); +* =2 (Gauss-Lobatto); =3 (Gauss-Legendre). +* XX X-directed mesh spacings. +* YY Y-directed mesh spacings. +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* NBMIX number of mixtures. +* NLF number of Legendre orders for the flux (even number). +* NVD type of void boundary condition if NLF>0 and ICOL=3. +* NAN number of Legendre orders for the cross sections. +* SIGT macroscopic cross sections ordered by mixture. +* SIGT(:,NAN) generally contains the total cross section only. +* SIGTI inverse macroscopic cross sections ordered by mixture. +* SIGTI(:,NAN) generally contains the inverse total cross +* section only. +* L4 order of the profiled system matrices. +* KN element-ordered unknown list. +* QFR element-ordered boundary conditions. +* LC order of the unit matrices. +* R unit Cartesian mass matrix. +* V unit nodal coupling matrix. +* FUNKNO initial fluxes. +* SUNKNO initial sources. +* +*Parameters: output +* SUNKNO modified sources. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER ITY,NREG,IELEM,ICOL,MAT(NREG),NBMIX,NLF,NVD,NAN,L4, + 1 KN(5*NREG),LC + REAL XX(NREG),YY(NREG),VOL(NREG),SIGT(NBMIX,NAN),SIGTI(NBMIX,NAN), + 1 QFR(4*NREG),R(LC,LC),V(LC,LC-1),SUNKNO(L4*NLF/2),FUNKNO(L4*NLF/2) +*---- +* LOCAL VARIABLES +*---- + REAL QQ(5,5) +* + IF(ICOL.EQ.3) THEN + IF(NVD.EQ.0) THEN + NZMAR=NLF+1 + ELSE IF(NVD.EQ.1) THEN + NZMAR=NLF + ELSE IF(NVD.EQ.2) THEN + NZMAR=65 + ENDIF + ELSE + NZMAR=65 + ENDIF + DO 12 I0=1,IELEM + DO 11 J0=1,IELEM + QQ(I0,J0)=0.0 + DO 10 K0=2,IELEM + QQ(I0,J0)=QQ(I0,J0)+V(K0,I0)*V(K0,J0)/R(K0,K0) + 10 CONTINUE + 11 CONTINUE + 12 CONTINUE + DO 170 IL=0,NLF-1 + IF((ITY.EQ.1).AND.(IL.GE.NAN)) GO TO 170 + FACT=REAL(2*IL+1) +*---- +* COMPUTE THE SOURCE AT ORDER IL. +*---- + NUM1=0 + NUM2=0 + DO 160 K=1,NREG + IBM=MAT(K) + IF(IBM.EQ.0) GO TO 160 + VOL0=VOL(K) + GARS=SIGT(IBM,MIN(IL+1,NAN)) + IF(MOD(IL,2).EQ.0) THEN + DO 50 I0=1,IELEM + DO 20 J0=1,IELEM + JND1=(IL/2)*L4+KN(NUM1+1)+(I0-1)*IELEM+J0-1 + SUNKNO(JND1)=SUNKNO(JND1)+FACT*VOL0*GARS*FUNKNO(JND1) + 20 CONTINUE + IF(ITY.EQ.1) GO TO 50 +* + IND1=(IL/2)*L4+ABS(KN(NUM1+2))+I0-1 + IND2=(IL/2)*L4+ABS(KN(NUM1+3))+I0-1 + IND3=(IL/2)*L4+ABS(KN(NUM1+4))+I0-1 + IND4=(IL/2)*L4+ABS(KN(NUM1+5))+I0-1 + DO 30 J0=1,IELEM + JND1=(IL/2)*L4+KN(NUM1+1)+(I0-1)*IELEM+J0-1 + IF(KN(NUM1+2).NE.0) THEN + SG=REAL(SIGN(1,KN(NUM1+2))) + SUNKNO(JND1)=SUNKNO(JND1)+SG*REAL(IL+1)*VOL0*V(1,J0)* + 1 FUNKNO(IND1)/XX(K) + ENDIF + IF(KN(NUM1+3).NE.0) THEN + SG=REAL(SIGN(1,KN(NUM1+3))) + SUNKNO(JND1)=SUNKNO(JND1)+SG*REAL(IL+1)*VOL0*V(IELEM+1,J0)* + 1 FUNKNO(IND2)/XX(K) + ENDIF + JND1=(IL/2)*L4+KN(NUM1+1)+(J0-1)*IELEM+I0-1 + IF(KN(NUM1+4).NE.0) THEN + SG=REAL(SIGN(1,KN(NUM1+4))) + SUNKNO(JND1)=SUNKNO(JND1)+SG*REAL(IL+1)*VOL0*V(1,J0)* + 1 FUNKNO(IND3)/YY(K) + ENDIF + IF(KN(NUM1+5).NE.0) THEN + SG=REAL(SIGN(1,KN(NUM1+5))) + SUNKNO(JND1)=SUNKNO(JND1)+SG*REAL(IL+1)*VOL0*V(IELEM+1,J0)* + 1 FUNKNO(IND4)/YY(K) + ENDIF + 30 CONTINUE + IF(IL.GE.2) THEN + IND1=((IL-2)/2)*L4+ABS(KN(NUM1+2))+I0-1 + IND2=((IL-2)/2)*L4+ABS(KN(NUM1+3))+I0-1 + IND3=((IL-2)/2)*L4+ABS(KN(NUM1+4))+I0-1 + IND4=((IL-2)/2)*L4+ABS(KN(NUM1+5))+I0-1 + DO 40 J0=1,IELEM + JND1=(IL/2)*L4+KN(NUM1+1)+(I0-1)*IELEM+J0-1 + IF(KN(NUM1+2).NE.0) THEN + SG=REAL(SIGN(1,KN(NUM1+2))) + SUNKNO(JND1)=SUNKNO(JND1)+SG*REAL(IL)*VOL0*V(1,J0)* + 1 FUNKNO(IND1)/XX(K) + ENDIF + IF(KN(NUM1+3).NE.0) THEN + SG=REAL(SIGN(1,KN(NUM1+3))) + SUNKNO(JND1)=SUNKNO(JND1)+SG*REAL(IL)*VOL0*V(IELEM+1,J0)* + 1 FUNKNO(IND2)/XX(K) + ENDIF + JND1=(IL/2)*L4+KN(NUM1+1)+(J0-1)*IELEM+I0-1 + IF(KN(NUM1+4).NE.0) THEN + SG=REAL(SIGN(1,KN(NUM1+4))) + SUNKNO(JND1)=SUNKNO(JND1)+SG*REAL(IL)*VOL0*V(1,J0)* + 1 FUNKNO(IND3)/YY(K) + ENDIF + IF(KN(NUM1+5).NE.0) THEN + SG=REAL(SIGN(1,KN(NUM1+5))) + SUNKNO(JND1)=SUNKNO(JND1)+SG*REAL(IL)*VOL0*V(IELEM+1,J0)* + 1 FUNKNO(IND4)/YY(K) + ENDIF + 40 CONTINUE + ENDIF + 50 CONTINUE + ELSE IF(MOD(IL,2).EQ.1) THEN + GARSI=SIGTI(IBM,MIN(IL+1,NAN)) + DO 150 I0=1,IELEM +* PARTIAL INVERSION OF THE ODD PARITY EQUATION. MODIFICATION OF +* THE EVEN PARITY EQUATION. + IF(IELEM.GT.1) THEN + DO 65 J0=1,IELEM + DO 60 K0=1,IELEM + IF(QQ(J0,K0).EQ.0.0) GO TO 60 + JND1=(IL/2)*L4+KN(NUM1+1)+(I0-1)*IELEM+J0-1 + KND1=(IL/2)*L4+KN(NUM1+1)+(I0-1)*IELEM+K0-1 + SUNKNO(JND1)=SUNKNO(JND1)+(REAL(IL)**2)*VOL0*QQ(J0,K0)* + 1 GARSI*FUNKNO(KND1)/(FACT*XX(K)*XX(K)) + JND1=(IL/2)*L4+KN(NUM1+1)+(J0-1)*IELEM+I0-1 + KND1=(IL/2)*L4+KN(NUM1+1)+(K0-1)*IELEM+I0-1 + SUNKNO(JND1)=SUNKNO(JND1)+(REAL(IL)**2)*VOL0*QQ(J0,K0)* + 1 GARSI*FUNKNO(KND1)/(FACT*YY(K)*YY(K)) + IF(IL.LE.NLF-3) THEN + JND1=((IL+2)/2)*L4+KN(NUM1+1)+(I0-1)*IELEM+J0-1 + KND1=(IL/2)*L4+KN(NUM1+1)+(I0-1)*IELEM+K0-1 + SUNKNO(JND1)=SUNKNO(JND1)+(REAL(IL)*REAL(IL+1))*VOL0* + 1 QQ(J0,K0)*GARSI*FUNKNO(KND1)/(FACT*XX(K)*XX(K)) + JND1=((IL+2)/2)*L4+KN(NUM1+1)+(J0-1)*IELEM+I0-1 + KND1=(IL/2)*L4+KN(NUM1+1)+(K0-1)*IELEM+I0-1 + SUNKNO(JND1)=SUNKNO(JND1)+(REAL(IL)*REAL(IL+1))*VOL0* + 1 QQ(J0,K0)*GARSI*FUNKNO(KND1)/(FACT*YY(K)*YY(K)) + JND1=(IL/2)*L4+KN(NUM1+1)+(I0-1)*IELEM+J0-1 + KND1=((IL+2)/2)*L4+KN(NUM1+1)+(I0-1)*IELEM+K0-1 + SUNKNO(JND1)=SUNKNO(JND1)+(REAL(IL)*REAL(IL+1))*VOL0* + 1 QQ(J0,K0)*GARSI*FUNKNO(KND1)/(FACT*XX(K)*XX(K)) + JND1=(IL/2)*L4+KN(NUM1+1)+(J0-1)*IELEM+I0-1 + KND1=((IL+2)/2)*L4+KN(NUM1+1)+(K0-1)*IELEM+I0-1 + SUNKNO(JND1)=SUNKNO(JND1)+(REAL(IL)*REAL(IL+1))*VOL0* + 1 QQ(J0,K0)*GARSI*FUNKNO(KND1)/(FACT*YY(K)*YY(K)) + JND1=((IL+2)/2)*L4+KN(NUM1+1)+(I0-1)*IELEM+J0-1 + KND1=((IL+2)/2)*L4+KN(NUM1+1)+(I0-1)*IELEM+K0-1 + SUNKNO(JND1)=SUNKNO(JND1)+(REAL(IL+1)*REAL(IL+1))*VOL0* + 1 QQ(J0,K0)*GARSI*FUNKNO(KND1)/(FACT*XX(K)*XX(K)) + JND1=((IL+2)/2)*L4+KN(NUM1+1)+(J0-1)*IELEM+I0-1 + KND1=((IL+2)/2)*L4+KN(NUM1+1)+(K0-1)*IELEM+I0-1 + SUNKNO(JND1)=SUNKNO(JND1)+(REAL(IL+1)*REAL(IL+1))*VOL0* + 1 QQ(J0,K0)*GARSI*FUNKNO(KND1)/(FACT*YY(K)*YY(K)) + ENDIF + 60 CONTINUE + 65 CONTINUE + ENDIF +* ODD PARITY EQUATION. + DO 75 IC=1,2 + IIC=1 + IF(IC.EQ.2) IIC=IELEM+1 + IND1=(IL/2)*L4+ABS(KN(NUM1+1+IC))+I0-1 + S1=REAL(SIGN(1,KN(NUM1+1+IC))) + DO 70 JC=1,2 + JJC=1 + IF(JC.EQ.2) JJC=IELEM+1 + IND2=(IL/2)*L4+ABS(KN(NUM1+1+JC))+I0-1 + IF((KN(NUM1+1+IC).NE.0).AND.(KN(NUM1+1+JC).NE.0)) THEN + S2=REAL(SIGN(1,KN(NUM1+1+JC))) + SUNKNO(IND1)=SUNKNO(IND1)-S1*S2*FACT*R(IIC,JJC)*VOL0*GARS* + 1 FUNKNO(IND2) + ENDIF + 70 CONTINUE + 75 CONTINUE + DO 85 IC=3,4 + IF(IC.EQ.3) IIC=1 + IF(IC.EQ.4) IIC=IELEM+1 + IND1=(IL/2)*L4+ABS(KN(NUM1+1+IC))+I0-1 + S1=REAL(SIGN(1,KN(NUM1+1+IC))) + DO 80 JC=3,4 + IF(JC.EQ.3) JJC=1 + IF(JC.EQ.4) JJC=IELEM+1 + IND2=(IL/2)*L4+ABS(KN(NUM1+1+JC))+I0-1 + IF((KN(NUM1+1+IC).NE.0).AND.(KN(NUM1+1+JC).NE.0)) THEN + S2=REAL(SIGN(1,KN(NUM1+1+JC))) + SUNKNO(IND1)=SUNKNO(IND1)-S1*S2*FACT*R(IIC,JJC)*VOL0*GARS* + 1 FUNKNO(IND2) + ENDIF + 80 CONTINUE + 85 CONTINUE + IF(ITY.EQ.1) GO TO 150 +* + IND1=(IL/2)*L4+ABS(KN(NUM1+2))+I0-1 + IND2=(IL/2)*L4+ABS(KN(NUM1+3))+I0-1 + IND3=(IL/2)*L4+ABS(KN(NUM1+4))+I0-1 + IND4=(IL/2)*L4+ABS(KN(NUM1+5))+I0-1 + IF((QFR(NUM2+1).NE.0.0).AND.(KN(NUM1+2).NE.0)) THEN +* XINF SIDE. + DO 90 IL2=1,NLF-1,2 + ZMARS=PNMAR2(NZMAR,IL2,IL) + IND5=(IL2/2)*L4+ABS(KN(NUM1+2))+I0-1 + SUNKNO(IND1)=SUNKNO(IND1)-0.5*FACT*QFR(NUM2+1)*ZMARS* + 1 FUNKNO(IND5) + 90 CONTINUE + ENDIF + IF((QFR(NUM2+2).NE.0.0).AND.(KN(NUM1+3).NE.0)) THEN +* XSUP SIDE. + DO 100 IL2=1,NLF-1,2 + ZMARS=PNMAR2(NZMAR,IL2,IL) + IND5=(IL2/2)*L4+ABS(KN(NUM1+3))+I0-1 + SUNKNO(IND2)=SUNKNO(IND2)-0.5*FACT*QFR(NUM2+2)*ZMARS* + 1 FUNKNO(IND5) + 100 CONTINUE + ENDIF + IF((QFR(NUM2+3).NE.0.0).AND.(KN(NUM1+4).NE.0)) THEN +* YINF SIDE. + DO 110 IL2=1,NLF-1,2 + ZMARS=PNMAR2(NZMAR,IL2,IL) + IND5=(IL2/2)*L4+ABS(KN(NUM1+4))+I0-1 + SUNKNO(IND3)=SUNKNO(IND3)-0.5*FACT*QFR(NUM2+3)*ZMARS* + 1 FUNKNO(IND5) + 110 CONTINUE + ENDIF + IF((QFR(NUM2+4).NE.0.0).AND.(KN(NUM1+5).NE.0)) THEN +* YSUP SIDE. + DO 120 IL2=1,NLF-1,2 + ZMARS=PNMAR2(NZMAR,IL2,IL) + IND5=(IL2/2)*L4+ABS(KN(NUM1+5))+I0-1 + SUNKNO(IND4)=SUNKNO(IND4)-0.5*FACT*QFR(NUM2+4)*ZMARS* + 1 FUNKNO(IND5) + 120 CONTINUE + ENDIF +* + DO 130 J0=1,IELEM + JND1=(IL/2)*L4+KN(NUM1+1)+(I0-1)*IELEM+J0-1 + IF(KN(NUM1+2).NE.0) THEN + SG=REAL(SIGN(1,KN(NUM1+2))) + SUNKNO(IND1)=SUNKNO(IND1)+SG*REAL(IL)*VOL0*V(1,J0)* + 1 FUNKNO(JND1)/XX(K) + ENDIF + IF(KN(NUM1+3).NE.0) THEN + SG=REAL(SIGN(1,KN(NUM1+3))) + SUNKNO(IND2)=SUNKNO(IND2)+SG*REAL(IL)*VOL0*V(IELEM+1,J0)* + 1 FUNKNO(JND1)/XX(K) + ENDIF + JND1=(IL/2)*L4+KN(NUM1+1)+(J0-1)*IELEM+I0-1 + IF(KN(NUM1+4).NE.0) THEN + SG=REAL(SIGN(1,KN(NUM1+4))) + SUNKNO(IND3)=SUNKNO(IND3)+SG*REAL(IL)*VOL0*V(1,J0)* + 1 FUNKNO(JND1)/YY(K) + ENDIF + IF(KN(NUM1+5).NE.0) THEN + SG=REAL(SIGN(1,KN(NUM1+5))) + SUNKNO(IND4)=SUNKNO(IND4)+SG*REAL(IL)*VOL0*V(IELEM+1,J0)* + 1 FUNKNO(JND1)/YY(K) + ENDIF + 130 CONTINUE + IF(IL.LE.NLF-3) THEN + DO 140 J0=1,IELEM + JND1=((IL+2)/2)*L4+KN(NUM1+1)+(I0-1)*IELEM+J0-1 + IF(KN(NUM1+2).NE.0) THEN + SG=REAL(SIGN(1,KN(NUM1+2))) + SUNKNO(IND1)=SUNKNO(IND1)+SG*REAL(IL+1)*VOL0*V(1,J0)* + 1 FUNKNO(JND1)/XX(K) + ENDIF + IF(KN(NUM1+3).NE.0) THEN + SG=REAL(SIGN(1,KN(NUM1+3))) + SUNKNO(IND2)=SUNKNO(IND2)+SG*REAL(IL+1)*VOL0* + 1 V(IELEM+1,J0)*FUNKNO(JND1)/XX(K) + ENDIF + JND1=((IL+2)/2)*L4+KN(NUM1+1)+(J0-1)*IELEM+I0-1 + IF(KN(NUM1+4).NE.0) THEN + SG=REAL(SIGN(1,KN(NUM1+4))) + SUNKNO(IND3)=SUNKNO(IND3)+SG*REAL(IL+1)*VOL0*V(1,J0)* + 1 FUNKNO(JND1)/YY(K) + ENDIF + IF(KN(NUM1+5).NE.0) THEN + SG=REAL(SIGN(1,KN(NUM1+5))) + SUNKNO(IND4)=SUNKNO(IND4)+SG*REAL(IL+1)*VOL0* + 1 V(IELEM+1,J0)*FUNKNO(JND1)/YY(K) + ENDIF + 140 CONTINUE + ENDIF + 150 CONTINUE + ENDIF + NUM1=NUM1+5 + NUM2=NUM2+4 + 160 CONTINUE + 170 CONTINUE + RETURN + END diff --git a/Trivac/src/PNSZ3D.f b/Trivac/src/PNSZ3D.f new file mode 100755 index 0000000..b191a18 --- /dev/null +++ b/Trivac/src/PNSZ3D.f @@ -0,0 +1,482 @@ +*DECK PNSZ3D + SUBROUTINE PNSZ3D(ITY,IPR,NREG,IELEM,ICOL,XX,YY,ZZ,MAT,VOL,NBMIX, + 1 NLF,NVD,NAN,SIGT,SIGTI,L4,KN,QFR,LC,R,V,FUNKNO,SUNKNO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Source calculation for a SPN approximation in TRIVAC, including +* neighbour Legendre and out-of-group contributions. +* Raviart-Thomas method in Cartesian geometry. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* ITY type of assembly: +* =0: leakage-removal matrix assembly; =1: cross section matrix +* assembly. +* IPR type of assembly: +* =0: contains system matrices; +* =1: contains derivative of these matrices; +* =2: contains first variation of these matrices; +* =3: contains addition of first vatiation to unperturbed +* system matrices. +* NREG total number of regions. +* IELEM degree of the Lagrangian finite elements: =1 (linear); +* =2 (parabolic); =3 (cubic); =4 (quartic). +* ICOL type of quadrature: =1 (analytical integration); +* =2 (Gauss-Lobatto); =3 (Gauss-Legendre). +* XX X-directed mesh spacings. +* YY Y-directed mesh spacings. +* ZZ Z-directed mesh spacings. +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* NBMIX number of mixtures. +* NLF number of Legendre orders for the flux (even number). +* NVD type of void boundary condition if NLF>0 and ICOL=3. +* NAN number of Legendre orders for the cross sections. +* SIGT macroscopic cross sections ordered by mixture. +* SIGT(:,NAN) generally contains the total cross section only. +* SIGTI inverse macroscopic cross sections ordered by mixture. +* SIGTI(:,NAN) generally contains the inverse total cross +* section only. +* L4 order of the profiled system matrices. +* KN element-ordered unknown list. +* QFR element-ordered boundary conditions. +* LC order of the unit matrices. +* R unit Cartesian mass matrix. +* V unit nodal coupling matrix. +* FUNKNO initial fluxes. +* SUNKNO initial sources. +* +*Parameters: output +* SUNKNO modified sources. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER ITY,IPR,NREG,IELEM,ICOL,MAT(NREG),NBMIX,NLF,NVD,NAN,L4, + 1 KN(NREG*(1+6*IELEM**2)),LC + REAL XX(NREG),YY(NREG),ZZ(NREG),VOL(NREG),SIGT(NBMIX,NAN), + 1 SIGTI(NBMIX,NAN),QFR(6*NREG),R(LC,LC),V(LC,LC-1), + 2 SUNKNO(L4*NLF/2),FUNKNO(L4*NLF/2) +*---- +* LOCAL VARIABLES +*---- + REAL QQ(5,5) +* + IF(ICOL.EQ.3) THEN + IF(NVD.EQ.0) THEN + NZMAR=NLF+1 + ELSE IF(NVD.EQ.1) THEN + NZMAR=NLF + ELSE IF(NVD.EQ.2) THEN + NZMAR=65 + ENDIF + ELSE + NZMAR=65 + ENDIF + DO 12 I0=1,IELEM + DO 11 J0=1,IELEM + QQ(I0,J0)=0.0 + DO 10 K0=2,IELEM + QQ(I0,J0)=QQ(I0,J0)+V(K0,I0)*V(K0,J0)/R(K0,K0) + 10 CONTINUE + 11 CONTINUE + 12 CONTINUE + DO 200 IL=0,NLF-1 + IF((ITY.EQ.1).AND.(IL.GE.NAN)) GO TO 200 + FACT=REAL(2*IL+1) +*---- +* COMPUTE THE SOURCE AT ORDER IL. +*---- + NUM1=0 + NUM2=0 + DO 190 K=1,NREG + IBM=MAT(K) + IF(IBM.EQ.0) GO TO 190 + VOL0=VOL(K) + GARS=SIGT(IBM,MIN(IL+1,NAN)) + IF(MOD(IL,2).EQ.0) THEN +* EVEN PARITY EQUATION + DO 55 K3=0,IELEM-1 + DO 50 K2=0,IELEM-1 + DO 20 K1=0,IELEM-1 + JND1=(IL/2)*L4+KN(NUM1+1)+(K3*IELEM+K2)*IELEM+K1 + SUNKNO(JND1)=SUNKNO(JND1)+FACT*VOL0*GARS*FUNKNO(JND1) + 20 CONTINUE + IF(ITY.EQ.1) GO TO 50 + IF((IPR.EQ.1).OR.(IPR.EQ.2)) GO TO 50 +* + KN1=KN(NUM1+2+K3*IELEM+K2) + KN2=KN(NUM1+2+IELEM**2+K3*IELEM+K2) + KN3=KN(NUM1+2+2*IELEM**2+K3*IELEM+K2) + KN4=KN(NUM1+2+3*IELEM**2+K3*IELEM+K2) + KN5=KN(NUM1+2+4*IELEM**2+K3*IELEM+K2) + KN6=KN(NUM1+2+5*IELEM**2+K3*IELEM+K2) + IND1=(IL/2)*L4+ABS(KN1) + IND2=(IL/2)*L4+ABS(KN2) + IND3=(IL/2)*L4+ABS(KN3) + IND4=(IL/2)*L4+ABS(KN4) + IND5=(IL/2)*L4+ABS(KN5) + IND6=(IL/2)*L4+ABS(KN6) + DO 30 K1=0,IELEM-1 + JND1=(IL/2)*L4+KN(NUM1+1)+(K3*IELEM+K2)*IELEM+K1 + IF(KN1.NE.0) THEN + SG=REAL(SIGN(1,KN1)) + SUNKNO(JND1)=SUNKNO(JND1)+SG*REAL(IL+1)*VOL0*V(1,K1+1)* + 1 FUNKNO(IND1)/XX(K) + ENDIF + IF(KN2.NE.0) THEN + SG=REAL(SIGN(1,KN2)) + SUNKNO(JND1)=SUNKNO(JND1)+SG*REAL(IL+1)*VOL0*V(IELEM+1,K1+1) + 1 *FUNKNO(IND2)/XX(K) + ENDIF + JND1=(IL/2)*L4+KN(NUM1+1)+(K3*IELEM+K1)*IELEM+K2 + IF(KN3.NE.0) THEN + SG=REAL(SIGN(1,KN3)) + SUNKNO(JND1)=SUNKNO(JND1)+SG*REAL(IL+1)*VOL0*V(1,K1+1)* + 1 FUNKNO(IND3)/YY(K) + ENDIF + IF(KN4.NE.0) THEN + SG=REAL(SIGN(1,KN4)) + SUNKNO(JND1)=SUNKNO(JND1)+SG*REAL(IL+1)*VOL0*V(IELEM+1,K1+1) + 1 *FUNKNO(IND4)/YY(K) + ENDIF + JND1=(IL/2)*L4+KN(NUM1+1)+(K1*IELEM+K3)*IELEM+K2 + IF(KN5.NE.0) THEN + SG=REAL(SIGN(1,KN5)) + SUNKNO(JND1)=SUNKNO(JND1)+SG*REAL(IL+1)*VOL0*V(1,K1+1)* + 1 FUNKNO(IND5)/ZZ(K) + ENDIF + IF(KN6.NE.0) THEN + SG=REAL(SIGN(1,KN6)) + SUNKNO(JND1)=SUNKNO(JND1)+SG*REAL(IL+1)*VOL0*V(IELEM+1,K1+1) + 1 *FUNKNO(IND6)/ZZ(K) + ENDIF + 30 CONTINUE + IF(IL.GE.2) THEN + KN1=KN(NUM1+2+K3*IELEM+K2) + KN2=KN(NUM1+2+IELEM**2+K3*IELEM+K2) + KN3=KN(NUM1+2+2*IELEM**2+K3*IELEM+K2) + KN4=KN(NUM1+2+3*IELEM**2+K3*IELEM+K2) + KN5=KN(NUM1+2+4*IELEM**2+K3*IELEM+K2) + KN6=KN(NUM1+2+5*IELEM**2+K3*IELEM+K2) + IND1=((IL-2)/2)*L4+ABS(KN1) + IND2=((IL-2)/2)*L4+ABS(KN2) + IND3=((IL-2)/2)*L4+ABS(KN3) + IND4=((IL-2)/2)*L4+ABS(KN4) + IND5=((IL-2)/2)*L4+ABS(KN5) + IND6=((IL-2)/2)*L4+ABS(KN6) + DO 40 K1=0,IELEM-1 + JND1=(IL/2)*L4+KN(NUM1+1)+(K3*IELEM+K2)*IELEM+K1 + IF(KN1.NE.0) THEN + SG=REAL(SIGN(1,KN1)) + SUNKNO(JND1)=SUNKNO(JND1)+SG*REAL(IL)*VOL0*V(1,K1+1)* + 1 FUNKNO(IND1)/XX(K) + ENDIF + IF(KN2.NE.0) THEN + SG=REAL(SIGN(1,KN2)) + SUNKNO(JND1)=SUNKNO(JND1)+SG*REAL(IL)*VOL0* + 1 V(IELEM+1,K1+1)*FUNKNO(IND2)/XX(K) + ENDIF + JND1=(IL/2)*L4+KN(NUM1+1)+(K3*IELEM+K1)*IELEM+K2 + IF(KN3.NE.0) THEN + SG=REAL(SIGN(1,KN3)) + SUNKNO(JND1)=SUNKNO(JND1)+SG*REAL(IL)*VOL0*V(1,K1+1)* + 1 FUNKNO(IND3)/YY(K) + ENDIF + IF(KN4.NE.0) THEN + SG=REAL(SIGN(1,KN4)) + SUNKNO(JND1)=SUNKNO(JND1)+SG*REAL(IL)*VOL0* + 1 V(IELEM+1,K1+1)*FUNKNO(IND4)/YY(K) + ENDIF + JND1=(IL/2)*L4+KN(NUM1+1)+(K1*IELEM+K3)*IELEM+K2 + IF(KN5.NE.0) THEN + SG=REAL(SIGN(1,KN5)) + SUNKNO(JND1)=SUNKNO(JND1)+SG*REAL(IL)*VOL0*V(1,K1+1)* + 1 FUNKNO(IND5)/ZZ(K) + ENDIF + IF(KN6.NE.0) THEN + SG=REAL(SIGN(1,KN6)) + SUNKNO(JND1)=SUNKNO(JND1)+SG*REAL(IL)*VOL0* + 1 V(IELEM+1,K1+1)*FUNKNO(IND6)/ZZ(K) + ENDIF + 40 CONTINUE + ENDIF + 50 CONTINUE + 55 CONTINUE + ELSE IF(MOD(IL,2).EQ.1) THEN + GARSI=SIGTI(IBM,MIN(IL+1,NAN)) + DO 185 K3=0,IELEM-1 + DO 180 K2=0,IELEM-1 +* PARTIAL INVERSION OF THE ODD PARITY EQUATION. MODIFICATION OF +* THE EVEN PARITY EQUATION. + IF(IELEM.GT.1) THEN + DO 60 K1=0,IELEM-1 + IF(QQ(K1+1,K1+1).EQ.0.0) GO TO 60 + JND1=(IL/2)*L4+KN(NUM1+1)+(K3*IELEM+K2)*IELEM+K1 + SUNKNO(JND1)=SUNKNO(JND1)+(REAL(IL)**2)*VOL0*QQ(K1+1,K1+1)* + 1 GARSI*FUNKNO(JND1)/(FACT*XX(K)*XX(K)) +* + JND1=(IL/2)*L4+KN(NUM1+1)+(K3*IELEM+K1)*IELEM+K2 + SUNKNO(JND1)=SUNKNO(JND1)+(REAL(IL)**2)*VOL0* + 1 QQ(K1+1,K1+1)*GARSI*FUNKNO(JND1)/(FACT*YY(K)*YY(K)) +* + JND1=(IL/2)*L4+KN(NUM1+1)+(K1*IELEM+K3)*IELEM+K2 + SUNKNO(JND1)=SUNKNO(JND1)+(REAL(IL)**2)*VOL0* + 1 QQ(K1+1,K1+1)*GARSI*FUNKNO(JND1)/(FACT*ZZ(K)*ZZ(K)) + IF(IL.LE.NLF-3) THEN + JND1=((IL+2)/2)*L4+KN(NUM1+1)+(K3*IELEM+K2)*IELEM+K1 + KND1=(IL/2)*L4+KN(NUM1+1)+(K3*IELEM+K2)*IELEM+K1 + SUNKNO(JND1)=SUNKNO(JND1)+(REAL(IL)*REAL(IL+1))*VOL0* + 1 QQ(K1+1,K1+1)*GARSI*FUNKNO(KND1)/(FACT*XX(K)*XX(K)) + JND1=(IL/2)*L4+KN(NUM1+1)+(K3*IELEM+K2)*IELEM+K1 + KND1=((IL+2)/2)*L4+KN(NUM1+1)+(K3*IELEM+K2)*IELEM+K1 + SUNKNO(JND1)=SUNKNO(JND1)+(REAL(IL)*REAL(IL+1))*VOL0* + 1 QQ(K1+1,K1+1)*GARSI*FUNKNO(KND1)/(FACT*XX(K)*XX(K)) + JND1=((IL+2)/2)*L4+KN(NUM1+1)+(K3*IELEM+K2)*IELEM+K1 + SUNKNO(JND1)=SUNKNO(JND1)+(REAL(IL+1)*REAL(IL+1))*VOL0* + 1 QQ(K1+1,K1+1)*GARSI*FUNKNO(JND1)/(FACT*XX(K)*XX(K)) +* + JND1=((IL+2)/2)*L4+KN(NUM1+1)+(K3*IELEM+K1)*IELEM+K2 + KND1=(IL/2)*L4+KN(NUM1+1)+(K3*IELEM+K1)*IELEM+K2 + SUNKNO(JND1)=SUNKNO(JND1)+(REAL(IL)*REAL(IL+1))*VOL0* + 1 QQ(K1+1,K1+1)*GARSI*FUNKNO(KND1)/(FACT*YY(K)*YY(K)) + JND1=(IL/2)*L4+KN(NUM1+1)+(K3*IELEM+K1)*IELEM+K2 + KND1=((IL+2)/2)*L4+KN(NUM1+1)+(K3*IELEM+K1)*IELEM+K2 + SUNKNO(JND1)=SUNKNO(JND1)+(REAL(IL)*REAL(IL+1))*VOL0* + 1 QQ(K1+1,K1+1)*GARSI*FUNKNO(KND1)/(FACT*YY(K)*YY(K)) + JND1=((IL+2)/2)*L4+KN(NUM1+1)+(K3*IELEM+K1)*IELEM+K2 + SUNKNO(JND1)=SUNKNO(JND1)+(REAL(IL+1)*REAL(IL+1))*VOL0* + 1 QQ(K1+1,K1+1)*GARSI*FUNKNO(JND1)/(FACT*YY(K)*YY(K)) +* + JND1=((IL+2)/2)*L4+KN(NUM1+1)+(K1*IELEM+K3)*IELEM+K2 + KND1=(IL/2)*L4+KN(NUM1+1)+(K1*IELEM+K3)*IELEM+K2 + SUNKNO(JND1)=SUNKNO(JND1)+(REAL(IL)*REAL(IL+1))*VOL0* + 1 QQ(K1+1,K1+1)*GARSI*FUNKNO(KND1)/(FACT*ZZ(K)*ZZ(K)) + JND1=(IL/2)*L4+KN(NUM1+1)+(K1*IELEM+K3)*IELEM+K2 + KND1=((IL+2)/2)*L4+KN(NUM1+1)+(K1*IELEM+K3)*IELEM+K2 + SUNKNO(JND1)=SUNKNO(JND1)+(REAL(IL)*REAL(IL+1))*VOL0* + 1 QQ(K1+1,K1+1)*GARSI*FUNKNO(KND1)/(FACT*ZZ(K)*ZZ(K)) + JND1=((IL+2)/2)*L4+KN(NUM1+1)+(K1*IELEM+K3)*IELEM+K2 + SUNKNO(JND1)=SUNKNO(JND1)+(REAL(IL+1)*REAL(IL+1))*VOL0* + 1 QQ(K1+1,K1+1)*GARSI*FUNKNO(JND1)/(FACT*ZZ(K)*ZZ(K)) + ENDIF + 60 CONTINUE + ENDIF +* ODD PARITY EQUATION. + DO 75 IC=1,2 + IF(IC.EQ.1) IIC=1 + IF(IC.EQ.2) IIC=IELEM+1 + KN1=KN(NUM1+2+(IC-1)*IELEM**2+K3*IELEM+K2) + IND1=(IL/2)*L4+ABS(KN1) + S1=REAL(SIGN(1,KN1)) + DO 70 JC=1,2 + KN2=KN(NUM1+2+(JC-1)*IELEM**2+K3*IELEM+K2) + IF((KN1.NE.0).AND.(KN2.NE.0)) THEN + JJC=1 + IF(JC.EQ.2) JJC=IELEM+1 + IND2=(IL/2)*L4+ABS(KN2) + S2=REAL(SIGN(1,KN2)) + SUNKNO(IND1)=SUNKNO(IND1)-S1*S2*FACT*R(IIC,JJC)*VOL0*GARS* + 1 FUNKNO(IND2) + ENDIF + 70 CONTINUE + 75 CONTINUE + DO 85 IC=3,4 + IF(IC.EQ.3) IIC=1 + IF(IC.EQ.4) IIC=IELEM+1 + KN1=KN(NUM1+2+(IC-1)*IELEM**2+K3*IELEM+K2) + IND1=(IL/2)*L4+ABS(KN1) + S1=REAL(SIGN(1,KN1)) + DO 80 JC=3,4 + KN2=KN(NUM1+2+(JC-1)*IELEM**2+K3*IELEM+K2) + IF((KN1.NE.0).AND.(KN2.NE.0)) THEN + JJC=1 + IF(JC.EQ.4) JJC=IELEM+1 + IND2=(IL/2)*L4+ABS(KN2) + S2=REAL(SIGN(1,KN2)) + SUNKNO(IND1)=SUNKNO(IND1)-S1*S2*FACT*R(IIC,JJC)*VOL0*GARS* + 1 FUNKNO(IND2) + ENDIF + 80 CONTINUE + 85 CONTINUE + DO 95 IC=5,6 + IF(IC.EQ.5) IIC=1 + IF(IC.EQ.6) IIC=IELEM+1 + KN1=KN(NUM1+2+(IC-1)*IELEM**2+K3*IELEM+K2) + IND1=(IL/2)*L4+ABS(KN1) + S1=REAL(SIGN(1,KN1)) + DO 90 JC=5,6 + KN2=KN(NUM1+2+(JC-1)*IELEM**2+K3*IELEM+K2) + IF((KN1.NE.0).AND.(KN2.NE.0)) THEN + JJC=1 + IF(JC.EQ.6) JJC=IELEM+1 + IND2=(IL/2)*L4+ABS(KN2) + S2=REAL(SIGN(1,KN2)) + SUNKNO(IND1)=SUNKNO(IND1)-S1*S2*FACT*R(IIC,JJC)*VOL0*GARS* + 1 FUNKNO(IND2) + ENDIF + 90 CONTINUE + 95 CONTINUE + IF(ITY.EQ.1) GO TO 180 +* + KN1=KN(NUM1+2+K3*IELEM+K2) + KN2=KN(NUM1+2+IELEM**2+K3*IELEM+K2) + KN3=KN(NUM1+2+2*IELEM**2+K3*IELEM+K2) + KN4=KN(NUM1+2+3*IELEM**2+K3*IELEM+K2) + KN5=KN(NUM1+2+4*IELEM**2+K3*IELEM+K2) + KN6=KN(NUM1+2+5*IELEM**2+K3*IELEM+K2) + IND1=(IL/2)*L4+ABS(KN1) + IND2=(IL/2)*L4+ABS(KN2) + IND3=(IL/2)*L4+ABS(KN3) + IND4=(IL/2)*L4+ABS(KN4) + IND5=(IL/2)*L4+ABS(KN5) + IND6=(IL/2)*L4+ABS(KN6) + IF((QFR(NUM2+1).NE.0.0).AND.(KN1.NE.0)) THEN +* XINF SIDE. + DO 100 IL2=1,NLF-1,2 + ZMARS=PNMAR2(NZMAR,IL2,IL) + INDL=(IL2/2)*L4+ABS(KN1) + SUNKNO(IND1)=SUNKNO(IND1)-0.5*FACT*QFR(NUM2+1)*ZMARS* + 1 FUNKNO(INDL) + 100 CONTINUE + ENDIF + IF((QFR(NUM2+2).NE.0.0).AND.(KN2.NE.0)) THEN +* XSUP SIDE. + DO 110 IL2=1,NLF-1,2 + ZMARS=PNMAR2(NZMAR,IL2,IL) + INDL=(IL2/2)*L4+ABS(KN2) + SUNKNO(IND2)=SUNKNO(IND2)-0.5*FACT*QFR(NUM2+2)*ZMARS* + 1 FUNKNO(INDL) + 110 CONTINUE + ENDIF + IF((QFR(NUM2+3).NE.0.0).AND.(KN3.NE.0)) THEN +* YINF SIDE. + DO 120 IL2=1,NLF-1,2 + ZMARS=PNMAR2(NZMAR,IL2,IL) + INDL=(IL2/2)*L4+ABS(KN3) + SUNKNO(IND3)=SUNKNO(IND3)-0.5*FACT*QFR(NUM2+3)*ZMARS* + 1 FUNKNO(INDL) + 120 CONTINUE + ENDIF + IF((QFR(NUM2+4).NE.0.0).AND.(KN4.NE.0)) THEN +* YSUP SIDE. + DO 130 IL2=1,NLF-1,2 + ZMARS=PNMAR2(NZMAR,IL2,IL) + INDL=(IL2/2)*L4+ABS(KN4) + SUNKNO(IND4)=SUNKNO(IND4)-0.5*FACT*QFR(NUM2+4)*ZMARS* + 1 FUNKNO(INDL) + 130 CONTINUE + ENDIF + IF((QFR(NUM2+5).NE.0.0).AND.(KN5.NE.0)) THEN +* ZINF SIDE. + DO 140 IL2=1,NLF-1,2 + ZMARS=PNMAR2(NZMAR,IL2,IL) + INDL=(IL2/2)*L4+ABS(KN5) + SUNKNO(IND5)=SUNKNO(IND5)-0.5*FACT*QFR(NUM2+5)*ZMARS* + 1 FUNKNO(INDL) + 140 CONTINUE + ENDIF + IF((QFR(NUM2+6).NE.0.0).AND.(KN6.NE.0)) THEN +* ZSUP SIDE. + DO 150 IL2=1,NLF-1,2 + ZMARS=PNMAR2(NZMAR,IL2,IL) + INDL=(IL2/2)*L4+ABS(KN6) + SUNKNO(IND6)=SUNKNO(IND6)-0.5*FACT*QFR(NUM2+6)*ZMARS* + 1 FUNKNO(INDL) + 150 CONTINUE + ENDIF +* + IF((IPR.EQ.1).OR.(IPR.EQ.2)) GO TO 180 + DO 160 K1=0,IELEM-1 + JND1=(IL/2)*L4+KN(NUM1+1)+(K3*IELEM+K2)*IELEM+K1 + IF(KN1.NE.0) THEN + SG=REAL(SIGN(1,KN1)) + SUNKNO(IND1)=SUNKNO(IND1)+SG*REAL(IL)*VOL0*V(1,K1+1)* + 1 FUNKNO(JND1)/XX(K) + ENDIF + IF(KN2.NE.0) THEN + SG=REAL(SIGN(1,KN2)) + SUNKNO(IND2)=SUNKNO(IND2)+SG*REAL(IL)*VOL0*V(IELEM+1,K1+1)* + 1 FUNKNO(JND1)/XX(K) + ENDIF + JND1=(IL/2)*L4+KN(NUM1+1)+(K3*IELEM+K1)*IELEM+K2 + IF(KN3.NE.0) THEN + SG=REAL(SIGN(1,KN3)) + SUNKNO(IND3)=SUNKNO(IND3)+SG*REAL(IL)*VOL0*V(1,K1+1)* + 1 FUNKNO(JND1)/YY(K) + ENDIF + IF(KN4.NE.0) THEN + SG=REAL(SIGN(1,KN4)) + SUNKNO(IND4)=SUNKNO(IND4)+SG*REAL(IL)*VOL0*V(IELEM+1,K1+1)* + 1 FUNKNO(JND1)/YY(K) + ENDIF + JND1=(IL/2)*L4+KN(NUM1+1)+(K1*IELEM+K3)*IELEM+K2 + IF(KN5.NE.0) THEN + SG=REAL(SIGN(1,KN5)) + SUNKNO(IND5)=SUNKNO(IND5)+SG*REAL(IL)*VOL0*V(1,K1+1)* + 1 FUNKNO(JND1)/ZZ(K) + ENDIF + IF(KN6.NE.0) THEN + SG=REAL(SIGN(1,KN6)) + SUNKNO(IND6)=SUNKNO(IND6)+SG*REAL(IL)*VOL0*V(IELEM+1,K1+1)* + 1 FUNKNO(JND1)/ZZ(K) + ENDIF + 160 CONTINUE + IF(IL.LE.NLF-3) THEN + DO 170 K1=0,IELEM-1 + JND1=((IL+2)/2)*L4+KN(NUM1+1)+(K3*IELEM+K2)*IELEM+K1 + IF(KN1.NE.0) THEN + SG=REAL(SIGN(1,KN1)) + SUNKNO(IND1)=SUNKNO(IND1)+SG*REAL(IL+1)*VOL0*V(1,K1+1)* + 1 FUNKNO(JND1)/XX(K) + ENDIF + IF(KN2.NE.0) THEN + SG=REAL(SIGN(1,KN2)) + SUNKNO(IND2)=SUNKNO(IND2)+SG*REAL(IL+1)*VOL0* + 1 V(IELEM+1,K1+1)*FUNKNO(JND1)/XX(K) + ENDIF + JND1=((IL+2)/2)*L4+KN(NUM1+1)+(K3*IELEM+K1)*IELEM+K2 + IF(KN3.NE.0) THEN + SG=REAL(SIGN(1,KN3)) + SUNKNO(IND3)=SUNKNO(IND3)+SG*REAL(IL+1)*VOL0*V(1,K1+1)* + 1 FUNKNO(JND1)/YY(K) + ENDIF + IF(KN4.NE.0) THEN + SG=REAL(SIGN(1,KN4)) + SUNKNO(IND4)=SUNKNO(IND4)+SG*REAL(IL+1)*VOL0* + 1 V(IELEM+1,K1+1)*FUNKNO(JND1)/YY(K) + ENDIF + JND1=((IL+2)/2)*L4+KN(NUM1+1)+(K1*IELEM+K3)*IELEM+K2 + IF(KN5.NE.0) THEN + SG=REAL(SIGN(1,KN5)) + SUNKNO(IND5)=SUNKNO(IND5)+SG*REAL(IL+1)*VOL0*V(1,K1+1)* + 1 FUNKNO(JND1)/ZZ(K) + ENDIF + IF(KN6.NE.0) THEN + SG=REAL(SIGN(1,KN6)) + SUNKNO(IND6)=SUNKNO(IND6)+SG*REAL(IL+1)*VOL0* + 1 V(IELEM+1,K1+1)*FUNKNO(JND1)/ZZ(K) + ENDIF + 170 CONTINUE + ENDIF + 180 CONTINUE + 185 CONTINUE + ENDIF + NUM1=NUM1+1+6*IELEM**2 + NUM2=NUM2+6 + 190 CONTINUE + 200 CONTINUE + RETURN + END diff --git a/Trivac/src/READ3D.f b/Trivac/src/READ3D.f new file mode 100755 index 0000000..ba0385d --- /dev/null +++ b/Trivac/src/READ3D.f @@ -0,0 +1,420 @@ +*DECK READ3D + SUBROUTINE READ3D (MAXX,MAXY,MAXZ,MAXPTS,IPGEOM,IHEX,IR,ILK,SIDE, + 1 XXX,YYY,ZZZ,IMPX,LX,LY,LZ,MAT,NMBLK,NCODE,ICODE,ZCODE,ISPLTX, + 2 ISPLTY,ISPLTZ,ISPLTH,ISPLTL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover the input data for the description of a 1-D, 2-D or 3-D +* Cartesian, cylindrical, spherical or hexagonal domain. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s):A. Hebert +* +*Parameters: input/output +* MAXX allocated storage for arrays of dimension LX. +* MAXY allocated storage for arrays of dimension LY. +* MAXZ allocated storage for arrays of dimension LZ. +* MAXPTS allocated storage for arrays of dimension NMBLK. +* IPGEOM L_GEOM pointer to the geometry. +* IHEX type of hexagonal geometry (=0 for non-hexagonal geometry). +* IR number of mixtures. +* ILK (ILK=.true. if neutron leakage through external boundary +* is present). +* SIDE side of the hexagons. XXX and YYY arrays are not used with +* hexagonal geometry. +* XXX Cartesian coordinates of the domain along the X-axis. +* YYY Cartesian coordinates of the domain along the Y-axis. +* ZZZ Cartesian coordinates of the domain along the Z-axis. +* IMPX print flag. Minimum printing if IMPX=0. +* LX number of elements along the X-axis after mesh-splitting +* or number of hexagons in one axial plane. +* LY number of elements along the Y-axis. +* LZ number of elements along the Z-axis. +* MAT index-number of the mixture type assigned to each volume +* after mesh-splitting. +* NMBLK number of elements in the domain. +* NCODE boundary condition relative to each side of the domain: +* =1: VOID ; =2: REFL ; =3: DIAG ; =4: TRAN ; =5: SYME +* =6: ALBE ; =7: ZERO ; =20: CYLI. +* ICODE physical albedo index on each side of the domain. +* ZCODE albedo relative to each side of the domain. +* ISPLTX mesh-splitting data for parallelepipeds along the X-axis +* negative value is used for equal-volume splitting of tubes. +* ISPLTY mesh-splitting data for parallelepipeds along the Y-axis. +* ISPLTZ mesh-splitting data for parallelepipeds along the Z-axis. +* ISPLTH mesh-splitting index for hexagons into triangles. +* ISPLTL mesh-splitting index for hexagons into lozenges. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPGEOM + INTEGER MAXX,MAXY,MAXZ,MAXPTS,IHEX,IR,IMPX,LX,LY,LZ,MAT(MAXPTS), + 1 NMBLK,NCODE(6),ICODE(6),ISPLTX(MAXX),ISPLTY(MAXY),ISPLTZ(MAXZ), + 2 ISPLTH,ISPLTL + REAL SIDE,XXX(MAXX+1),YYY(MAXY+1),ZZZ(MAXZ+1),ZCODE(6) + LOGICAL ILK + INTEGER, ALLOCATABLE, DIMENSION(:) :: DPP,MX +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + LOGICAL LL1,LL2,LCYL,SWCEN,EMPTY,LCM + CHARACTER HSMG*131,GEONAM*12,TEXT12*12 + INTEGER ISTATE(NSTATE) + EQUIVALENCE (ITYPE,ISTATE(1)),(LR1,ISTATE(2)),(LX1,ISTATE(3)), + 1 (LY1,ISTATE(4)),(LZ1,ISTATE(5)) +* + IHEX=0 + CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE) + IF((ITYPE.EQ.8).OR.(ITYPE.EQ.9)) THEN + CALL LCMLEN(IPGEOM,'IHEX',ILEN,ITYLCM) + IF(ILEN.EQ.0) CALL LCMLIB(IPGEOM) + IF(ILEN.EQ.0) CALL XABORT('READ3D: MISSING IHEX RECORD.') + CALL LCMGET(IPGEOM,'IHEX',IHEX) + ENDIF + IF((ISTATE(8).NE.0).OR.(ISTATE(9).NE.0).OR.(ISTATE(10).NE.0).OR. + 1 (ISTATE(13).NE.0)) CALL XABORT('READ3D: UNABLE TO PROCESS THE G' + 2 //'EOMETRY.') + LCYL=(ITYPE.EQ.3).OR.(ITYPE.EQ.4).OR.(ITYPE.EQ.6) + IDIM=1 + IF((ITYPE.EQ.5).OR.(ITYPE.EQ.6).OR.(ITYPE.EQ.8)) IDIM=2 + IF((ITYPE.EQ.7).OR.(ITYPE.EQ.9)) IDIM=3 +*---- +* RECOVER THE BOUNDARY CONDITIONS +*---- + CALL LCMGET(IPGEOM,'NCODE',NCODE) + CALL LCMGET(IPGEOM,'ZCODE',ZCODE) + CALL LCMGET(IPGEOM,'ICODE',ICODE) + DO 10 I=1,6 + IF(NCODE(I).EQ.10) NCODE(I)=2 + IF(NCODE(I).EQ.2) ZCODE(I)=1.0 + IF(NCODE(I).EQ.6) NCODE(I)=1 + IF((NCODE(I).EQ.20).AND.(ITYPE.NE.5).AND.(ITYPE.NE.7)) CALL + 1 XABORT('READ3D: CYLINDRICAL CORRECTION IS LIMITED TO CARTESIAN ' + 2 //'GEOMETRIES.') + IF((NCODE(I).GE.8).AND.(NCODE(I).NE.20)) THEN + CALL XABORT('READ3D: INVALID TYPE OF B.C.') + ENDIF + 10 CONTINUE +*---- +* CHECK COHERENCE OF THE CYLINDRICAL EXTERNAL B.C. +*---- + SWCEN=.FALSE. + ALBMAX=-1.0E35 + ALBMIN=+1.0E35 + DO 15 IC=1,6 + IF(NCODE(IC).NE.20) GO TO 15 + SWCEN=.TRUE. + IF(ZCODE(IC).LT.ALBMIN) ALBMIN=ZCODE(IC) + IF(ZCODE(IC).GT.ALBMAX) ALBMAX=ZCODE(IC) + 15 CONTINUE + IF(SWCEN.AND.(ALBMIN.NE.ALBMAX)) CALL XABORT('READ3D: CYLINDRICA' + 1 //'L IMBEDDED EXTERNAL GEOMETRY: ALBEDOS ARE INCONSISTENT.') +* + IF(ITYPE.GE.10) THEN + CALL XABORT('READ3D: INVALID TYPE OF GEOMETRY.') + ELSE IF(ITYPE.GE.8) THEN + IF((NCODE(2).NE.0).OR.(NCODE(3).NE.0).OR.(NCODE(4).NE.0)) + 1 CALL XABORT('READ3D: INVALID TYPE OF HEXAGONAL B.C.') + IF(NCODE(1).EQ.5) THEN + IF(IHEX.EQ.1) THEN + IHEX=10 + ELSE IF(IHEX.EQ.2) THEN + IHEX=11 + ELSE + CALL XABORT('READ3D: BOUNDARY CONDITION HBC WITH OPTION' + 1 //' SYME IS ONLY PERMITTED WITH S30 OR SA60 SYMMETRY.') + ENDIF + ELSE IF((NCODE(1).GT.2).AND.(NCODE(1).NE.7)) THEN + CALL XABORT('READ3D: BOUNDARY CONDITION HBC CAN ONLY BE US' + 1 //'ED WITH OPTIONS VOID, REFL, SYME, ALBE OR ZERO.') + ENDIF + ENDIF +*---- +* RECOVER THE MIXTURE NUMBERS +*---- + IF(ISTATE(6).GT.MAXPTS) THEN + WRITE (HSMG,690) 'NMBLK',ISTATE(6),'MAXPTS',MAXPTS + CALL XABORT(HSMG) + ENDIF + CALL LCMGET(IPGEOM,'MIX',MAT) + IR=0 + DO 20 I=1,ISTATE(6) + IR=MAX(IR,MAT(I)) + 20 CONTINUE +*---- +* RECOVER THE MESH COORDINATES. +*---- + IF(LCYL.AND.(LR1.GT.MAXX)) THEN + WRITE (HSMG,690) 'LX',LR1,'MAXX',MAXX + CALL XABORT(HSMG) + ELSE IF(LX1.GT.MAXX) THEN + WRITE (HSMG,690) 'LX',LX1,'MAXX',MAXX + CALL XABORT(HSMG) + ENDIF + IF(LY1.GT.MAXY) THEN + WRITE (HSMG,690) 'LY',LY1,'MAXY',MAXY + CALL XABORT(HSMG) + ENDIF + IF(LZ1.GT.MAXZ) THEN + WRITE (HSMG,690) 'LZ',LZ1,'MAXZ',MAXZ + CALL XABORT(HSMG) + ENDIF + LL1=.FALSE. + LL2=.FALSE. + LY=1 + YYY(1)=0.0 + YYY(2)=1.0 + LZ=1 + ZZZ(1)=0.0 + ZZZ(2)=1.0 + IF(ITYPE.EQ.2) THEN +* 1-D CARTESIAN GEOMETRY. + LX=LX1 + NMBLK=LX + IF((NCODE(1).EQ.0).OR.(NCODE(2).EQ.0)) GO TO 610 + CALL LCMGET(IPGEOM,'MESHX',XXX) + ELSE IF((ITYPE.EQ.3).OR.(ITYPE.EQ.4)) THEN +* 1-D CYLINDRICAL/SPHERICAL GEOMETRY. + LX=LR1 + NMBLK=LX + IF(NCODE(1).NE.0) GO TO 640 + IF(NCODE(2).EQ.0) GO TO 610 + NCODE(1)=2 + CALL LCMGET(IPGEOM,'RADIUS',XXX) + ELSE IF(ITYPE.EQ.5) THEN +* 2-D CARTESIAN GEOMETRY. + LX=LX1 + LY=LY1 + NMBLK=LX*LY + I2=0 + DO 30 IC=1,4 + IF(NCODE(IC).EQ.0) GO TO 610 + IF(NCODE(IC).EQ.3) I2=I2+1 + 30 CONTINUE + IF(I2.NE.0) THEN + IF((I2.NE.2).OR.(LX.NE.LY)) GO TO 630 + NMBLK=(LX+1)*LX/2 + LL1=(NCODE(2).EQ.3).AND.(NCODE(3).EQ.3) + LL2=(NCODE(1).EQ.3).AND.(NCODE(4).EQ.3) + IF((.NOT.LL1).AND.(.NOT.LL2)) GO TO 620 + ENDIF + CALL LCMGET(IPGEOM,'MESHX',XXX) + IF(LL1.OR.LL2) THEN + CALL LCMGET(IPGEOM,'MESHX',YYY) + ELSE + CALL LCMGET(IPGEOM,'MESHY',YYY) + ENDIF + ELSE IF(ITYPE.EQ.6) THEN +* 2-D CYLINDRICAL GEOMETRY. + LX=LR1 + LZ=LZ1 + NMBLK=LX*LZ + IF(NCODE(1).NE.0) GO TO 650 + IF((NCODE(2).EQ.3).OR.(NCODE(3).EQ.3).OR.(NCODE(4).EQ.3)) + 1 GO TO 660 + IF((NCODE(2).EQ.0).OR.(NCODE(5).EQ.0).OR.(NCODE(6).EQ.0)) + 1 GO TO 610 + NCODE(1)=2 + CALL LCMGET(IPGEOM,'RADIUS',XXX) + CALL LCMGET(IPGEOM,'MESHZ',ZZZ) + ELSE IF(ITYPE.EQ.7) THEN +* 3-D CARTESIAN GEOMETRY. + LX=LX1 + LY=LY1 + LZ=LZ1 + NMBLK=LX*LY*LZ + I2=0 + DO 40 IC=1,4 + IF(NCODE(IC).EQ.0) GO TO 610 + IF(NCODE(IC).EQ.3) I2=I2+1 + 40 CONTINUE + IF(I2.NE.0) THEN + IF((I2.NE.2).OR.(LX.NE.LY)) GO TO 630 + NMBLK=((LX+1)*LX/2)*LZ + LL1=(NCODE(2).EQ.3).AND.(NCODE(3).EQ.3) + LL2=(NCODE(1).EQ.3).AND.(NCODE(4).EQ.3) + IF((.NOT.LL1).AND.(.NOT.LL2)) GO TO 620 + ENDIF + CALL LCMGET(IPGEOM,'MESHX',XXX) + IF(LL1.OR.LL2) THEN + CALL LCMGET(IPGEOM,'MESHX',YYY) + ELSE + CALL LCMGET(IPGEOM,'MESHY',YYY) + ENDIF + CALL LCMGET(IPGEOM,'MESHZ',ZZZ) + ELSE IF(ITYPE.EQ.8) THEN +* 2-D HEXAGONAL GEOMETRY. + LX=LX1 + NMBLK=LX + CALL LCMGET(IPGEOM,'SIDE',SIDE) + ELSE IF(ITYPE.EQ.9) THEN +* 3-D HEXAGONAL GEOMETRY. + LX=LX1 + LZ=LZ1 + NMBLK=LX*LZ + CALL LCMGET(IPGEOM,'SIDE',SIDE) + CALL LCMGET(IPGEOM,'MESHZ',ZZZ) + ELSE + CALL XABORT('READ3D: INVALID TYPE OF GEOMETRY.') + ENDIF + IF(NMBLK.NE.ISTATE(6)) THEN + WRITE(HSMG,'(45HREAD3D: INVALID NUMBER OF REGIONS. NUMBER OF , + 1 13HMIX ENTRIES =,I7,20H NUMBER OF REGIONS =,I7)') ISTATE(6), + 2 NMBLK + CALL XABORT(HSMG) + ENDIF + DO 50 IC=1,6,2 + IF((NCODE(IC).EQ.4).AND.(NCODE(IC+1).NE.4)) GO TO 670 + 50 CONTINUE + IF((NCODE(2).EQ.3).AND.(NCODE(3).EQ.3)) THEN + ZCODE(3)=ZCODE(1) + ZCODE(2)=ZCODE(4) + ELSE IF((NCODE(1).EQ.3).AND.(NCODE(4).EQ.3)) THEN + ZCODE(1)=ZCODE(3) + ZCODE(4)=ZCODE(2) + ENDIF +*---- +* UNFOLD GEOMETRY IF HEXAGONAL IN LOZENGES +*---- + ISPLTL=0 + ISPLTH=0 + CALL LCMLEN(IPGEOM,'SPLITL',ILEN,ITYLCM) + IF(ILEN.GT.0) CALL LCMGET(IPGEOM,'SPLITL',ISPLTL) + CALL LCMLEN(IPGEOM,'SPLITH',ILEN,ITYLCM) + IF(ILEN.GT.0) CALL LCMGET(IPGEOM,'SPLITH',ISPLTH) + IF((ISPLTL.GT.0).AND.(IHEX.NE.9)) THEN + ALLOCATE(DPP(MAXPTS),MX(LX*LZ)) + DO 60 I=1,LX*LZ + MX(I)=MAT(I) + 60 CONTINUE + LXOLD=LX + CALL BIVALL(MAXPTS,IHEX,LXOLD,LX,DPP) + DO 80 KZ=1,LZ + DO 70 KX=1,LX + KEL=DPP(KX)+(KZ-1)*LXOLD + MAT(KX+(KZ-1)*LX)=MX(KEL) + 70 CONTINUE + 80 CONTINUE + DEALLOCATE(DPP,MX) + IHEX=9 + ENDIF +*---- +* MESH-SPLITTING +*---- + IF(ISTATE(11).NE.0) THEN + CALL LCMLEN(IPGEOM,'SPLITR',ILEN1,ITYLCM) + CALL LCMLEN(IPGEOM,'SPLITX',ILEN2,ITYLCM) + IF(LCYL.AND.(ILEN1.GT.0)) THEN + CALL LCMGET(IPGEOM,'SPLITR',ISPLTX) + ELSE IF(ILEN2.GT.0) THEN + CALL LCMGET(IPGEOM,'SPLITX',ISPLTX) + ELSE IF(ITYPE.LE.7) THEN + DO 90 I=1,LX + ISPLTX(I)=1 + 90 CONTINUE + ENDIF + CALL LCMLEN(IPGEOM,'SPLITY',ILEN,ITYLCM) + IF(ILEN.GT.0) THEN + CALL LCMGET(IPGEOM,'SPLITY',ISPLTY) + ELSE IF(LL1.OR.LL2) THEN + DO 100 I=1,LX + ISPLTY(I)=ISPLTX(I) + 100 CONTINUE + ELSE + DO 110 I=1,LY + ISPLTY(I)=1 + 110 CONTINUE + ENDIF + CALL LCMLEN(IPGEOM,'SPLITZ',ILEN,ITYLCM) + IF(ILEN.GT.0) THEN + CALL LCMGET(IPGEOM,'SPLITZ',ISPLTZ) + ELSE + DO 120 I=1,LZ + ISPLTZ(I)=1 + 120 CONTINUE + ENDIF + IF((ISPLTH.GT.0).AND.(ISPLTL.GT.0)) THEN + CALL XABORT('READ3D: SPLITH AND SPLITL KEYWORDS ARE EXCLUS' + 1 //'IVE.') + ENDIF + CALL SPLIT0(MAXPTS,ITYPE,NCODE,LXOLD,LYOLD,LZOLD,ISPLTX,ISPLTY, + 1 ISPLTZ,0,ISPLTL,NMBLK,LX,LY,LZ,SIDE,XXX,YYY,ZZZ,MAT,.TRUE., + 2 IMPX) + IF(NMBLK.GT.MAXPTS) THEN + WRITE (HSMG,690) 'NMBLK',NMBLK,'MAXPTS',MAXPTS + CALL XABORT(HSMG) + ENDIF + ENDIF +* + ILK=((NCODE(1).EQ.1).AND.(ZCODE(1).NE.1.0)).OR.(NCODE(1).EQ.7).OR. + 1 ((NCODE(2).EQ.1).AND.(ZCODE(2).NE.1.0)).OR.(NCODE(2).EQ.7).OR. + 2 ((NCODE(3).EQ.1).AND.(ZCODE(3).NE.1.0)).OR.(NCODE(3).EQ.7).OR. + 3 ((NCODE(4).EQ.1).AND.(ZCODE(4).NE.1.0)).OR.(NCODE(4).EQ.7).OR. + 4 ((NCODE(5).EQ.1).AND.(ZCODE(5).NE.1.0)).OR.(NCODE(5).EQ.7).OR. + 5 ((NCODE(6).EQ.1).AND.(ZCODE(6).NE.1.0)).OR.(NCODE(6).EQ.7).OR. + 6 ((NCODE(1).EQ.8).AND.(ZCODE(1).NE.1.0)).OR. + 7 ((NCODE(2).EQ.8).AND.(ZCODE(2).NE.1.0)).OR. + 8 ((NCODE(3).EQ.8).AND.(ZCODE(3).NE.1.0)).OR. + 9 ((NCODE(4).EQ.8).AND.(ZCODE(4).NE.1.0)).OR. + 1 ((NCODE(5).EQ.8).AND.(ZCODE(5).NE.1.0)).OR. + 2 ((NCODE(6).EQ.8).AND.(ZCODE(6).NE.1.0)) + IF(IMPX.GT.0) THEN + IF(ITYPE.EQ.2) THEN + WRITE (6,'(/19H 1-D SLAB GEOMETRY.)') + ELSE IF(ITYPE.EQ.3) THEN + WRITE (6,'(/26H 1-D CYLINDRICAL GEOMETRY.)') + ELSE IF(ITYPE.EQ.4) THEN + WRITE (6,'(/24H 1-D SPHERICAL GEOMETRY.)') + ELSE IF(ITYPE.EQ.5) THEN + WRITE (6,'(/24H 2-D CARTESIAN GEOMETRY.)') + ELSE IF(ITYPE.EQ.6) THEN + WRITE (6,'(/18H 2-D R-Z GEOMETRY.)') + ELSE IF(ITYPE.EQ.7) THEN + WRITE (6,'(/24H 3-D CARTESIAN GEOMETRY.)') + ELSE IF(ITYPE.EQ.8) THEN + WRITE (6,'(/24H 2-D HEXAGONAL GEOMETRY.)') + ELSE IF(ITYPE.EQ.9) THEN + WRITE (6,'(/24H 3-D HEXAGONAL GEOMETRY.)') + ENDIF + CALL LCMINF(IPGEOM,GEONAM,TEXT12,EMPTY,ILONG,LCM) + WRITE (6,'(1H+,26X,18HBASED ON GEOMETRY ,A12,1H./)') GEONAM + WRITE (6,770) LX,MAXX,LY,MAXY,LZ,MAXZ,IR + IF(.NOT.ILK) WRITE (6,'(17H INFINITE DOMAIN./)') + ENDIF + RETURN +* + 610 CALL XABORT('READ3D: A BOUNDARY CONDITION IS MISSING.') + 620 CALL XABORT('READ3D: THE DIAGONAL CONDITIONS X+: DIAG Y-: DIAG A' + 1 //'ND X-: DIAG Y+: DIAG ARE THE ONLY PERMITTED.') + 630 CALL XABORT('READ3D: LX=LY WITH A DIAGONAL SYMMETRY.') + 640 CALL XABORT('READ3D: CYLINDRICAL GEOMETRY - ONLY THE R+: BOUNDAR' + 1 //'Y CONDITION IS REQUIRED.') + 650 CALL XABORT('READ3D: CYLINDRICAL GEOMETRY - ONLY THE R+:, Z-: AN' + 1 //'D Z+: BOUNDARY CONDITIONS ARE REQUIRED.') + 660 CALL XABORT('READ3D: CYLINDRICAL GEOMETRY : THE DIAG BOUNDARY CO' + 1 //'NDITION CANNOT BE USED.') + 670 CALL XABORT('READ3D: THE TRANSLATION CONDITIONS X-: TRAN X+: TRA' + 1 //'N, Y-: TRAN Y+: TRAN AND Z-: TRAN Z+: TRAN ARE THE ONLY PERM' + 1 //'ITTED.') +* + 690 FORMAT (29HREAD3D: INSUFFICIENT STORAGE.,5X,A6,1H=,I7,8H ; AVAIL, + 1 13HABLE STORAGE ,A6,1H=,I7) + 770 FORMAT (/44H NUMBER OF MESH INTERVALS ALONG THE X AXIS =,I5,5X, + 1 24HAVAILABLE STORAGE MAXX =,I7/26X,18HALONG THE Y AXIS =,I5,5X, + 2 24HAVAILABLE STORAGE MAXY =,I7/26X,18HALONG THE Z AXIS =,I5,5X, + 3 24HAVAILABLE STORAGE MAXZ =,I7/28H NUMBER OF DISTINCT MIXTURES, + 4 2H =,I7/) + END diff --git a/Trivac/src/SPLIT0.f b/Trivac/src/SPLIT0.f new file mode 100755 index 0000000..16298b6 --- /dev/null +++ b/Trivac/src/SPLIT0.f @@ -0,0 +1,382 @@ +*DECK SPLIT0 + SUBROUTINE SPLIT0 (MAXPTS,ITYPE,NCODE,LXOLD,LYOLD,LZOLD,ISPLTX, + 1 ISPLTY,ISPLTZ,ISPLTH,ISPLTL,NMBLK,LX,LY,LZ,SIDE,XXX,YYY,ZZZ, + 2 MAT,ITYP,IMPX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Generalized mesh-splitting algorithm. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s):A. Hebert +* +*Parameters: input/output +* MAXPTS dimension of vector MAT. +* ITYPE type of geometry. +* NCODE boundary condition relative to each side of the domain. +* LXOLD number of parallelepipeds along the X-axis as given in the +* input data. +* LYOLD number of parallelepipeds along the Y-axis. +* LZOLD number of parallelepipeds along the Z-axis. +* ISPLTX mesh-splitting data for parallelepipeds along the X-axis +* negative value is used for equal-volume splitting of tubes. +* ISPLTY mesh-splitting data for parallelepipeds along the Y-axis. +* ISPLTZ mesh-splitting data for parallelepipeds along the Z-axis. +* ISPLTH mesh-splitting index for hexagons into triangles. +* ISPLTL mesh-splitting index for hexagons into lozenges. +* NMBLK number of parallelepipeds in the domain. +* LX number of parallelepipeds along the X-axis after mesh- +* splitting. +* LY number of parallelepipeds along the Y-axis. +* LZ number of parallelepipeds along the Z-axis. +* XXX Cartesian coordinates of the domain along the X-axis. +* YYY Cartesian coordinates of the domain along the Y-axis. +* ZZZ Cartesian coordinates of the domain along the Z-axis. +* MAT index-number of the mixture type assigned to each volume +* before and after mesh-splitting. +* ITYP modification flag: +* =.true. modification of XXX, YYY, ZZZ and MAT; +* =.false. modification of MAT only. +* IMPX print flag. Minimum printing if IMPX=0. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MAXPTS,ITYPE,NCODE(6),LXOLD,LYOLD,LZOLD,ISPLTX(LX), + 1 ISPLTY(LY),ISPLTZ(LZ),ISPLTL,NMBLK,LX,LY,LZ,MAT(MAXPTS),IMPX + REAL XXX(LX+1),YYY(LY+1),ZZZ(LZ+1) + LOGICAL ITYP +*---- +* LOCAL VARIABLES +*---- + CHARACTER HSMG*130 + LOGICAL LL1,LL2,NEWCOD(6),LTRI,LLOZ + DOUBLE PRECISION DEL,GAR +*---- +* SETTING LOGICAL PARAMETERS +*---- + LL1=(NCODE(2).EQ.3).AND.(NCODE(3).EQ.3) + LL2=(NCODE(1).EQ.3).AND.(NCODE(4).EQ.3) + LTRI=(ISPLTH.NE.0).AND.((ITYPE.EQ.8).OR.(ITYPE.EQ.9)) + LLOZ=(ISPLTL.NE.0).AND.((ITYPE.EQ.8).OR.(ITYPE.EQ.9)) +* + IF(ITYP) THEN + IF(LL1.OR.LL2) THEN +* DIAGONAL SYMMETRY: CHECK IF ISPLTY(I)=ISPLTX(I) + DO 10 I=1,LX + IF(ISPLTX(I).NE.ISPLTY(I)) CALL XABORT('SPLIT0: INCONSTEN' + 1 //'T MESH-SPLITTING INPUT DATA.') + 10 CONTINUE + ENDIF +* DETERMINATION OF THE NEW BOUNDARY CONDITIONS. + DO 20 I=1,6 + NEWCOD(I)=.FALSE. + 20 CONTINUE + IF((NCODE(1).EQ.5).OR.(LL2.AND.(NCODE(3).EQ.5))) THEN + DEL=XXX(2)-XXX(1) + IF(MOD(ISPLTX(1),2).EQ.0) THEN + ISPLTX(1)=ISPLTX(1)/2 + NEWCOD(1)=.TRUE. + XXX(1)=XXX(2)-REAL(0.5*DEL) + ELSE + IGAR=ISPLTX(1) + ISPLTX(1)=(ISPLTX(1)+1)/2 + XXX(1)=XXX(2)-REAL(DEL*(DBLE(ISPLTX(1))/DBLE(IGAR))) + ENDIF + ENDIF + IF((NCODE(2).EQ.5).OR.(LL1.AND.(NCODE(4).EQ.5))) THEN + DEL=XXX(LX+1)-XXX(LX) + IF(MOD(ISPLTX(LX),2).EQ.0) THEN + ISPLTX(LX)=ISPLTX(LX)/2 + NEWCOD(2)=.TRUE. + XXX(LX+1)=XXX(LX)+REAL(0.5*DEL) + ELSE + IGAR=ISPLTX(LX) + ISPLTX(LX)=(ISPLTX(LX)+1)/2 + XXX(LX+1)=XXX(LX)+REAL(DEL*(DBLE(ISPLTX(LX))/DBLE(IGAR))) + ENDIF + ENDIF + IF(ITYPE.LT.8) THEN + IF((NCODE(3).EQ.5).OR.(LL1.AND.(NCODE(1).EQ.5))) THEN + DEL=YYY(2)-YYY(1) + IF(MOD(ISPLTY(1),2).EQ.0) THEN + ISPLTY(1)=ISPLTY(1)/2 + NEWCOD(3)=.TRUE. + YYY(1)=YYY(2)-REAL(0.5*DEL) + ELSE + IGAR=ISPLTY(1) + ISPLTY(1)=(ISPLTY(1)+1)/2 + YYY(1)=YYY(2)-REAL(DEL*(DBLE(ISPLTY(1))/DBLE(IGAR))) + ENDIF + ENDIF + IF((NCODE(4).EQ.5).OR.(LL2.AND.(NCODE(2).EQ.5))) THEN + DEL=YYY(LY+1)-YYY(LY) + IF(MOD(ISPLTY(LY),2).EQ.0) THEN + ISPLTY(LY)=ISPLTY(LY)/2 + NEWCOD(4)=.TRUE. + YYY(LY+1)=YYY(LY)+REAL(0.5*DEL) + ELSE + IGAR=ISPLTY(LY) + ISPLTY(LY)=(ISPLTY(LY)+1)/2 + YYY(LY+1)=YYY(LY)+REAL(DEL*(DBLE(ISPLTY(LY))/DBLE(IGAR))) + ENDIF + ENDIF + ENDIF + IF(NCODE(5).EQ.5) THEN + DEL=ZZZ(2)-ZZZ(1) + IF(MOD(ISPLTZ(1),2).EQ.0) THEN + ISPLTZ(1)=ISPLTZ(1)/2 + NEWCOD(5)=.TRUE. + ZZZ(1)=ZZZ(2)-REAL(0.5*DEL) + ELSE + IGAR=ISPLTZ(1) + ISPLTZ(1)=(ISPLTZ(1)+1)/2 + ZZZ(1)=ZZZ(2)-REAL(DEL*(DBLE(ISPLTZ(1))/DBLE(IGAR))) + ENDIF + ENDIF + IF(NCODE(6).EQ.5) THEN + DEL=ZZZ(LZ+1)-ZZZ(LZ) + IF(MOD(ISPLTZ(LZ),2).EQ.0) THEN + ISPLTZ(LZ)=ISPLTZ(LZ)/2 + NEWCOD(6)=.TRUE. + ZZZ(LZ+1)=ZZZ(LZ)+REAL(0.5*DEL) + ELSE + IGAR=ISPLTZ(LZ) + ISPLTZ(LZ)=(ISPLTZ(LZ)+1)/2 + ZZZ(LZ+1)=ZZZ(LZ)+REAL(DEL*(DBLE(ISPLTZ(LZ))/DBLE(IGAR))) + ENDIF + ENDIF + IF((.NOT.LL2).AND.NEWCOD(1)) NCODE(1)=2 + IF((.NOT.LL1).AND.NEWCOD(2)) NCODE(2)=2 + IF((.NOT.LL1).AND.NEWCOD(3)) NCODE(3)=2 + IF((.NOT.LL2).AND.NEWCOD(4)) NCODE(4)=2 + IF(NEWCOD(5)) NCODE(5)=2 + IF(NEWCOD(6)) NCODE(6)=2 +* +* COMPUTE THE NEW VALUES OF LX, LY AND LZ. + LXOLD=LX + LYOLD=LY + LZOLD=LZ + IF(ITYPE.LT.8) THEN + LX=0 + DO 40 IOLD=1,LXOLD + LX=LX+ABS(ISPLTX(IOLD)) + 40 CONTINUE + LY=0 + DO 50 IOLD=1,LYOLD + LY=LY+ISPLTY(IOLD) + 50 CONTINUE + ELSEIF(LTRI) THEN + LX=LXOLD*6*(ISPLTH**2) + ELSEIF(LLOZ) THEN + LX=LXOLD*3*(ISPLTL**2) + ENDIF + LZ=0 + DO 55 IOLD=1,LZOLD + LZ=LZ+ISPLTZ(IOLD) + 55 CONTINUE +* +* COMPUTE THE NEW VALUES OF XXX, YYY AND ZZZ. + IF(ITYPE.LT.8) THEN + K=LX+1 + GAR=XXX(LXOLD+1) + DO 61 IOLD=LXOLD,1,-1 + ISP=ISPLTX(IOLD) + DEL=(GAR-XXX(IOLD))/DBLE(ABS(ISP)) + IF(ISP.LT.0) THEN + IF((ITYPE.EQ.3).OR.(ITYPE.EQ.6)) DEL=DEL*(GAR+XXX(IOLD)) + IF(ITYPE.EQ.4) DEL=DEL*(GAR**2+GAR*XXX(IOLD)+XXX(IOLD)**2) + ENDIF + GAR=XXX(IOLD) + DO 60 I=ABS(ISP),1,-1 + IF(ISP.GT.0) THEN + XXX(K)=REAL(GAR+DEL*DBLE(I)) + ELSE IF((ITYPE.EQ.3).OR.(ITYPE.EQ.6)) THEN + XXX(K)=REAL(SQRT(GAR*GAR+DEL*DBLE(I))) + ELSE IF(ITYPE.EQ.4) THEN + XXX(K)=REAL((GAR**3+DEL*DBLE(I))**(1.0D0/3.0D0)) + ELSE + CALL XABORT('SPLIT0: INVALID MESH-SPLITTING INDEX.') + ENDIF + K=K-1 + 60 CONTINUE + 61 CONTINUE + K=LY+1 + GAR=YYY(LYOLD+1) + DO 71 IOLD=LYOLD,1,-1 + ISP=ISPLTY(IOLD) + DEL=(GAR-YYY(IOLD))/DBLE(ISP) + GAR=YYY(IOLD) + DO 70 I=ISP,1,-1 + YYY(K)=REAL(GAR+DEL*DBLE(I)) + K=K-1 + 70 CONTINUE + 71 CONTINUE + ELSEIF(LTRI) THEN + SIDE=SIDE/REAL(ISPLTH) + ELSEIF(LLOZ) THEN + SIDE=SIDE/REAL(ISPLTL) + ENDIF + K=LZ+1 + GAR=ZZZ(LZOLD+1) + DO 76 IOLD=LZOLD,1,-1 + ISP=ISPLTZ(IOLD) + DEL=(GAR-ZZZ(IOLD))/DBLE(ISP) + GAR=ZZZ(IOLD) + DO 75 I=ISP,1,-1 + ZZZ(K)=REAL(GAR+DEL*DBLE(I)) + K=K-1 + 75 CONTINUE + 76 CONTINUE +* +* COMPUTE THE NUMBER OF PARALLEPIPEDS AFTER MESH-SPLITTING. + IF(LL1.OR.LL2) THEN + IF(LX.EQ.LY) THEN + NMBLK=LZ*((LX+1)*LX)/2 + ELSE + CALL XABORT('SPLIT0: LX ET LY SHOULD BE EQUAL.') + ENDIF + ELSE IF(ITYPE.LT.8) THEN + NMBLK=LX*LY*LZ + ELSE + NMBLK=LX*LZ + ENDIF + IF(IMPX.GE.3) THEN + WRITE (6,200) LX,LY,LZ,NMBLK,(NCODE(I),I=1,6) + IF(ITYPE.LT.8) THEN + WRITE (6,210) 'XXX',(XXX(I),I=1,LX+1) + WRITE (6,210) 'YYY',(YYY(I),I=1,LY+1) + ELSE + WRITE (6,210) 'SIDE',SIDE + ENDIF + WRITE (6,210) 'ZZZ',(ZZZ(I),I=1,LZ+1) + ENDIF + ENDIF +*---- +* COMPUTE THE NEW MIXTURE NUMBERS MAT(I). +*---- + IF(ITYPE.LT.8) THEN + IF(LL1.OR.LL2) THEN + KOLD=LZOLD*((LXOLD+1)*LXOLD)/2 + KNEW=LZ*((LX+1)*LX)/2 + ELSE + KOLD=LXOLD*LYOLD*LZOLD + KNEW=LX*LY*LZ + ENDIF + NMBLK=KNEW + IF(KNEW.GT.MAXPTS) THEN + WRITE (HSMG,230) 'NMBLK',KNEW,'MAXPTS',MAXPTS + CALL XABORT(HSMG) + ENDIF + DO 103 K0=LZOLD,1,-1 + KIOFZ=KOLD + DO 102 K=ISPLTZ(K0),1,-1 + KOLD=KIOFZ + DO 101 K1=LYOLD,1,-1 + KIOFY=KOLD + DO 100 J=ISPLTY(K1),1,-1 + KOLD=KIOFY + DO 90 K2=LXOLD,1,-1 + IF(LL1.AND.(K1.LT.K2)) GO TO 90 + IF(LL2.AND.(K1.GT.K2)) GO TO 90 + IGAR=MAT(KOLD) + DO 80 I=ABS(ISPLTX(K2)),1,-1 + IF(LL1.AND.(J.LT.I).AND.(K1.EQ.K2)) GO TO 80 + IF(LL2.AND.(J.GT.I).AND.(K1.EQ.K2)) GO TO 80 + MAT(KNEW)=IGAR + MAT(KNEW)=IGAR + KNEW=KNEW-1 + 80 CONTINUE + KOLD=KOLD-1 + 90 CONTINUE + 100 CONTINUE + 101 CONTINUE + 102 CONTINUE + 103 CONTINUE + ELSEIF(LTRI) THEN +* HEXAGONAL GEOMETRY WITH TRIANGULAR SUBMESH. + KOLD=LXOLD*LZOLD + KNEW=LXOLD*6*(ISPLTH**2)*LZ + NMBLK=KNEW + IF(KNEW.GT.MAXPTS) THEN + WRITE (HSMG,230) 'NMBLK',KNEW,'MAXPTS',MAXPTS + CALL XABORT(HSMG) + ENDIF + DO 135 K0=LZOLD,1,-1 + KIOFZ=KOLD + DO 130 K=ISPLTZ(K0),1,-1 + KOLD=KIOFZ + DO 120 K2=LXOLD,1,-1 + IGAR=MAT(KOLD) + DO 110 I=(6*ISPLTH**2),1,-1 + MAT(KNEW)=IGAR + KNEW=KNEW-1 + 110 CONTINUE + KOLD=KOLD-1 + 120 CONTINUE + 130 CONTINUE + 135 CONTINUE + ELSEIF(LLOZ) THEN +* HEXAGONAL GEOMETRY WITH LOZENGE SUBMESH. + KOLD=LXOLD*LZOLD + KNEW=LXOLD*3*(ISPLTL**2)*LZ + NMBLK=KNEW + IF(KNEW.GT.MAXPTS) THEN + WRITE (HSMG,230) 'NMBLK',KNEW,'MAXPTS',MAXPTS + CALL XABORT(HSMG) + ENDIF + DO 165 K0=LZOLD,1,-1 + KIOFZ=KOLD + DO 160 K=ISPLTZ(K0),1,-1 + KOLD=KIOFZ + DO 150 K2=LXOLD,1,-1 + IGAR=MAT(KOLD) + DO 140 I=(3*ISPLTL**2),1,-1 + MAT(KNEW)=IGAR + KNEW=KNEW-1 + 140 CONTINUE + KOLD=KOLD-1 + 150 CONTINUE + 160 CONTINUE + 165 CONTINUE + ELSE +* HEXAGONAL GEOMETRY. + KOLD=LXOLD*LZOLD + KNEW=LXOLD*LZ + NMBLK=KNEW + IF(KNEW.GT.MAXPTS) THEN + WRITE (HSMG,230) 'NMBLK',KNEW,'MAXPTS',MAXPTS + CALL XABORT(HSMG) + ENDIF + DO 185 K0=LZOLD,1,-1 + KIOFZ=KOLD + DO 180 K=ISPLTZ(K0),1,-1 + KOLD=KIOFZ + DO 170 K2=LXOLD,1,-1 + MAT(KNEW)=MAT(KOLD) + KNEW=KNEW-1 + KOLD=KOLD-1 + 170 CONTINUE + 180 CONTINUE + 185 CONTINUE + ENDIF + IF(IMPX.GE.3) WRITE (6,220) (MAT(I),I=1,NMBLK) + RETURN +* + 200 FORMAT (//4H LX=,I4,4X,3HLY=,I4,4X,3HLZ=,I4,4X,6HNMBLK=,I5, + 1 4X,9HNCODE(1)=,I2,3X,9HNCODE(2)=,I2,3X,9HNCODE(3)=,I2,3X, + 2 9HNCODE(4)=,I2,3X,9HNCODE(5)=,I2,3X,9HNCODE(6)=,I2/) + 210 FORMAT (//1X,A4/(1X,1P,10E12.4)) + 220 FORMAT (//4H MAT/(1X,20I6)) + 230 FORMAT (29HSPLIT0: INSUFFICIENT STORAGE.,5X,A6,1H=,I9,8H ; AVAIL, + 1 13HABLE STORAGE ,A6,1H=,I9) + END diff --git a/Trivac/src/TRIAHD.f b/Trivac/src/TRIAHD.f new file mode 100755 index 0000000..caf9fd2 --- /dev/null +++ b/Trivac/src/TRIAHD.f @@ -0,0 +1,50 @@ +*DECK TRIAHD + SUBROUTINE TRIAHD (IR,NEL,LL4,SGD,VOL,MAT,VEC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Assembly of a diagonal system matrix corresponding to a single cross +* section type. Mesh centered finite difference case in hexagonal +* geometry. Note: vector VEC should be initialized by the calling +* program. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IR maximum number of material mixtures. +* NEL total number of finite elements. +* LL4 number of unknowns (order of the system matrices). +* SGD cross section per material mixture. +* VOL volumes. +* MAT index-number of the mixture type assigned to each volume. +* +*Parameters: output +* VEC diagonal system matrix. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IR,NEL,LL4,MAT(NEL) + REAL SGD(IR),VOL(NEL),VEC(LL4) +* + KEL=0 + DO 10 K=1,NEL + L=MAT(K) + IF(L.EQ.0) GO TO 10 + KEL=KEL+1 + VOL0=VOL(K) + IF(VOL0.EQ.0.0) GO TO 10 + VEC(KEL)=VEC(KEL)+SGD(L)*VOL0 + 10 CONTINUE + RETURN + END diff --git a/Trivac/src/TRIAHP.f b/Trivac/src/TRIAHP.f new file mode 100755 index 0000000..1955acc --- /dev/null +++ b/Trivac/src/TRIAHP.f @@ -0,0 +1,120 @@ +*DECK TRIAHP + SUBROUTINE TRIAHP (MAXKN,ISPLH,IR,NEL,LL4,SGD,SIDE,ZZ,VOL,MAT,KN, + 1 R,RH,RT,VEC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Assembly of a diagonal system matrix corresponding to a single cross +* section type (primal formulation) in hexagonal geometry. +* Note: vector VEC should be initialized by the calling program. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* ISPLH type of mesh-splitting: =1 for complete hexagons; .gt.1 for +* triangle mesh-splitting. +* IR number of material mixtures. +* NEL total number of finite elements. +* LL4 order of system matrices. +* SGD cross section per material mixture. +* SIDE dide of an hexagon. +* ZZ height of each hexagon. +* VOL volume of each element. +* MAT mixture index assigned to each element. +* KN element-ordered unknown list. +* R unit matrix. +* RH unit matrix. +* RT unit matrix. +* +*Parameters: output +* VEC diagonal matrix corresponding to the cross section term. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MAXKN,ISPLH,IR,NEL,LL4,MAT(NEL),KN(MAXKN) + REAL SGD(IR),SIDE,ZZ(NEL),VOL(NEL),R(2,2),RH(6,6),RT(3,3),VEC(LL4) +*---- +* LOCAL VARIABLES +*---- + INTEGER ILIEN(6,3),IJ17(14),IJ27(14),IJ16(12),IJ26(12),IJ1(14), + 1 IJ2(14) + REAL RH2(7,7) + DOUBLE PRECISION RR,VOL1,RTHG(14,14) + DATA ILIEN/6*4,2,1,5,6,7,3,1,5,6,7,3,2/ + DATA IJ16,IJ26 /1,2,3,4,5,6,1,2,3,4,5,6,6*1,6*2/ + DATA IJ17,IJ27 /1,2,3,4,5,6,7,1,2,3,4,5,6,7,7*1,7*2/ +* +* COMPUTE THE HEXAGONAL MASS (RH2). + IF(ISPLH.EQ.1) THEN + LC=6 + DO 10 I=1,2*LC + IJ1(I)=IJ16(I) + IJ2(I)=IJ26(I) + 10 CONTINUE + DO 30 I=1,LC + DO 20 J=1,LC + RH2(I,J)=RH(I,J) + 20 CONTINUE + 30 CONTINUE + ELSE + LC=7 + DO 40 I=1,2*LC + IJ1(I)=IJ17(I) + IJ2(I)=IJ27(I) + 40 CONTINUE + DO 60 I=1,LC + DO 50 J=1,LC + RH2(I,J)=0.0 + 50 CONTINUE + 60 CONTINUE + DO 85 K=1,6 + DO 80 I=1,3 + NUMI=ILIEN(K,I) + DO 70 J=1,3 + NUMJ=ILIEN(K,J) + RH2(NUMI,NUMJ)=RH2(NUMI,NUMJ)+RT(I,J) + 70 CONTINUE + 80 CONTINUE + 85 CONTINUE + ENDIF + LL=2*LC +* +* CALCULATION OF 3-D MASS AND STIFFNESS MATRICES FROM TENSORIAL PRODUCT +* OF 1-D AND 2-D MATRICES. + DO 100 I=1,LL + I1=IJ1(I) + I2=IJ2(I) + DO 90 J=1,LL + J1=IJ1(J) + J2=IJ2(J) + RTHG(I,J)=RH2(I1,J1)*R(I2,J2) + 90 CONTINUE + 100 CONTINUE +* + NUM1=0 + VOL1=SIDE*SIDE + DO 160 K=1,NEL + L=MAT(K) + IF(L.EQ.0) GO TO 160 + IF(VOL(K).EQ.0.0) GO TO 150 + DO 110 I=1,LL + INW1=KN(NUM1+I) + IF(INW1.EQ.0) GO TO 110 + RR=RTHG(I,I)*VOL1*ZZ(K) + VEC(INW1)=VEC(INW1)+REAL(RR*SGD(L)) + 110 CONTINUE + 150 NUM1=NUM1+LL + 160 CONTINUE + RETURN + END diff --git a/Trivac/src/TRIALB.f b/Trivac/src/TRIALB.f new file mode 100755 index 0000000..9b26ca2 --- /dev/null +++ b/Trivac/src/TRIALB.f @@ -0,0 +1,106 @@ +*DECK TRIALB + SUBROUTINE TRIALB(IPTRK,IPMACR,IPMACP,IPSYS,NGRP,NALBP,IPR,GAMMA) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Process physical albedo information and calculation of multigroup +* albedo functions. +* +*Copyright: +* Copyright (C) 2018 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK L_TRACK pointer to the TRIVAC tracking information. +* IPMACR L_MACROLIB pointer to the unperturbed cross sections. +* IPMACP L_MACROLIB pointer to the perturbed cross sections if +* IPR.gt.0. Equal to IPMACR if IPR=0. +* IPSYS L_SYSTEM pointer to system matrices. +* NGRP number of energy groups. +* NALBP number of physical albedos per energy group. +* IPR type of assembly: +* =0: calculation of the system matrices; +* =1: calculation of the derivative of these matrices; +* =2: calculation of the first variation of these matrices; +* =3: identical to IPR=2, but these variation are added to +* unperturbed system matrices. +* +*Parameters: output +* GAMMA albedo functions +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPMACR,IPMACP,IPSYS + INTEGER NGRP,NALBP,IPR + REAL GAMMA(NALBP,NGRP) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + INTEGER ISTATE(NSTATE) + CHARACTER TEXT12*12 + REAL, DIMENSION(:,:), ALLOCATABLE :: ALBP,DALBP +* + ALB(X)=0.5*(1.0-X)/(1.0+X) +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(ALBP(NALBP,NGRP),DALBP(NALBP,NGRP)) +*---- +* RECOVER PHYSICAL ALBEDOS +*---- + IF(NALBP.EQ.0) CALL XABORT('TRIALB: NO PHYSICAL ALBEDOS.') + CALL LCMGET(IPMACR,'ALBEDO',ALBP) + IF(IPR.GT.0) CALL LCMGET(IPMACP,'ALBEDO',DALBP) +*---- +* COMPUTE ALBEDO FUNCTIONS +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + ICHX=ISTATE(12) + DO IGR=1,NGRP + GAMMA(:NALBP,IGR)=0.0 + DO IALB=1,NALBP + IF(ICHX.NE.2) THEN + IF(IPR.EQ.0) THEN + GAMMA(IALB,IGR)=ALB(ALBP(IALB,IGR)) + ELSE + GAMMA(IALB,IGR)=ALB(DALBP(IALB,IGR)) + ENDIF + ELSE IF((ICHX.EQ.2).AND.(ALBP(IALB,IGR).NE.1.0)) THEN + IF(IPR.EQ.0) THEN + GAMMA(IALB,IGR)=1.0/ALB(ALBP(IALB,IGR)) + ELSE IF(IPR.EQ.1) THEN + GG=ALB(ALBP(IALB,IGR)) + DGG=ALB(DALBP(IALB,IGR)) + GAMMA(IALB,IGR)=-DGG/(GG**2) + ELSE + GG=ALB(ALBP(IALB,IGR)) + DGG=ALB(ALBP(IALB,IGR))+ALB(DALBP(IALB,IGR)) + GAMMA(IALB,IGR)=1.0/DGG-1.0/GG + ENDIF + ELSE IF((ICHX.EQ.2).AND.(ALBP(IALB,IGR).EQ.1.0)) THEN + GAMMA(IALB,IGR)=1.0E20 + ENDIF + ENDDO +*---- +* SAVE ALBEDO FUNCTIONS ON IPSYS +*---- + WRITE(TEXT12,'(9HALBEDO-FU,I3.3)') IGR + CALL LCMPUT(IPSYS,TEXT12,NALBP,2,GAMMA(1,IGR)) + ENDDO +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(DALBP,ALBP) + RETURN + END diff --git a/Trivac/src/TRIASD.f b/Trivac/src/TRIASD.f new file mode 100755 index 0000000..73c29f5 --- /dev/null +++ b/Trivac/src/TRIASD.f @@ -0,0 +1,136 @@ +*DECK TRIASD + SUBROUTINE TRIASD (MAXKN,IELEM,ICHX,IDIM,IR,NEL,NUN,SGD,VOL,MAT, + 1 KN,VEC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Assembly of a diagonal system matrix corresponding to a single cross +* section type (Thomas-Raviart dual cases). Note: vector VEC should be +* initialized by the calling program. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXKN dimension of array KN. +* IELEM degree of the Lagrangian finite elements. +* ICHX type of discretization method: +* =2: dual finite element approximations; +* =3: nodal collocation method with full tensorial products; +* =4: nodal collocation method with serendipity approximation. +* IDIM number of dimensions. +* IR maximum number of material mixtures. +* NEL total number of finite elements. +* NUN total number of unknowns per group. +* SGD cross section per material mixture. +* VOL volumes. +* MAT index-number of the mixture type assigned to each volume. +* KN element-ordered unknown list. +* +*Parameters: output +* VEC diagonal system matrix. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MAXKN,IELEM,ICHX,IDIM,IR,NEL,NUN,MAT(NEL),KN(MAXKN) + REAL SGD(IR),VOL(NEL),VEC(NUN) +*---- +* LOCAL VARIABLES +*---- + INTEGER, DIMENSION(:), ALLOCATABLE :: IGAR +* + IORD(J,K,L,LL,IEL,IW)=(IEL*L+K)*LL*IEL+(1+IEL*(IW-1))+J + IORL(J,K,L,LL,IEL,IW)= + 1 1+LL*(L*(IEL*(IEL+1))/2-(L*(L-1)*(3*IEL-L+2))/6 + 2 +K*(IEL-L)-(K*(K-1))/2)+(IEL-K-L)*(IW-1)+J +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IGAR(NEL)) +* + IF(ICHX.EQ.2) THEN +* DUAL FINITE ELEMENT METHOD. + NUM1=0 + DO 30 K=1,NEL + L=MAT(K) + IF(L.EQ.0) GO TO 30 + VOL0=VOL(K) + IF(VOL0.EQ.0.0) GO TO 20 + DO 12 K3=0,IELEM-1 + DO 11 K2=0,IELEM-1 + DO 10 K1=0,IELEM-1 + IND1=KN(NUM1+1)+(K3*IELEM+K2)*IELEM+K1 + VEC(IND1)=VEC(IND1)+VOL0*SGD(L) + 10 CONTINUE + 11 CONTINUE + 12 CONTINUE + 20 NUM1=NUM1+1+6*IELEM**2 + 30 CONTINUE + ELSE IF(ICHX.EQ.3) THEN +* NODAL COLLOCATION METHOD WITH FULL TENSORIAL PRODUCTS. + LNUN=0 + DO 40 K=1,NEL + IF(MAT(K).EQ.0) GO TO 40 + LNUN=LNUN+1 + IGAR(K)=LNUN + 40 CONTINUE +* + DO 70 K=1,NEL + L=MAT(K) + IF(L.EQ.0) GO TO 70 + VOL0=VOL(K) + IF(VOL0.EQ.0.0) GO TO 70 + DO 65 I3=0,IELEM-1 + DO 60 I2=0,IELEM-1 + DO 50 I1=0,IELEM-1 + INX1=IORD(I1,I2,I3,LNUN,IELEM,IGAR(K)) + VEC(INX1)=VEC(INX1)+SGD(L)*VOL0 + 50 CONTINUE + IF((IDIM.EQ.1).AND.(I2.EQ.0)) GO TO 70 + IF((IDIM.EQ.2).AND.(I2.EQ.IELEM-1)) GO TO 70 + 60 CONTINUE + 65 CONTINUE + 70 CONTINUE + ELSE IF(ICHX.EQ.4) THEN +* NODAL COLLOCATION METHOD WITH SERENDIPITY APPROXIMATION. + LNUN=0 + DO 80 K=1,NEL + IF(MAT(K).EQ.0) GO TO 80 + LNUN=LNUN+1 + IGAR(K)=LNUN + 80 CONTINUE +* + DO 110 K=1,NEL + L=MAT(K) + IF(L.EQ.0) GO TO 110 + VOL0=VOL(K) + IF(VOL0.EQ.0.0) GO TO 110 + DO 105 I3=0,IELEM-1 + DO 100 I2=0,IELEM-1-I3 + DO 90 I1=0,IELEM-1-I2-I3 + INX1=IORL(I1,I2,I3,LNUN,IELEM,IGAR(K)) + VEC(INX1)=VEC(INX1)+SGD(L)*VOL0 + 90 CONTINUE + IF((IDIM.EQ.1).AND.(I2.EQ.0)) GO TO 110 + IF((IDIM.EQ.2).AND.(I2.EQ.IELEM-1)) GO TO 110 + 100 CONTINUE + 105 CONTINUE + 110 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IGAR) + RETURN + END diff --git a/Trivac/src/TRIASH.f b/Trivac/src/TRIASH.f new file mode 100755 index 0000000..0433dc2 --- /dev/null +++ b/Trivac/src/TRIASH.f @@ -0,0 +1,75 @@ +*DECK TRIASH + SUBROUTINE TRIASH(IELEM,NBMIX,LL4F,NBLOS,MAT,SIDE,ZZ,FRZ,SGD,KN, + > IPERT,VEC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Assembly of a diagonal system matrix corresponding to a single cross +* section type (Thomas-Raviart-Schneider dual cases). Note: vector VEC +* should be initialized by the calling program. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IELEM degree of the Lagrangian finite elements. +* NBMIX maximum number of material mixtures. +* LL4F total number of flux unknowns per group. +* NBLOS number of lozenges per direction, taking into account +* mesh-splitting. +* MAT mixture index assigned to each element. +* SIDE side of an hexagon. +* ZZ Z-directed mesh spacings. +* FRZ volume fractions for the axial SYME boundary condition. +* SGD cross section per material mixture. +* KN ADI permutation indices for the volumes. +* IPERT mixture permutation index. +* +*Parameters: output +* VEC diagonal system matrix. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + PARAMETER(MAXIEL=3) + INTEGER IELEM,NBMIX,LL4F,NBLOS,MAT(3,NBLOS),KN(NBLOS,3), + 1 IPERT(NBLOS) + REAL SIDE,ZZ(3,NBLOS),FRZ(NBLOS),SGD(NBMIX),VEC(LL4F) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION TTTT,VOL0,SIG +* + TTTT=0.5D0*SQRT(3.D00)*SIDE*SIDE + NUM=0 + DO 20 KEL=1,NBLOS + IF(IPERT(KEL).EQ.0) GO TO 20 + IBM=MAT(1,IPERT(KEL)) + IF(IBM.EQ.0) GO TO 20 + NUM=NUM+1 + VOL0=TTTT*ZZ(1,IPERT(KEL))*FRZ(KEL) + SIG=SGD(IBM) + DO 12 K3=0,IELEM-1 + DO 11 K2=0,IELEM-1 + DO 10 K1=0,IELEM-1 + JND1=(NUM-1)*IELEM**3+K3*IELEM**2+K2*IELEM+K1+1 + JND2=(KN(NUM,1)-1)*IELEM**3+K3*IELEM**2+K2*IELEM+K1+1 + JND3=(KN(NUM,2)-1)*IELEM**3+K3*IELEM**2+K2*IELEM+K1+1 + VEC(JND1)=VEC(JND1)+REAL(VOL0*SIG) + VEC(JND2)=VEC(JND2)+REAL(VOL0*SIG) + VEC(JND3)=VEC(JND3)+REAL(VOL0*SIG) + 10 CONTINUE + 11 CONTINUE + 12 CONTINUE + 20 CONTINUE + RETURN + END diff --git a/Trivac/src/TRIASM.f b/Trivac/src/TRIASM.f new file mode 100755 index 0000000..3867a53 --- /dev/null +++ b/Trivac/src/TRIASM.f @@ -0,0 +1,780 @@ +*DECK TRIASM + SUBROUTINE TRIASM(HNAMT,IPTRK,IPSYS,IMPX,MAXMIX,NEL,NALBP,IPR, + 1 MAT,VOL,GAMMA,SGD,XSGD) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Assembly of a single-group system matrix with leakage and removal +* cross sections. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* HNAMT name of the matrix. +* IPTRK L_TRACK pointer to the TRIVAC tracking information. +* IPSYS L_SYSTEM pointer to system matrices. +* IMPX print parameter (equal to zero for no print). +* MAXMIX first dimension for matrices SGD and XSGD. +* NEL total number of finite elements. +* NALBP number of physical albedos. +* IPR type of assembly: +* =0: calculation of the system matrices; +* =1: calculation of the derivative of these matrices; +* =2: calculation of the first variation of these matrices; +* =3: identical to IPR=2, but these variation are added to +* unperturbed system matrices. +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* GAMMA physical albedo functions. +* SGD nuclear properties per material mixture. +* XSGD first variations or derivatives of nuclear properties: +* if IPR.ge.1, XSGD contain first variations or derivatives +* of nuclear properties in each material mixture; +* if IPR=0, XSGD should be equivalenced with SGD. This is +* obtained using 'CALL TRIASM(...,SGD,SGD)'. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPSYS + CHARACTER HNAMT*10 + INTEGER IMPX,MAXMIX,NEL,IPR,MAT(NEL) + REAL VOL(NEL),GAMMA(NALBP),SGD(MAXMIX,4),XSGD(MAXMIX,4) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + LOGICAL CYLIND,CHEX,DIAG,LSGD,LOGY,LOGZ + CHARACTER TEXT10*10 + INTEGER NCODE(6),ICODE(6),ISTATE(NSTATE) + REAL ZCODE(6),ZALB(6) + INTEGER, DIMENSION(:), ALLOCATABLE :: KN,IQFR,MUW,MUZ,MATN,IPERT + INTEGER, DIMENSION(:), ALLOCATABLE, TARGET :: MUY + INTEGER, DIMENSION(:), POINTER :: MUX + REAL, DIMENSION(:), ALLOCATABLE :: VOL2,QFR,XX,YY,ZZ,DD,T,TS,FRZ, + 1 DIF + REAL, DIMENSION(:,:), ALLOCATABLE :: R,RS,Q,QS,V,RH,QH,RT,QT,DSGD + REAL, DIMENSION(:), ALLOCATABLE :: RR0,XR0,ANG + INTEGER, DIMENSION(:), POINTER :: IPW,IPX,IPY,IPZ + INTEGER, DIMENSION(:), POINTER :: IPBW,IPBX,IPBY,IPBZ + REAL, DIMENSION(:), POINTER :: TF,WA,AW,XA,AX,YA,AY,ZA,AZ + REAL, DIMENSION(:), POINTER :: BW,BX,BY,BZ + TYPE(C_PTR) IPW_PTR,IPX_PTR,IPY_PTR,IPZ_PTR + TYPE(C_PTR) IPBW_PTR,IPBX_PTR,IPBY_PTR,IPBZ_PTR + TYPE(C_PTR) TF_PTR,WA_PTR,AW_PTR,XA_PTR,AX_PTR,YA_PTR,AY_PTR, + 1 ZA_PTR,AZ_PTR + TYPE(C_PTR) BW_PTR,BX_PTR,BY_PTR,BZ_PTR +*---- +* RECOVER TRIVAC SPECIFIC TRACKING INFORMATION +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + ITYPE=ISTATE(6) + CYLIND=(ITYPE.EQ.3).OR.(ITYPE.EQ.6) + CHEX=(ITYPE.EQ.8).OR.(ITYPE.EQ.9) + IDIM=1 + IF((ITYPE.EQ.5).OR.(ITYPE.EQ.6).OR.(ITYPE.EQ.8)) IDIM=2 + IF((ITYPE.EQ.7).OR.(ITYPE.EQ.9)) IDIM=3 + IHEX=ISTATE(7) + DIAG=(ISTATE(8).EQ.1) + IELEM=ISTATE(9) + ICOL=ISTATE(10) + LL4=ISTATE(11) + ICHX=ISTATE(12) + ISPLH=ISTATE(13) + LX=ISTATE(14) + LY=ISTATE(15) + LZ=ISTATE(16) + ISEG=ISTATE(17) + IMPV=ISTATE(18) + NR0=ISTATE(24) + LL4F=ISTATE(25) + IF(ICHX.EQ.2) THEN + ITY=3 + LL4W=ISTATE(26) + LL4X=ISTATE(27) + LL4Y=ISTATE(28) + LL4Z=ISTATE(29) + LOGY=LL4Y.GT.0 + LOGZ=LL4Z.GT.0 + ELSE + ITY=2 + LL4W=LL4 + LL4X=LL4 + LL4Y=LL4 + LL4Z=LL4 + LOGY=IDIM.GT.1 + LOGZ=IDIM.GT.2 + ENDIF + CALL LCMLEN(IPTRK,'KN',MAXKN,ITYLCM) + CALL LCMLEN(IPTRK,'QFR',MAXQF,ITYLCM) + ALLOCATE(ZZ(LX*LY*LZ),KN(MAXKN),QFR(MAXQF),IQFR(MAXQF)) + CALL LCMGET(IPTRK,'ZZ',ZZ) + CALL LCMGET(IPTRK,'KN',KN) + CALL LCMGET(IPTRK,'QFR',QFR) + CALL LCMGET(IPTRK,'IQFR',IQFR) + IF(CHEX) THEN + CALL LCMGET(IPTRK,'SIDE',SIDE) + ALLOCATE(MUW(LL4W)) + CALL LCMGET(IPTRK,'MUW',MUW) + ELSE + ALLOCATE(XX(LX*LY*LZ),YY(LX*LY*LZ),DD(LX*LY*LZ)) + CALL LCMGET(IPTRK,'XX',XX) + CALL LCMGET(IPTRK,'YY',YY) + CALL LCMGET(IPTRK,'DD',DD) + ENDIF + IF(LOGY) THEN + ALLOCATE(MUY(LL4Y)) + CALL LCMGET(IPTRK,'MUY',MUY) + ENDIF + IF(.NOT.DIAG) THEN + ALLOCATE(MUX(LL4X)) + CALL LCMGET(IPTRK,'MUX',MUX) + ELSE + MUX=>MUY + ENDIF + IF(LOGZ) THEN + ALLOCATE(MUZ(LL4Z)) + CALL LCMGET(IPTRK,'MUZ',MUZ) + ENDIF +*---- +* RECOVER UNIT MATRICES +*---- + IF((ICHX.EQ.1).OR.(ICHX.EQ.2)) THEN + CALL LCMSIX(IPTRK,'BIVCOL',1) + CALL LCMLEN(IPTRK,'T',LC,ITYLCM) + ALLOCATE(T(LC),TS(LC),R(LC,LC),RS(LC,LC),Q(LC,LC),QS(LC,LC), + 1 V(LC,LC-1),RH(6,6),QH(6,6),RT(3,3),QT(3,3)) + CALL LCMGET(IPTRK,'T',T) + CALL LCMGET(IPTRK,'TS',TS) + CALL LCMGET(IPTRK,'R',R) + CALL LCMGET(IPTRK,'RS',RS) + CALL LCMGET(IPTRK,'Q',Q) + CALL LCMGET(IPTRK,'QS',QS) + CALL LCMGET(IPTRK,'V',V) + IF((IELEM.EQ.1).AND.(ICOL.LE.2)) THEN + CALL LCMGET(IPTRK,'RH',RH) + CALL LCMGET(IPTRK,'QH',QH) + CALL LCMGET(IPTRK,'RT',RT) + CALL LCMGET(IPTRK,'QT',QT) + ENDIF + CALL LCMSIX(IPTRK,' ',2) + ENDIF +* + TEXT10=HNAMT(:10) + IF(IMPX.GT.0) WRITE(6,'(/36H TRIASM: ASSEMBLY OF SYMMETRIC MATRI, + 1 3HX '',A10,38H'' IN COMPRESSED DIAGONAL STORAGE MODE.)') TEXT10 + CALL KDRCPU(TK1) +*---- +* COMPUTE THE INVERSE CROSS SECTIONS FOR DUAL FINITE ELEMENT CASES +*---- + IF(ICHX.EQ.2) THEN + ALLOCATE(DSGD(MAXMIX,4)) + IF(IPR.EQ.0) THEN + DO 15 J=1,4 + DO 10 I=1,MAXMIX + IF(SGD(I,J).NE.0.) DSGD(I,J)=1.0/SGD(I,J) + 10 CONTINUE + 15 CONTINUE + ELSE IF(IPR.EQ.1) THEN + DO 25 J=1,4 + DO 20 I=1,MAXMIX + IF(SGD(I,J).NE.0.0) THEN + DSGD(I,J)=-XSGD(I,J)/(SGD(I,J)**2) + ENDIF + 20 CONTINUE + 25 CONTINUE + ELSE + DO 35 J=1,4 + DO 30 I=1,MAXMIX + SIGMA=SGD(I,J)+XSGD(I,J) + IF((SGD(I,J).NE.0.0).AND.(SIGMA.NE.0.0)) THEN + DSGD(I,J)=1.0/SIGMA-1.0/SGD(I,J) + ENDIF + 30 CONTINUE + 35 CONTINUE + ENDIF + ENDIF +*---- +* DETERMINATION OF THE PERTURBED ELEMENTS AND INCLUSION OF ELEMENTS +* NEIGHBOUR TO PERTURBED ZONES IN MCFD CASES. NON-PERTURBED ELEMENTS +* WILL HAVE VOL2(K)=0.0 +*---- + ALLOCATE(VOL2(NEL)) + IF((IPR.EQ.0).OR.(NALBP.GT.0)) THEN + DO 40 K=1,NEL + VOL2(K)=VOL(K) + 40 CONTINUE + ELSE + VOL2(:NEL)=0.0 + IF(ICHX.EQ.3) THEN +* MCFD CASE. + NUM1=0 + DO 70 L=1,NEL + IF(MAT(L).EQ.0) GO TO 70 + LSGD=.FALSE. + DO 50 I=1,4 + LSGD=LSGD.OR.(XSGD(MAT(L),I).NE.0.0) + 50 CONTINUE + IF(LSGD) THEN + VOL2(L)=VOL(L) + DO 60 I=1,6 + K=KN(NUM1+I) + IF(K.GT.0) THEN + IF(K.GT.NEL) CALL XABORT('TRIASM: INVALID BOUNDARY E' + 1 //'LEMENT INDEX.') + VOL2(K)=VOL(K) + ENDIF + 60 CONTINUE + ENDIF + NUM1=NUM1+6 + 70 CONTINUE + ELSE + DO 90 L=1,NEL + IF(MAT(L).EQ.0) GO TO 90 + LSGD=.FALSE. + DO 80 I=1,4 + LSGD=LSGD.OR.(XSGD(MAT(L),I).NE.0.0) + 80 CONTINUE + IF(LSGD) VOL2(L)=VOL(L) + 90 CONTINUE + ENDIF + ENDIF +*---- +* APPLY PHYSICAL ALBEDOS AND INTRODUCE THE CYLINDER BOUNDARY +* APPROXIMATION IN CARTESIAN GEOMETRY +*---- + IF(NR0.GT.0) THEN + IF(IPR.GT.0) CALL XABORT('TRIASM: PERTURBATION CALCULATION NO' + 1 //'T AVAILABLE WITH CYLINDRICAL CORRECTION.') + ALLOCATE(RR0(NR0),XR0(NR0),ANG(NR0)) + CALL LCMGET(IPTRK,'RR0',RR0) + CALL LCMGET(IPTRK,'XR0',XR0) + CALL LCMGET(IPTRK,'ANG',ANG) + CALL LCMGET(IPTRK,'NCODE',NCODE) + CALL LCMGET(IPTRK,'ICODE',ICODE) + CALL LCMGET(IPTRK,'ZCODE',ZCODE) + DO IC=1,6 + IF(ICHX.NE.2) THEN + ZALB(IC)=0.5*(1.0-ZCODE(IC))/(1.0+ZCODE(IC)) + ELSE IF((ICHX.EQ.2).AND.(ZCODE(IC).NE.1.0)) THEN + ZALB(IC)=2.0*(1.0+ZCODE(IC))/(1.0-ZCODE(IC)) + ELSE IF((ICHX.EQ.2).AND.(ZCODE(IC).EQ.1.0)) THEN + ZALB(IC)=1.0E20 + ENDIF + ENDDO + IF(NALBP.GT.0) THEN + DO IC=1,6 + IALB=ICODE(IC) + IF(IALB.NE.0) ZALB(IC)=GAMMA(IALB) + ENDDO + ENDIF + CALL TRICYL(MAXMIX,IMPX,ICHX,IDIM,LX,LY,LZ,XX,YY,ZZ,VOL,MAT, + 1 NCODE,ZALB,NR0,RR0,XR0,ANG,SGD,QFR) + DEALLOCATE(ANG,XR0,RR0) + ELSE IF(NALBP.GT.0) THEN + IF((IPR.GT.0).AND.(ICHX.NE.2)) CALL XABORT('TRIASM: PERTURBAT' + 1 //'ION CALCULATION NOT AVAILABLE WITH PHYSICAL ALBEDOS.') + DO IQW=1,MAXQF + IALB=IQFR(IQW) + IF(IALB.NE.0) QFR(IQW)=QFR(IQW)*GAMMA(IALB) + ENDDO + ELSE IF(IPR.GT.0) THEN + QFR(:MAXQF)=0.0 + ENDIF +*---- +* ASSEMBLY OF THE ADI SPLITTED SYSTEM MATRICES +*---- +* +* DIMENSION W + IF(CHEX) THEN + IF((ICHX.EQ.3).AND.(ISPLH.GT.1)) THEN + ALLOCATE(MATN(LL4)) + NUM1=0 + DO 110 I=1,LX*LZ + IF(MAT(I).EQ.0) GO TO 110 + DO 100 J=1,6*(ISPLH-1)**2 + KEL=KN(NUM1+J) + MATN(KEL)=MAT(I) + 100 CONTINUE + NUM1=NUM1+18*(ISPLH-1)**2+8 + 110 CONTINUE + ENDIF + IIMAW=MUW(LL4W) + IF(IPR.NE.3) THEN + IF((IPR.EQ.0).OR.(ICHX.NE.2)) THEN + WA_PTR=LCMARA(IIMAW) + CALL C_F_POINTER(WA_PTR,WA,(/ IIMAW /)) + ELSE + ALLOCATE(WA(IIMAW)) + ENDIF + WA(:IIMAW)=0.0 + ELSE + IF(ISEG.GT.0) CALL MTBLD('W_'//TEXT10,IPTRK,IPSYS,1) + CALL LCMGPD(IPSYS,'W_'//TEXT10,WA_PTR) + CALL C_F_POINTER(WA_PTR,WA,(/ IIMAW /)) + ENDIF + IF(ICHX.EQ.1) THEN +* MESH CORNER FINITE DIFFERENCES IN HEXAGONAL GEOMETRY. + CALL LCMGPD(IPTRK,'IPW',IPW_PTR) + CALL C_F_POINTER(IPW_PTR,IPW,(/ LL4 /)) + CALL TRIRWW(MAXMIX,NEL,LL4,VOL,MAT,XSGD,SIDE,ZZ,KN,QFR,MUW, + 1 WA,ISPLH,R,Q,RH,QH,RT,QT) + ELSE IF(ICHX.EQ.2) THEN +* THOMAS-RAVIART-SCHNEIDER FINITE ELEMENTS IN HEXAGONAL +* GEOMETRY. + IF(IPR.NE.3) THEN + TF_PTR=LCMARA(LL4F) + AW_PTR=LCMARA(IIMAW) + CALL C_F_POINTER(TF_PTR,TF,(/ LL4F /)) + CALL C_F_POINTER(AW_PTR,AW,(/ IIMAW /)) + TF(:LL4F)=0.0 + AW(:IIMAW)=0.0 + ELSE + IF(ISEG.GT.0) CALL MTBLD('WA'//TEXT10,IPTRK,IPSYS,1) + CALL LCMGPD(IPSYS,'TF'//TEXT10,TF_PTR) + CALL LCMGPD(IPSYS,'WA'//TEXT10,AW_PTR) + CALL C_F_POINTER(TF_PTR,TF,(/ LL4F /)) + CALL C_F_POINTER(AW_PTR,AW,(/ IIMAW /)) + ENDIF + NBLOS=LX*LZ/3 + ALLOCATE(IPERT(NBLOS),FRZ(NBLOS),DIF(NBLOS)) + CALL LCMGPD(IPTRK,'IPBBW',IPBW_PTR) + CALL LCMGPD(IPTRK,'WB',BW_PTR) + CALL C_F_POINTER(IPBW_PTR,IPBW,(/ 2*IELEM*LL4W /)) + CALL C_F_POINTER(BW_PTR,BW,(/ 2*IELEM*LL4W /)) + CALL LCMGET(IPTRK,'IPERT',IPERT) + CALL LCMGET(IPTRK,'FRZ',FRZ) + DO 120 KEL=1,NBLOS + DIF(KEL)=0.0 + IF(IPERT(KEL).GT.0) THEN + IBM=MAT((IPERT(KEL)-1)*3+1) + DZ=ZZ((IPERT(KEL)-1)*3+1)*FRZ(KEL) + IF(IBM.GT.0) DIF(KEL)=DZ/SGD(IBM,1) + ENDIF + 120 CONTINUE + CALL LCMPUT(IPSYS,'DIFF'//TEXT10,NBLOS,2,DIF) + CALL TRIHWW(MAXMIX,NBLOS,IELEM,LL4F,LL4W,MAT,SIDE,ZZ,FRZ, + 1 QFR,IPERT,KN,XSGD,DSGD,MUW,IPBW,LC,R,V,BW,TF,AW,WA) + DEALLOCATE(DIF,FRZ,IPERT) + ELSE IF(ICHX.EQ.3) THEN +* MESH CENTERED FINITE DIFFERENCES IN HEXAGONAL GEOMETRY. + CALL LCMGPD(IPTRK,'IPW',IPW_PTR) + CALL C_F_POINTER(IPW_PTR,IPW,(/ LL4 /)) + IF(ISPLH.EQ.1) THEN + CALL TRIMWW(MAXMIX,NEL,LL4,VOL,MAT,SGD,XSGD,SIDE,ZZ,KN, + 1 QFR,MUW,IPW,IPR,WA) + ELSE + CALL TRIMTW(ISPLH,MAXMIX,NEL,LL4,VOL,MAT,MATN,SGD,XSGD, + 1 SIDE,ZZ,KN,QFR,MUW,IPW,IPR,WA) + ENDIF + ENDIF + IF((IPR.EQ.0).OR.(IPR.EQ.3).OR.(ICHX.NE.2)) THEN + CALL LCMPPD(IPSYS,'W_'//TEXT10,IIMAW,2,WA_PTR) + ELSE + DEALLOCATE(WA) + ENDIF + IF(ICHX.EQ.2) THEN + CALL LCMPPD(IPSYS,'WA'//TEXT10,IIMAW,2,AW_PTR) + CALL LCMPPD(IPSYS,'TF'//TEXT10,LL4F,2,TF_PTR) + ENDIF + ENDIF +* +* DIMENSION X + IIMAX=MUX(LL4X) + IF(CHEX.AND.(ICHX.EQ.2)) THEN +* THOMAS-RAVIART-SCHNEIDER FINITE ELEMENTS IN HEXAGONAL GEOMETRY. + IF(IPR.NE.3) THEN + AX_PTR=LCMARA(IIMAX) + CALL C_F_POINTER(AX_PTR,AX,(/ IIMAX /)) + AX(:IIMAX)=0.0 + ELSE + IF(ISEG.GT.0) CALL MTBLD('XA'//TEXT10,IPTRK,IPSYS,1) + CALL LCMGPD(IPSYS,'XA'//TEXT10,AX_PTR) + CALL C_F_POINTER(AX_PTR,AX,(/ IIMAX /)) + ENDIF + NBLOS=LX*LZ/3 + ALLOCATE(IPERT(NBLOS),FRZ(NBLOS)) + CALL LCMGPD(IPSYS,'TF'//TEXT10,TF_PTR) + CALL C_F_POINTER(TF_PTR,TF,(/ LL4F /)) + CALL LCMGPD(IPTRK,'IPBBX',IPBX_PTR) + CALL LCMGPD(IPTRK,'XB',BX_PTR) + CALL C_F_POINTER(IPBX_PTR,IPBX,(/ 2*IELEM*LL4X /)) + CALL C_F_POINTER(BX_PTR,BX,(/ 2*IELEM*LL4X /)) + CALL LCMGET(IPTRK,'IPERT',IPERT) + CALL LCMGET(IPTRK,'FRZ',FRZ) + IF((IPR.EQ.0).OR.(IPR.EQ.3)) THEN + XA_PTR=LCMARA(IIMAX) + CALL C_F_POINTER(XA_PTR,XA,(/ IIMAX /)) + ELSE + ALLOCATE(XA(IIMAX)) + ENDIF + CALL TRIHWX(MAXMIX,NBLOS,IELEM,LL4F,LL4W,LL4X,MAT,SIDE,ZZ,FRZ, + 1 QFR,IPERT,KN,DSGD,MUX,IPBX,LC,R,BX,TF,AX,XA) + DEALLOCATE(FRZ,IPERT) + ELSE IF(ICHX.EQ.2) THEN +* THOMAS-RAVIART ADI ITERATIVE METHOD. + IF(DIAG) THEN + ALLOCATE(AX(IIMAX)) + IF(IPR.NE.3) THEN + TF_PTR=LCMARA(LL4F) + CALL C_F_POINTER(TF_PTR,TF,(/ LL4F /)) + TF(:LL4F)=0.0 + AX(:IIMAX)=0.0 + ELSE + IF(ISEG.GT.0) CALL MTBLD('XA'//TEXT10,IPTRK,IPSYS,1) + CALL LCMGPD(IPSYS,'TF'//TEXT10,TF_PTR) + CALL C_F_POINTER(TF_PTR,TF,(/ LL4F /)) + CALL LCMGET(IPSYS,'XA'//TEXT10,AX) + ENDIF + ALLOCATE(XA(IIMAX)) + ELSE + IF(IPR.NE.3) THEN + TF_PTR=LCMARA(LL4F) + AX_PTR=LCMARA(IIMAX) + CALL C_F_POINTER(TF_PTR,TF,(/ LL4F /)) + CALL C_F_POINTER(AX_PTR,AX,(/ IIMAX /)) + TF(:LL4F)=0.0 + AX(:IIMAX)=0.0 + ELSE + IF(ISEG.GT.0) CALL MTBLD('XA'//TEXT10,IPTRK,IPSYS,1) + CALL LCMGPD(IPSYS,'TF'//TEXT10,TF_PTR) + CALL LCMGPD(IPSYS,'XA'//TEXT10,AX_PTR) + CALL C_F_POINTER(TF_PTR,TF,(/ LL4F /)) + CALL C_F_POINTER(AX_PTR,AX,(/ IIMAX /)) + ENDIF + IF((IPR.EQ.0).OR.(IPR.EQ.3)) THEN + XA_PTR=LCMARA(IIMAX) + CALL C_F_POINTER(XA_PTR,XA,(/ IIMAX /)) + ELSE + ALLOCATE(XA(IIMAX)) + ENDIF + ENDIF + CALL LCMGPD(IPTRK,'IPBBX',IPBX_PTR) + CALL LCMGPD(IPTRK,'XB',BX_PTR) + CALL C_F_POINTER(IPBX_PTR,IPBX,(/ 2*IELEM*LL4X /)) + CALL C_F_POINTER(BX_PTR,BX,(/ 2*IELEM*LL4X /)) + CALL TRIDXX(MAXMIX,CYLIND,IELEM,ICOL,NEL,LL4F,LL4X,MAT,VOL2, + 1 XX,YY,ZZ,DD,KN,QFR,XSGD,DSGD,MUX,IPBX,LC,R,V,BX,TF,AX,XA) + ELSE +* GENERIC ADI ITERATIVE METHOD. + CALL LCMGPD(IPTRK,'IPX',IPX_PTR) + CALL C_F_POINTER(IPX_PTR,IPX,(/ LL4 /)) + IF(DIAG) THEN + ALLOCATE(XA(IIMAX)) + XA(:IIMAX)=0.0 + ELSE IF(IPR.NE.3) THEN + XA_PTR=LCMARA(IIMAX) + CALL C_F_POINTER(XA_PTR,XA,(/ IIMAX /)) + XA(:IIMAX)=0.0 + ELSE + IF(ISEG.GT.0) CALL MTBLD('X_'//TEXT10,IPTRK,IPSYS,1) + CALL LCMGPD(IPSYS,'X_'//TEXT10,XA_PTR) + CALL C_F_POINTER(XA_PTR,XA,(/ IIMAX /)) + ENDIF + IF((ICHX.EQ.1).AND.(.NOT.CHEX)) THEN + CALL TRIPXX(MAXMIX,MAXKN,NEL,LL4,VOL2,MAT,XSGD,XX,YY,ZZ,DD, + 1 KN,QFR,MUX,IPX,CYLIND,LC,T,TS,Q,QS,XA) + ELSE IF((ICHX.EQ.3).AND.(.NOT.CHEX)) THEN + CALL TRIMXX(MAXMIX,CYLIND,IELEM,IDIM,NEL,LL4,VOL2,MAT,SGD, + 1 XSGD,XX,YY,ZZ,DD,KN,QFR,MUX,IPX,IPR,XA) + ELSE IF((ICHX.EQ.1).AND.CHEX) THEN +* MESH CORNER FINITE DIFFERENCES IN HEXAGONAL GEOMETRY. + CALL TRIRWX(MAXMIX,NEL,LL4,VOL,MAT,XSGD,SIDE,ZZ,KN,QFR, + 1 MUX,IPX,XA,ISPLH,R,Q,RH,QH,RT,QT) + ELSE IF((ICHX.EQ.3).AND.CHEX) THEN +* MESH CENTERED FINITE DIFFERENCES IN HEXAGONAL GEOMETRY. + IF(ISPLH.EQ.1) THEN + CALL TRIMWX(MAXMIX,NEL,LL4,VOL,MAT,SGD,XSGD,SIDE,ZZ,KN, + 1 QFR,MUX,IPX,IPR,XA) + ELSE + CALL TRIMTX(ISPLH,MAXMIX,NEL,LL4,VOL,MAT,MATN,SGD,XSGD, + 1 SIDE,ZZ,KN,QFR,MUX,IPX,IPR,XA) + ENDIF + ENDIF + ENDIF + IF(.NOT.DIAG) THEN + IF((IPR.EQ.0).OR.(IPR.EQ.3).OR.(ICHX.NE.2)) THEN + CALL LCMPPD(IPSYS,'X_'//TEXT10,IIMAX,2,XA_PTR) + ELSE + DEALLOCATE(XA) + ENDIF + IF(ICHX.EQ.2) CALL LCMPPD(IPSYS,'XA'//TEXT10,IIMAX,2,AX_PTR) + ELSE +* IN DIAGONAL SYMMETRY CASE, DO NOT SAVE THE X-DIRECTED ADI +* MATRIX COMPONENT SINCE IT IS EQUAL TO THE Y-DIRECTED COMPONENT + DEALLOCATE(XA) + IF(ICHX.EQ.2) DEALLOCATE(AX) + ENDIF + IF(.NOT.CHEX.AND.(ICHX.EQ.2)) CALL LCMPPD(IPSYS,'TF'//TEXT10,LL4F, + 1 2,TF_PTR) +* +* DIMENSION Y + IF(LOGY) THEN + IIMAY=MUY(LL4Y) + IF(CHEX.AND.(ICHX.EQ.2)) THEN +* THOMAS-RAVIART-SCHNEIDER FINITE ELEMENTS IN HEXAGONAL +* GEOMETRY. + IF(IPR.NE.3) THEN + AY_PTR=LCMARA(IIMAY) + CALL C_F_POINTER(AY_PTR,AY,(/ IIMAY /)) + AY(:IIMAY)=0.0 + ELSE + IF(ISEG.GT.0) CALL MTBLD('YA'//TEXT10,IPTRK,IPSYS,1) + CALL LCMGPD(IPSYS,'YA'//TEXT10,AY_PTR) + CALL C_F_POINTER(AY_PTR,AY,(/ IIMAY /)) + ENDIF + NBLOS=LX*LZ/3 + ALLOCATE(IPERT(NBLOS),FRZ(NBLOS)) + CALL LCMGPD(IPSYS,'TF'//TEXT10,TF_PTR) + CALL C_F_POINTER(TF_PTR,TF,(/ LL4F /)) + CALL LCMGPD(IPTRK,'IPBBY',IPBY_PTR) + CALL LCMGPD(IPTRK,'YB',BY_PTR) + CALL C_F_POINTER(IPBY_PTR,IPBY,(/ 2*IELEM*LL4Y /)) + CALL C_F_POINTER(BY_PTR,BY,(/ 2*IELEM*LL4Y /)) + CALL LCMGET(IPTRK,'IPERT',IPERT) + CALL LCMGET(IPTRK,'FRZ',FRZ) + IF((IPR.EQ.0).OR.(IPR.EQ.3)) THEN + YA_PTR=LCMARA(IIMAY) + CALL C_F_POINTER(YA_PTR,YA,(/ IIMAY /)) + ELSE + ALLOCATE(YA(IIMAY)) + ENDIF + CALL TRIHWY(MAXMIX,NBLOS,IELEM,LL4F,LL4W,LL4X,LL4Y,MAT, + 1 SIDE,ZZ,FRZ,QFR,IPERT,KN,DSGD,MUY,IPBY,LC,R,BY,TF,AY,YA) + DEALLOCATE(FRZ,IPERT) + ELSE IF(ICHX.EQ.2) THEN +* THOMAS-RAVIART ADI ITERATIVE METHOD. + IF(IPR.NE.3) THEN + AY_PTR=LCMARA(IIMAY) + CALL C_F_POINTER(AY_PTR,AY,(/ IIMAY /)) + AY(:IIMAY)=0.0 + ELSE + IF(ISEG.GT.0) CALL MTBLD('YA'//TEXT10,IPTRK,IPSYS,1) + CALL LCMGPD(IPSYS,'YA'//TEXT10,AY_PTR) + CALL C_F_POINTER(AY_PTR,AY,(/ IIMAY /)) + ENDIF + CALL LCMGPD(IPSYS,'TF'//TEXT10,TF_PTR) + CALL LCMGPD(IPTRK,'IPBBY',IPBY_PTR) + CALL LCMGPD(IPTRK,'YB',BY_PTR) + CALL C_F_POINTER(TF_PTR,TF,(/ LL4F /)) + CALL C_F_POINTER(IPBY_PTR,IPBY,(/ 2*IELEM*LL4Y /)) + CALL C_F_POINTER(BY_PTR,BY,(/ 2*IELEM*LL4Y /)) + IF((IPR.EQ.0).OR.(IPR.EQ.3)) THEN + YA_PTR=LCMARA(IIMAY) + CALL C_F_POINTER(YA_PTR,YA,(/ IIMAY /)) + ELSE + ALLOCATE(YA(IIMAY)) + ENDIF + CALL TRIDXY(MAXMIX,IELEM,ICOL,NEL,LL4F,LL4X,LL4Y,MAT,VOL2, + 1 YY,KN,QFR,DSGD,MUY,IPBY,LC,R,BY,TF,AY,YA) + ELSE +* GENERIC ADI ITERATIVE METHOD. + CALL LCMGPD(IPTRK,'IPY',IPY_PTR) + CALL C_F_POINTER(IPY_PTR,IPY,(/ LL4 /)) + IF(IPR.NE.3) THEN + YA_PTR=LCMARA(IIMAY) + CALL C_F_POINTER(YA_PTR,YA,(/ IIMAY /)) + YA(:IIMAY)=0.0 + ELSE + IF(ISEG.GT.0) CALL MTBLD('Y_'//TEXT10,IPTRK,IPSYS,1) + CALL LCMGPD(IPSYS,'Y_'//TEXT10,YA_PTR) + CALL C_F_POINTER(YA_PTR,YA,(/ IIMAY /)) + ENDIF + IF((ICHX.EQ.1).AND.(.NOT.CHEX)) THEN + CALL TRIPXY(MAXMIX,MAXKN,NEL,LL4,VOL2,MAT,XSGD,XX,YY,ZZ, + 1 DD,KN,QFR,MUY,IPY,CYLIND,LC,T,TS,Q,QS,YA) + ELSE IF((ICHX.EQ.3).AND.(.NOT.CHEX)) THEN + CALL TRIMXY(MAXMIX,CYLIND,IELEM,IDIM,NEL,LL4,VOL2,MAT, + 1 SGD,XSGD,XX,YY,ZZ,DD,KN,QFR,MUY,IPY,IPR,YA) + ELSE IF((ICHX.EQ.1).AND.CHEX) THEN +* MESH CORNER FINITE DIFFERENCES IN HEXAGONAL GEOMETRY. + CALL TRIRWY(MAXMIX,NEL,LL4,VOL,MAT,XSGD,SIDE,ZZ, + 1 KN,QFR,MUY,IPY,YA,ISPLH,R,Q,RH,QH,RT,QT) + ELSE IF((ICHX.EQ.3).AND.CHEX) THEN +* MESH CENTERED FINITE DIFFERENCES IN HEXAGONAL GEOMETRY. + IF(ISPLH.EQ.1) THEN + CALL TRIMWY(MAXMIX,NEL,LL4,VOL,MAT,SGD,XSGD,SIDE,ZZ, + 1 KN,QFR,MUY,IPY,IPR,YA) + ELSE + CALL TRIMTY(ISPLH,MAXMIX,NEL,LL4,VOL,MAT,MATN,SGD, + 1 XSGD,SIDE,ZZ,KN,QFR,MUY,IPY,IPR,YA) + ENDIF + ENDIF + ENDIF + IF((IPR.EQ.0).OR.(IPR.EQ.3).OR.(ICHX.NE.2)) THEN + CALL LCMPPD(IPSYS,'Y_'//TEXT10,IIMAY,2,YA_PTR) + ELSE + DEALLOCATE(YA) + ENDIF + IF(ICHX.EQ.2) CALL LCMPPD(IPSYS,'YA'//TEXT10,IIMAY,2,AY_PTR) + ENDIF +* +* DIMENSION Z + IF(LOGZ) THEN + IIMAZ=MUZ(LL4Z) + IF(CHEX.AND.(ICHX.EQ.2)) THEN +* THOMAS-RAVIART-SCHNEIDER FINITE ELEMENTS IN HEXAGONAL +* GEOMETRY. + IF(IPR.NE.3) THEN + AZ_PTR=LCMARA(IIMAZ) + CALL C_F_POINTER(AZ_PTR,AZ,(/ IIMAZ /)) + AZ(:IIMAZ)=0.0 + ELSE + IF(ISEG.GT.0) CALL MTBLD('ZA'//TEXT10,IPTRK,IPSYS,1) + CALL LCMGPD(IPSYS,'ZA'//TEXT10,AZ_PTR) + CALL C_F_POINTER(AZ_PTR,AZ,(/ IIMAZ /)) + ENDIF + NBLOS=LX*LZ/3 + ALLOCATE(IPERT(NBLOS),FRZ(NBLOS)) + CALL LCMGPD(IPSYS,'TF'//TEXT10,TF_PTR) + CALL C_F_POINTER(TF_PTR,TF,(/ LL4F /)) + CALL LCMGPD(IPTRK,'IPBBZ',IPBZ_PTR) + CALL LCMGPD(IPTRK,'ZB',BZ_PTR) + CALL C_F_POINTER(IPBZ_PTR,IPBZ,(/ 2*IELEM*LL4Z /)) + CALL C_F_POINTER(BZ_PTR,BZ,(/ 2*IELEM*LL4Z /)) + CALL LCMGET(IPTRK,'IPERT',IPERT) + CALL LCMGET(IPTRK,'FRZ',FRZ) + IF((IPR.EQ.0).OR.(IPR.EQ.3)) THEN + ZA_PTR=LCMARA(IIMAZ) + CALL C_F_POINTER(ZA_PTR,ZA,(/ IIMAZ /)) + ELSE + ALLOCATE(ZA(IIMAZ)) + ENDIF + CALL TRIHWZ(MAXMIX,NBLOS,IELEM,ICOL,LL4F,LL4W,LL4X,LL4Y, + 1 LL4Z,MAT,SIDE,ZZ,FRZ,QFR,IPERT,KN,DSGD,MUZ,IPBZ,LC,R,BZ, + 2 TF,AZ,ZA) + DEALLOCATE(FRZ,IPERT) + ELSE IF(ICHX.EQ.2) THEN +* THOMAS-RAVIART ADI ITERATIVE METHOD. + IF(IPR.NE.3) THEN + AZ_PTR=LCMARA(IIMAZ) + CALL C_F_POINTER(AZ_PTR,AZ,(/ IIMAZ /)) + AZ(:IIMAZ)=0.0 + ELSE + IF(ISEG.GT.0) CALL MTBLD('ZA'//TEXT10,IPTRK,IPSYS,1) + CALL LCMGPD(IPSYS,'ZA'//TEXT10,AZ_PTR) + CALL C_F_POINTER(AZ_PTR,AZ,(/ IIMAZ /)) + ENDIF + CALL LCMGPD(IPSYS,'TF'//TEXT10,TF_PTR) + CALL LCMGPD(IPTRK,'IPBBZ',IPBZ_PTR) + CALL LCMGPD(IPTRK,'ZB',BZ_PTR) + CALL C_F_POINTER(TF_PTR,TF,(/ LL4F /)) + CALL C_F_POINTER(IPBZ_PTR,IPBZ,(/ 2*IELEM*LL4Z /)) + CALL C_F_POINTER(BZ_PTR,BZ,(/ 2*IELEM*LL4Z /)) + IF((IPR.EQ.0).OR.(IPR.EQ.3)) THEN + ZA_PTR=LCMARA(IIMAZ) + CALL C_F_POINTER(ZA_PTR,ZA,(/ IIMAZ /)) + ELSE + ALLOCATE(ZA(IIMAZ)) + ENDIF + CALL TRIDXZ(MAXMIX,IELEM,ICOL,NEL,LL4F,LL4X,LL4Y,LL4Z,MAT, + 1 VOL2,ZZ,KN,QFR,DSGD,MUZ,IPBZ,LC,R,BZ,TF,AZ,ZA) + ELSE + CALL LCMGPD(IPTRK,'IPZ',IPZ_PTR) + CALL C_F_POINTER(IPZ_PTR,IPZ,(/ LL4 /)) + IF(IPR.NE.3) THEN + ZA_PTR=LCMARA(IIMAZ) + CALL C_F_POINTER(ZA_PTR,ZA,(/ IIMAZ /)) + ZA(:IIMAZ)=0.0 + ELSE + IF(ISEG.GT.0) CALL MTBLD('Z_'//TEXT10,IPTRK,IPSYS,1) + CALL LCMGPD(IPSYS,'Z_'//TEXT10,ZA_PTR) + CALL C_F_POINTER(ZA_PTR,ZA,(/ IIMAZ /)) + ENDIF + IF((ICHX.EQ.1).AND.(.NOT.CHEX)) THEN + CALL TRIPXZ(MAXMIX,MAXKN,NEL,LL4,VOL2,MAT,XSGD,XX,YY,ZZ, + 1 DD,KN,QFR,MUZ,IPZ,CYLIND,LC,T,TS,Q,QS,ZA) + ELSE IF((ICHX.EQ.3).AND.(.NOT.CHEX)) THEN + CALL TRIMXZ(MAXMIX,CYLIND,IELEM,NEL,LL4,VOL2,MAT,SGD, + 1 XSGD,XX,YY,ZZ,DD,KN,QFR,MUZ,IPZ,IPR,ZA) + ELSE IF((ICHX.EQ.1).AND.CHEX) THEN +* MESH CORNER FINITE DIFFERENCES IN HEXAGONAL GEOMETRY. + CALL TRIRWZ(MAXMIX,NEL,LL4,VOL,MAT,XSGD,SIDE,ZZ,KN,QFR, + 1 MUZ,IPZ,ZA,ISPLH,R,Q,RH,QH,RT,QT) + ELSE IF((ICHX.EQ.3).AND.CHEX) THEN +* MESH CENTERED FINITE DIFFERENCES IN HEXAGONAL GEOMETRY. + IF(ISPLH.EQ.1) THEN + CALL TRIMWZ(MAXMIX,NEL,LL4,VOL,MAT,SGD,XSGD,SIDE,ZZ, + 1 KN,QFR,MUZ,IPZ,IPR,ZA) + ELSE + CALL TRIMTZ(ISPLH,MAXMIX,NEL,LL4,VOL,MAT,MATN,SGD, + 1 XSGD,SIDE,ZZ,KN,QFR,MUZ,IPZ,IPR,ZA) + ENDIF + ENDIF + ENDIF + IF((IPR.EQ.0).OR.(IPR.EQ.3).OR.(ICHX.NE.2)) THEN + CALL LCMPPD(IPSYS,'Z_'//TEXT10,IIMAZ,2,ZA_PTR) + ELSE + DEALLOCATE(ZA) + ENDIF + IF(ICHX.EQ.2) CALL LCMPPD(IPSYS,'ZA'//TEXT10,IIMAZ,2,AZ_PTR) + ENDIF + DEALLOCATE(VOL2) + IF(ICHX.EQ.2) DEALLOCATE(DSGD) + IF((ICHX.EQ.3).AND.(ISPLH.GT.1).AND.CHEX) DEALLOCATE(MATN) +*---- +* CHECK FOR MATRIX CONSISTENCY +*---- + IF(ICHX.NE.2) CALL TRICHK (TEXT10,IPTRK,IPSYS,IDIM,DIAG,CHEX, + 1 IPR,LL4) + CALL KDRCPU(TK2) + IF(IMPX.GT.1) WRITE(6,'(/35H TRIASM: CPU TIME FOR SYSTEM MATRIX, + 1 11H ASSEMBLY =,F9.2,3H S.)') TK2-TK1 +*---- +* PERFORM SUPERVECTORIZATION REBUILD OF THE COEFFICIENT MATRICES +*---- + IF(ISEG.GT.0) THEN + IF((IPR.EQ.0).OR.(IPR.EQ.3).OR.(ICHX.NE.2)) THEN + IF(CHEX) CALL MTBLD('W_'//TEXT10,IPTRK,IPSYS,3) + IF(.NOT.DIAG) CALL MTBLD('X_'//TEXT10,IPTRK,IPSYS,3) + IF(LOGY) CALL MTBLD('Y_'//TEXT10,IPTRK,IPSYS,3) + IF(LOGZ) CALL MTBLD('Z_'//TEXT10,IPTRK,IPSYS,3) + ENDIF + IF(ICHX.EQ.2) THEN + IF(CHEX) CALL MTBLD('WA'//TEXT10,IPTRK,IPSYS,3) + IF(.NOT.DIAG) CALL MTBLD('XA'//TEXT10,IPTRK,IPSYS,3) + IF(LOGY) CALL MTBLD('YA'//TEXT10,IPTRK,IPSYS,3) + IF(LOGZ) CALL MTBLD('ZA'//TEXT10,IPTRK,IPSYS,3) + ENDIF + ENDIF +*---- +* MATRIX FACTORIZATIONS +*---- + IF((IPR.EQ.0).OR.(IPR.EQ.3)) THEN + CALL KDRCPU(TK1) + CALL MTLDLF(TEXT10,IPTRK,IPSYS,ITY,IMPX) + CALL KDRCPU(TK2) + IF(IMPX.GT.1) WRITE(6,'(/34H TRIASM: CPU TIME FOR LDLT FACTORI, + 1 18HZATION OF MATRIX '',A10,2H''=,F9.2,3H S.)') TEXT10,TK2-TK1 + ENDIF +*---- +* RELEASE UNIT MATRICES +*---- + IF((ICHX.EQ.1).OR.(ICHX.EQ.2)) THEN + DEALLOCATE(T,TS,R,RS,Q,QS,V,RH,QH,RT,QT) + ENDIF +*---- +* RELEASE TRIVAC SPECIFIC TRACKING INFORMATION +*---- + DEALLOCATE(IQFR,QFR,KN,ZZ) + IF(CHEX) THEN + DEALLOCATE(MUW) + ELSE + DEALLOCATE(DD,YY,XX) + ENDIF + IF(LOGY) DEALLOCATE(MUY) + IF(.NOT.DIAG) DEALLOCATE(MUX) + IF(LOGZ) DEALLOCATE(MUZ) + RETURN + END diff --git a/Trivac/src/TRIASN.f b/Trivac/src/TRIASN.f new file mode 100755 index 0000000..a1358ba --- /dev/null +++ b/Trivac/src/TRIASN.f @@ -0,0 +1,539 @@ +*DECK TRIASN + SUBROUTINE TRIASN(HNAMT,IPTRK,IPSYS,IMPX,NBMIX,NEL,NAN,NALBP,IPR, + 1 MAT,VOL,GAMMA,SIGT,SIGTI) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Assembly of a single-group system matrix with leakage and removal +* cross sections for the simplified PN method. +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* HNAMT name of the matrix. +* IPTRK L_TRACK pointer to the TRIVAC tracking information. +* IPSYS L_SYSTEM pointer to system matrices. +* IMPX print parameter (equal to zero for no print). +* NBMIX number of mixtures. +* NEL total number of finite elements. +* NAN number of Legendre orders for the cross sections. +* NALBP number of physical albedos. +* IPR type of assembly: +* =0: calculation of the system matrices; +* =1: calculation of the derivative of these matrices; +* =2: calculation of the first variation of these matrices; +* =3: identical to IPR=2, but these variation are added to +* unperturbed system matrices. +* MAT index-number of the mixture type assigned to each volume. +* GAMMA physical albedo functions. +* VOL volumes. +* SIGT total minus self-scattering macroscopic cross sections. +* SIGT(:,NAN) generally contains the total cross section only. +* If IPR.gt.0, SIGT contains perturbed or derivative values. +* SIGTI inverse macroscopic cross sections ordered by mixture. +* SIGTI(:,NAN) generally contains the inverse total cross +* section only. If IPR.gt.0, SIGTI contains perturbed or +* derivative values. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPSYS + CHARACTER HNAMT*10 + INTEGER IMPX,NBMIX,NEL,NAN,IPR,MAT(NEL) + REAL VOL(NEL),GAMMA(NALBP),SIGT(NBMIX,NAN),SIGTI(NBMIX,NAN) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + LOGICAL CYLIND,CHEX,DIAG,LSGD + CHARACTER TEXT10*10 + INTEGER ISTATE(NSTATE) + INTEGER, DIMENSION(:), ALLOCATABLE :: KN,IQFR,MUW,MUZ,IPERT + INTEGER, DIMENSION(:), POINTER :: MUX + INTEGER, DIMENSION(:), ALLOCATABLE, TARGET :: MUY + REAL, DIMENSION(:), ALLOCATABLE :: VOL2,XX,YY,ZZ,QFR,FRZ,DIF + REAL, DIMENSION(:,:), ALLOCATABLE :: R,V + INTEGER, DIMENSION(:), POINTER :: IPBW,IPBX,IPBY,IPBZ + REAL, DIMENSION(:), POINTER :: TF,AW,AX,AY,AZ,WA,XA,YA,ZA,BW,BX, + 1 BY,BZ + TYPE(C_PTR) IPBW_PTR,IPBX_PTR,IPBY_PTR,IPBZ_PTR + TYPE(C_PTR) TF_PTR,AW_PTR,AX_PTR,AY_PTR,AZ_PTR,WA_PTR,XA_PTR, + 1 YA_PTR,ZA_PTR,BW_PTR,BX_PTR,BY_PTR,BZ_PTR +*---- +* RECOVER TRIVAC SPECIFIC TRACKING INFORMATION +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + ITYPE=ISTATE(6) + CYLIND=(ITYPE.EQ.3).OR.(ITYPE.EQ.6) + CHEX=(ITYPE.EQ.8).OR.(ITYPE.EQ.9) + IF(CYLIND) CALL XABORT('TRIASN: GEOMETRY NOT AVAILABLE.') + IHEX=ISTATE(7) + DIAG=(ISTATE(8).EQ.1) + IELEM=ISTATE(9) + ICOL=ISTATE(10) + LL4=ISTATE(11) + ICHX=ISTATE(12) + IF(ICHX.NE.2) CALL XABORT('TRIASN: DISCRETIZATION NOT AVAILABLE.') + ISPLH=ISTATE(13) + LX=ISTATE(14) + LY=ISTATE(15) + LZ=ISTATE(16) + ISEG=ISTATE(17) + IMPV=ISTATE(18) + NR0=ISTATE(24) + LL4F=ISTATE(25) + ITY=3 + LL4W=ISTATE(26) + LL4X=ISTATE(27) + LL4Y=ISTATE(28) + LL4Z=ISTATE(29) + NLF=ISTATE(30) + NVD=ISTATE(34) + CALL LCMLEN(IPTRK,'KN',MAXKN,ITYLCM) + CALL LCMLEN(IPTRK,'QFR',MAXQF,ITYLCM) + ALLOCATE(ZZ(LX*LY*LZ),KN(MAXKN),QFR(MAXQF),IQFR(MAXQF)) + CALL LCMGET(IPTRK,'ZZ',ZZ) + CALL LCMGET(IPTRK,'KN',KN) + CALL LCMGET(IPTRK,'QFR',QFR) + CALL LCMGET(IPTRK,'IQFR',IQFR) + IF(CHEX) THEN + CALL LCMGET(IPTRK,'SIDE',SIDE) + ALLOCATE(MUW(LL4W)) + CALL LCMGET(IPTRK,'MUW',MUW) + ELSE + ALLOCATE(XX(LX*LY*LZ),YY(LX*LY*LZ)) + CALL LCMGET(IPTRK,'XX',XX) + CALL LCMGET(IPTRK,'YY',YY) + ENDIF + IF(LL4Y.GT.0) THEN + ALLOCATE(MUY(LL4Y)) + CALL LCMGET(IPTRK,'MUY',MUY) + ENDIF + IF(.NOT.DIAG) THEN + ALLOCATE(MUX(LL4X)) + CALL LCMGET(IPTRK,'MUX',MUX) + ELSE + MUX=>MUY + ENDIF + IF(LL4Z.GT.0) THEN + ALLOCATE(MUZ(LL4Z)) + CALL LCMGET(IPTRK,'MUZ',MUZ) + ENDIF +*---- +* RECOVER UNIT MATRICES +*---- + CALL LCMSIX(IPTRK,'BIVCOL',1) + CALL LCMLEN(IPTRK,'T',LC,ITYLCM) + ALLOCATE(R(LC,LC),V(LC,LC-1)) + CALL LCMGET(IPTRK,'R',R) + CALL LCMGET(IPTRK,'V',V) + CALL LCMSIX(IPTRK,' ',2) +* + TEXT10=HNAMT(:10) + IF(IMPX.GT.0) WRITE(6,'(/36H TRIASN: ASSEMBLY OF SYMMETRIC MATRI, + 1 3HX '',A10,38H'' IN COMPRESSED DIAGONAL STORAGE MODE.)') TEXT10 + CALL KDRCPU(TK1) +*---- +* DETERMINATION OF THE PERTURBED ELEMENTS. NON-PERTURBED ELEMENTS WILL +* HAVE VOL(K)=0.0 +*---- + ALLOCATE(VOL2(NEL)) + IF((IPR.EQ.0).OR.(NALBP.GT.0)) THEN + DO 25 K=1,NEL + VOL2(K)=VOL(K) + 25 CONTINUE + ELSE + VOL2(:NEL)=0.0 + DO 50 L=1,NEL + IBM=MAT(L) + IF(IBM.EQ.0) GO TO 50 + LSGD=.FALSE. + DO 45 I=1,NAN + LSGD=LSGD.OR.(SIGT(IBM,I).NE.0.0).OR.(SIGTI(IBM,I).NE.0.0) + 45 CONTINUE + IF(LSGD) VOL2(L)=VOL(L) + 50 CONTINUE + ENDIF +*---- +* APPLY PHYSICAL ALBEDOS AND INTRODUCE THE CYLINDER BOUNDARY +* APPROXIMATION IN CARTESIAN GEOMETRY +*---- + IF(NR0.GT.0) THEN + CALL XABORT('TRIASN: CYLINDRICAL CORRECTION NOT IMPLEMENTED.') + ELSE IF(NALBP.GT.0) THEN + DO IQW=1,MAXQF + IALB=IQFR(IQW) + IF(IALB.NE.0) QFR(IQW)=QFR(IQW)*GAMMA(IALB) + ENDDO + ELSE IF(IPR.GT.0) THEN + QFR(:MAXQF)=0.0 + ENDIF +*---- +* ASSEMBLY OF THE ADI SPLITTED SYSTEM MATRICES +*---- +* +* DIMENSION W + IF(CHEX) THEN + IIMAW=MUW(LL4W)*NLF/2 + IF(DIAG.OR.(IPR.NE.3)) THEN + TF_PTR=LCMARA(LL4F*NLF/2) + AW_PTR=LCMARA(IIMAW) + CALL C_F_POINTER(TF_PTR,TF,(/ LL4F*NLF/2 /)) + CALL C_F_POINTER(AW_PTR,AW,(/ IIMAW /)) + TF(:LL4F*NLF/2)=0.0 + AW(:IIMAW)=0.0 + ELSE + IF(ISEG.GT.0) CALL MTBLD('WA'//TEXT10,IPTRK,IPSYS,1) + CALL LCMGPD(IPSYS,'TF'//TEXT10,TF_PTR) + CALL LCMGPD(IPSYS,'WA'//TEXT10,AW_PTR) + CALL C_F_POINTER(TF_PTR,TF,(/ LL4F*NLF/2 /)) + CALL C_F_POINTER(AW_PTR,AW,(/ IIMAW /)) + ENDIF + CALL LCMGPD(IPTRK,'IPBBW',IPBW_PTR) + CALL LCMLEN(IPSYS,'WB',LENWB,ITYL) + IF(LENWB.EQ.0) THEN + CALL LCMGPD(IPTRK,'WB',BW_PTR) + ELSE + CALL LCMGPD(IPSYS,'WB',BW_PTR) + ENDIF + CALL C_F_POINTER(IPBW_PTR,IPBW,(/ 2*IELEM*LL4W /)) + CALL C_F_POINTER(BW_PTR,BW,(/ 2*IELEM*LL4W /)) + NBLOS=LX*LZ/3 + ALLOCATE(IPERT(NBLOS),FRZ(NBLOS),DIF(NBLOS)) + CALL LCMGET(IPTRK,'IPERT',IPERT) + CALL LCMGET(IPTRK,'FRZ',FRZ) + IF((IPR.EQ.0).OR.(IPR.EQ.3)) THEN + WA_PTR=LCMARA(IIMAW) + CALL C_F_POINTER(WA_PTR,WA,(/ IIMAW /)) + ELSE + ALLOCATE(WA(IIMAW)) + ENDIF + DO 60 KEL=1,NBLOS + DIF(KEL)=0.0 + IF(IPERT(KEL).GT.0) THEN + IBM=MAT((IPERT(KEL)-1)*3+1) + DZ=ZZ((IPERT(KEL)-1)*3+1)*FRZ(KEL) + IF(IBM.GT.0) DIF(KEL)=DZ*SIGT(IBM,1) + ENDIF + 60 CONTINUE + CALL LCMPUT(IPSYS,'SIGT'//TEXT10,NBLOS,2,DIF) + CALL PN3HWW(NBMIX,NBLOS,IELEM,ICOL,NLF,NVD,NAN,LL4F,LL4W,MAT, + 1 SIGT,SIGTI,SIDE,ZZ,FRZ,QFR,IPERT,KN,MUW,IPBW,LC,R,V,BW,TF,AW, + 2 WA) + IF((IPR.EQ.0).OR.(IPR.EQ.3)) THEN + CALL LCMPPD(IPSYS,'W_'//TEXT10,IIMAW,2,WA_PTR) + ELSE + DEALLOCATE(WA) + ENDIF + CALL LCMPPD(IPSYS,'WA'//TEXT10,IIMAW,2,AW_PTR) + CALL LCMPPD(IPSYS,'TF'//TEXT10,LL4F*NLF/2,2,TF_PTR) + DEALLOCATE(DIF,FRZ,IPERT) + ENDIF +* +* DIMENSION X + IIMAX=MUX(LL4X)*NLF/2 + CALL LCMGPD(IPTRK,'IPBBX',IPBX_PTR) + CALL LCMLEN(IPSYS,'XB',LENXB,ITYL) + IF(LENXB.EQ.0) THEN + CALL LCMGPD(IPTRK,'XB',BX_PTR) + ELSE + CALL LCMGPD(IPSYS,'XB',BX_PTR) + ENDIF + CALL C_F_POINTER(IPBX_PTR,IPBX,(/ 2*IELEM*LL4X /)) + CALL C_F_POINTER(BX_PTR,BX,(/ 2*IELEM*LL4X /)) + IF(CHEX) THEN + IF(IPR.NE.3) THEN + AX_PTR=LCMARA(IIMAX) + CALL C_F_POINTER(AX_PTR,AX,(/ IIMAX /)) + AX(:IIMAX)=0.0 + ELSE + IF(ISEG.GT.0) CALL MTBLD('XA'//TEXT10,IPTRK,IPSYS,1) + CALL LCMGPD(IPSYS,'XA'//TEXT10,AX_PTR) + CALL C_F_POINTER(AX_PTR,AX,(/ IIMAX /)) + ENDIF + CALL LCMGPD(IPSYS,'TF'//TEXT10,TF_PTR) + CALL C_F_POINTER(TF_PTR,TF,(/ LL4F*NLF/2 /)) + NBLOS=LX*LZ/3 + ALLOCATE(IPERT(NBLOS),FRZ(NBLOS)) + CALL LCMGET(IPTRK,'IPERT',IPERT) + CALL LCMGET(IPTRK,'FRZ',FRZ) + IF((IPR.EQ.0).OR.(IPR.EQ.3)) THEN + XA_PTR=LCMARA(IIMAX) + CALL C_F_POINTER(XA_PTR,XA,(/ IIMAX /)) + ELSE + ALLOCATE(XA(IIMAX)) + ENDIF + CALL PN3HWX(NBMIX,NBLOS,IELEM,ICOL,NLF,NVD,NAN,LL4F,LL4W,LL4X, + 1 MAT,SIGT,SIDE,ZZ,FRZ,QFR,IPERT,KN,MUX,IPBX,LC,R,BX,TF,AX,XA) + DEALLOCATE(FRZ,IPERT) + IF((IPR.EQ.0).OR.(IPR.EQ.3)) THEN + CALL LCMPPD(IPSYS,'X_'//TEXT10,IIMAX,2,XA_PTR) + ELSE + DEALLOCATE(XA) + ENDIF + CALL LCMPPD(IPSYS,'XA'//TEXT10,IIMAX,2,AX_PTR) + ELSE + IF(DIAG) THEN + ALLOCATE(AX(IIMAX)) + IF(IPR.NE.3) THEN + TF_PTR=LCMARA(LL4F*NLF/2) + CALL C_F_POINTER(TF_PTR,TF,(/ LL4F*NLF/2 /)) + TF(:LL4F*NLF/2)=0.0 + AX(:IIMAX)=0.0 + ELSE + IF(ISEG.GT.0) CALL MTBLD('XA'//TEXT10,IPTRK,IPSYS,1) + CALL LCMGPD(IPSYS,'TF'//TEXT10,TF_PTR) + CALL C_F_POINTER(TF_PTR,TF,(/ LL4F*NLF/2 /)) + CALL LCMGET(IPSYS,'XA'//TEXT10,AX) + ENDIF + ALLOCATE(XA(IIMAX)) + ELSE + IF(IPR.NE.3) THEN + TF_PTR=LCMARA(LL4F*NLF/2) + AX_PTR=LCMARA(IIMAX) + CALL C_F_POINTER(TF_PTR,TF,(/ LL4F*NLF/2 /)) + CALL C_F_POINTER(AX_PTR,AX,(/ IIMAX /)) + TF(:LL4F*NLF/2)=0.0 + AX(:IIMAX)=0.0 + ELSE + IF(ISEG.GT.0) CALL MTBLD('XA'//TEXT10,IPTRK,IPSYS,1) + CALL LCMGPD(IPSYS,'TF'//TEXT10,TF_PTR) + CALL LCMGPD(IPSYS,'XA'//TEXT10,AX_PTR) + CALL C_F_POINTER(TF_PTR,TF,(/ LL4F*NLF/2 /)) + CALL C_F_POINTER(AX_PTR,AX,(/ IIMAX /)) + ENDIF + IF((IPR.EQ.0).OR.(IPR.EQ.3)) THEN + XA_PTR=LCMARA(IIMAX) + CALL C_F_POINTER(XA_PTR,XA,(/ IIMAX /)) + ELSE + ALLOCATE(XA(IIMAX)) + ENDIF + ENDIF + CALL PN3DXX(NBMIX,IELEM,ICOL,NEL,NLF,NVD,NAN,LL4F,LL4X,SIGT, + 1 SIGTI,MAT,VOL2,XX,YY,ZZ,KN,QFR,MUX,IPBX,LC,R,V,BX,TF,AX,XA) + IF(.NOT.DIAG) THEN + IF((IPR.EQ.0).OR.(IPR.EQ.3)) THEN + CALL LCMPPD(IPSYS,'X_'//TEXT10,IIMAX,2,XA_PTR) + ELSE + DEALLOCATE(XA) + ENDIF + CALL LCMPPD(IPSYS,'XA'//TEXT10,IIMAX,2,AX_PTR) + ELSE +* IN DIAGONAL SYMMETRY CASE, DO NOT SAVE THE X-DIRECTED +* ADI MATRIX COMPONENT SINCE IT IS EQUAL TO THE Y-DIRECTED +* COMPONENT + DEALLOCATE(XA,AX) + ENDIF + CALL LCMPPD(IPSYS,'TF'//TEXT10,LL4F*NLF/2,2,TF_PTR) + ENDIF +* +* DIMENSION Y + IF(CHEX) THEN + IIMAY=MUY(LL4Y)*NLF/2 + IF(IPR.NE.3) THEN + AY_PTR=LCMARA(IIMAY) + CALL C_F_POINTER(AY_PTR,AY,(/ IIMAY /)) + AY(:IIMAY)=0.0 + ELSE + IF(ISEG.GT.0) CALL MTBLD('YA'//TEXT10,IPTRK,IPSYS,1) + CALL LCMGPD(IPSYS,'YA'//TEXT10,AY_PTR) + CALL C_F_POINTER(AY_PTR,AY,(/ IIMAY /)) + ENDIF + CALL LCMGPD(IPSYS,'TF'//TEXT10,TF_PTR) + CALL C_F_POINTER(TF_PTR,TF,(/ LL4F*NLF/2 /)) + CALL LCMGPD(IPTRK,'IPBBY',IPBY_PTR) + CALL LCMLEN(IPSYS,'YB',LENYB,ITYL) + IF(LENYB.EQ.0) THEN + CALL LCMGPD(IPTRK,'YB',BY_PTR) + ELSE + CALL LCMGPD(IPSYS,'YB',BY_PTR) + ENDIF + CALL C_F_POINTER(IPBY_PTR,IPBY,(/ 2*IELEM*LL4Y /)) + CALL C_F_POINTER(BY_PTR,BY,(/ 2*IELEM*LL4Y /)) + NBLOS=LX*LZ/3 + ALLOCATE(IPERT(NBLOS),FRZ(NBLOS)) + CALL LCMGET(IPTRK,'IPERT',IPERT) + CALL LCMGET(IPTRK,'FRZ',FRZ) + IF((IPR.EQ.0).OR.(IPR.EQ.3)) THEN + YA_PTR=LCMARA(IIMAY) + CALL C_F_POINTER(YA_PTR,YA,(/ IIMAY /)) + ELSE + ALLOCATE(YA(IIMAY)) + ENDIF + CALL PN3HWY(NBMIX,NBLOS,IELEM,ICOL,NLF,NVD,NAN,LL4F,LL4W,LL4X, + 1 LL4Y,MAT,SIGT,SIDE,ZZ,FRZ,QFR,IPERT,KN,MUY,IPBY,LC,R,BY,TF,AY, + 2 YA) + DEALLOCATE(FRZ,IPERT) + IF((IPR.EQ.0).OR.(IPR.EQ.3)) THEN + CALL LCMPPD(IPSYS,'Y_'//TEXT10,IIMAY,2,YA_PTR) + ELSE + DEALLOCATE(YA) + ENDIF + CALL LCMPPD(IPSYS,'YA'//TEXT10,IIMAY,2,AY_PTR) + ELSE IF(LL4Y.GT.0) THEN + IIMAY=MUY(LL4Y)*NLF/2 + IF(IPR.NE.3) THEN + AY_PTR=LCMARA(IIMAY) + CALL C_F_POINTER(AY_PTR,AY,(/ IIMAY /)) + AY(:IIMAY)=0.0 + ELSE + IF(ISEG.GT.0) CALL MTBLD('YA'//TEXT10,IPTRK,IPSYS,1) + CALL LCMGPD(IPSYS,'YA'//TEXT10,AY_PTR) + CALL C_F_POINTER(AY_PTR,AY,(/ IIMAY /)) + ENDIF + CALL LCMGPD(IPSYS,'TF'//TEXT10,TF_PTR) + CALL C_F_POINTER(TF_PTR,TF,(/ LL4F*NLF/2 /)) + CALL LCMGPD(IPTRK,'IPBBY',IPBY_PTR) + CALL LCMGPD(IPTRK,'YB',BY_PTR) + CALL C_F_POINTER(IPBY_PTR,IPBY,(/ 2*IELEM*LL4Y /)) + CALL C_F_POINTER(BY_PTR,BY,(/ 2*IELEM*LL4Y /)) + IF((IPR.EQ.0).OR.(IPR.EQ.3)) THEN + YA_PTR=LCMARA(IIMAY) + CALL C_F_POINTER(YA_PTR,YA,(/ IIMAY /)) + ELSE + ALLOCATE(YA(IIMAY)) + ENDIF + CALL PN3DXY(NBMIX,IELEM,ICOL,NEL,NLF,NVD,NAN,LL4F,LL4X,LL4Y, + 1 SIGT,MAT,VOL2,YY,KN,QFR,MUY,IPBY,LC,R,BY,TF,AY,YA) + IF((IPR.EQ.0).OR.(IPR.EQ.3)) THEN + CALL LCMPPD(IPSYS,'Y_'//TEXT10,IIMAY,2,YA_PTR) + ELSE + DEALLOCATE(YA) + ENDIF + CALL LCMPPD(IPSYS,'YA'//TEXT10,IIMAY,2,AY_PTR) + ENDIF +* +* DIMENSION Z + IF(LL4Z.GT.0) THEN + IIMAZ=MUZ(LL4Z)*NLF/2 + IF(CHEX) THEN + IF(IPR.NE.3) THEN + AZ_PTR=LCMARA(IIMAZ) + CALL C_F_POINTER(AZ_PTR,AZ,(/ IIMAZ /)) + AZ(:IIMAZ)=0.0 + ELSE + IF(ISEG.GT.0) CALL MTBLD('ZA'//TEXT10,IPTRK,IPSYS,1) + CALL LCMGPD(IPSYS,'ZA'//TEXT10,AZ_PTR) + CALL C_F_POINTER(AZ_PTR,AZ,(/ IIMAZ /)) + ENDIF + CALL LCMGPD(IPSYS,'TF'//TEXT10,TF_PTR) + CALL C_F_POINTER(TF_PTR,TF,(/ LL4F*NLF/2 /)) + CALL LCMGPD(IPTRK,'IPBBZ',IPBZ_PTR) + CALL LCMLEN(IPSYS,'ZB',LENZB,ITYL) + IF(LENZB.EQ.0) THEN + CALL LCMGPD(IPTRK,'ZB',BZ_PTR) + ELSE + CALL LCMGPD(IPSYS,'ZB',BZ_PTR) + ENDIF + CALL C_F_POINTER(IPBZ_PTR,IPBZ,(/ 2*IELEM*LL4Z /)) + CALL C_F_POINTER(BZ_PTR,BZ,(/ 2*IELEM*LL4Z /)) + NBLOS=LX*LZ/3 + ALLOCATE(IPERT(NBLOS),FRZ(NBLOS)) + CALL LCMGET(IPTRK,'IPERT',IPERT) + CALL LCMGET(IPTRK,'FRZ',FRZ) + IF((IPR.EQ.0).OR.(IPR.EQ.3)) THEN + ZA_PTR=LCMARA(IIMAZ) + CALL C_F_POINTER(ZA_PTR,ZA,(/ IIMAZ /)) + ELSE + ALLOCATE(ZA(IIMAZ)) + ENDIF + CALL PN3HWZ(NBMIX,NBLOS,IELEM,ICOL,NLF,NVD,NAN,LL4F,LL4W, + 1 LL4X,LL4Y,LL4Z,MAT,SIGT,SIDE,ZZ,FRZ,QFR,IPERT,KN,MUZ,IPBZ, + 2 LC,R,BZ,TF,AZ,ZA) + DEALLOCATE(FRZ,IPERT) + ELSE + IF(IPR.NE.3) THEN + IF(IPR.EQ.0) THEN + AZ_PTR=LCMARA(IIMAZ) + CALL C_F_POINTER(AZ_PTR,AZ,(/ IIMAZ /)) + ELSE + ALLOCATE(ZA(IIMAZ)) + ENDIF + AZ(:IIMAZ)=0.0 + ELSE + IF(ISEG.GT.0) CALL MTBLD('ZA'//TEXT10,IPTRK,IPSYS,1) + CALL LCMGPD(IPSYS,'ZA'//TEXT10,AZ_PTR) + CALL C_F_POINTER(AZ_PTR,AZ,(/ IIMAZ /)) + ENDIF + CALL LCMGPD(IPSYS,'TF'//TEXT10,TF_PTR) + CALL C_F_POINTER(TF_PTR,TF,(/ LL4F*NLF/2 /)) + CALL LCMGPD(IPTRK,'IPBBZ',IPBZ_PTR) + CALL LCMGPD(IPTRK,'ZB',BZ_PTR) + CALL C_F_POINTER(IPBZ_PTR,IPBZ,(/ 2*IELEM*LL4Z /)) + CALL C_F_POINTER(BZ_PTR,BZ,(/ 2*IELEM*LL4Z /)) + IF((IPR.EQ.0).OR.(IPR.EQ.3)) THEN + ZA_PTR=LCMARA(IIMAZ) + CALL C_F_POINTER(ZA_PTR,ZA,(/ IIMAZ /)) + ELSE + ALLOCATE(ZA(IIMAZ)) + ENDIF + CALL PN3DXZ(NBMIX,IELEM,ICOL,NEL,NLF,NVD,NAN,LL4F,LL4X, + 1 LL4Y,LL4Z,SIGT,MAT,VOL2,ZZ,KN,QFR,MUZ,IPBZ,LC,R,BZ,TF, + 2 AZ,ZA) + ENDIF + IF((IPR.EQ.0).OR.(IPR.EQ.3)) THEN + CALL LCMPPD(IPSYS,'Z_'//TEXT10,IIMAZ,2,ZA_PTR) + ELSE + DEALLOCATE(ZA) + ENDIF + CALL LCMPPD(IPSYS,'ZA'//TEXT10,IIMAZ,2,AZ_PTR) + ENDIF + DEALLOCATE(VOL2) + CALL KDRCPU(TK2) + IF(IMPX.GT.1) WRITE(6,'(/35H TRIASN: CPU TIME FOR SYSTEM MATRIX, + 1 11H ASSEMBLY =,F9.2,3H S.)') TK2-TK1 +*---- +* PERFORM SUPERVECTORIZATION REBUILD OF THE COEFFICIENT MATRICES +*---- + IF(ISEG.GT.0) THEN + IF((IPR.EQ.0).OR.(IPR.EQ.3)) THEN + IF(CHEX) CALL MTBLD('W_'//TEXT10,IPTRK,IPSYS,3) + IF(.NOT.DIAG) CALL MTBLD('X_'//TEXT10,IPTRK,IPSYS,3) + IF(LL4Y.GT.0) CALL MTBLD('Y_'//TEXT10,IPTRK,IPSYS,3) + IF(LL4Z.GT.0) CALL MTBLD('Z_'//TEXT10,IPTRK,IPSYS,3) + ENDIF + IF(CHEX) CALL MTBLD('WA'//TEXT10,IPTRK,IPSYS,3) + IF(.NOT.DIAG) CALL MTBLD('XA'//TEXT10,IPTRK,IPSYS,3) + IF(LL4Y.GT.0) CALL MTBLD('YA'//TEXT10,IPTRK,IPSYS,3) + IF(LL4Z.GT.0) CALL MTBLD('ZA'//TEXT10,IPTRK,IPSYS,3) + ENDIF +*---- +* MATRIX FACTORIZATIONS +*---- + IF((IPR.EQ.0).OR.(IPR.EQ.3)) THEN + CALL KDRCPU(TK1) + CALL MTLDLF(TEXT10,IPTRK,IPSYS,ITY,IMPX) + CALL KDRCPU(TK2) + IF(IMPX.GT.1) WRITE(6,'(/34H TRIASN: CPU TIME FOR LDLT FACTORI, + 1 18HZATION OF MATRIX '',A10,2H''=,F9.2,3H S.)') TEXT10,TK2-TK1 + ENDIF +*---- +* RELEASE UNIT MATRICES +*---- + DEALLOCATE(V,R) +*---- +* RELEASE TRIVAC SPECIFIC TRACKING INFORMATION +*---- + DEALLOCATE(IQFR,QFR,KN,ZZ) + IF(CHEX) THEN + DEALLOCATE(MUW) + ELSE + DEALLOCATE(YY,XX) + ENDIF + IF(LL4Z.GT.0) DEALLOCATE(MUZ) + IF(LL4Y.GT.0) DEALLOCATE(MUY) + IF(.NOT.DIAG) DEALLOCATE(MUX) + RETURN + END diff --git a/Trivac/src/TRIASP.f b/Trivac/src/TRIASP.f new file mode 100755 index 0000000..76e0a0f --- /dev/null +++ b/Trivac/src/TRIASP.f @@ -0,0 +1,88 @@ +*DECK TRIASP + SUBROUTINE TRIASP (IELEM,IR,NEL,LL4,CYLIND,SGD,XX,DD,VOL,MAT,KN, + 1 LC,T,TS,VEC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Assembly of a diagonal system matrix corresponding to a single cross +* section type (primal formulation). Note: vector VEC should be +* initialized by the calling program. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IELEM degree of the Lagrangian finite elements. +* IR number of material mixtures. +* NEL total number of finite elements. +* ll4 order of system matrices. +* CYLIND cylinderization flag (=.true. for cylindrical geometry). +* SGD cross section per material mixture. +* XX X-directed mesh spacings. +* DD used with cylindrical geometry. +* VOL volume of each element. +* MAT mixture index assigned to each element. +* KN element-ordered unknown list. +* LC order of the unit matrices. +* T Cartesian linear product vector. +* TS cylindrical linear product vector. +* +*Parameters: output +* VEC diagonal matrix corresponding to the cross section term. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IELEM,IR,NEL,LL4,MAT(NEL),KN(NEL*(IELEM+1)**3),LC + REAL SGD(IR),XX(NEL),DD(NEL),VOL(NEL),T(LC),TS(LC),VEC(LL4) + LOGICAL CYLIND +*---- +* LOCAL VARIABLES +*---- + REAL R3DP(125),R3DC(125) +*---- +* CALCULATION OF 3-D MASS MATRICES FROM TENSORIAL PRODUCT OF 1-D +* MATRICES +*---- + LL=LC*LC*LC + DO 20 L=1,LL + L1=1+MOD(L-1,LC) + L2=1+(L-L1)/LC + L3=1+MOD(L2-1,LC) + I1=L1 + I2=L3 + I3=1+(L2-L3)/LC + R3DP(L)=T(I1)*T(I2)*T(I3) + R3DC(L)=TS(I1)*T(I2)*T(I3) + 20 CONTINUE +* + NUM1=0 + DO 90 K=1,NEL + L=MAT(K) + IF(L.EQ.0) GO TO 90 + VOL0=VOL(K) + IF(VOL0.EQ.0.0) GO TO 80 + DX=XX(K) + DO 50 I=1,LL + IND1=KN(NUM1+I) + IF(IND1.EQ.0) GO TO 50 + IF(CYLIND) THEN + RR=(R3DP(I)+R3DC(I)*DX/DD(K))*VOL0 + ELSE + RR=R3DP(I)*VOL0 + ENDIF + VEC(IND1)=VEC(IND1)+RR*SGD(L) + 50 CONTINUE + 80 NUM1=NUM1+LL + 90 CONTINUE + RETURN + END diff --git a/Trivac/src/TRICH1.f b/Trivac/src/TRICH1.f new file mode 100755 index 0000000..6aa237d --- /dev/null +++ b/Trivac/src/TRICH1.f @@ -0,0 +1,254 @@ +*DECK TRICH1 + SUBROUTINE TRICH1(IELEM,IDIM,LX,LY,LZ,L4,MAT,KN,MUX,MUY,MUZ,IPY, + 1 IPZ,IMPX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* compute the compressed diagonal storage indices (MUX, MUY and MUZ) +* and the permutation vectors (IPY and IPZ) for an ADI splitting of +* the nodal collocation leakage matrices. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IELEM degree of the polynomial expansion: =1 (linear); +* =2 (parabolic); =3 (cubic); =4 (quartic). +* IDIM number of dimensions. +* LX number of mesh along the X axis. +* LY number of mesh along the Y axis. +* LZ number of mesh along the Z axis. +* L4 order of system matrices +* MAT mixture index assigned to each element. +* KN element-ordered unknown list. +* IMPX print parameter (equal to zero for no print). +* +*Parameters: output +* MUX X-oriented compressed storage mode indices. +* MUY Y-oriented compressed storage mode indices. +* MUZ Z-oriented compressed storage mode indices. +* IPY Y-oriented permutation matrices. +* IPZ Z-oriented permutation matrices. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IELEM,IDIM,LX,LY,LZ,L4,MAT(LX*LY*LZ),KN(7*LX*LY*LZ), + 1 MUX(L4),MUY(L4),MUZ(L4),IPY(L4),IPZ(L4),IMPX +*---- +* LOCAL VARIABLES +*---- + INTEGER, DIMENSION(:), ALLOCATABLE :: IWRK +* + IORD(J,K,L,LL,IEL,IW)=(IEL*L+K)*LL*IEL+(1+IEL*(IW-1))+J +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IWRK(LX*LY*LZ)) +* + IWRK(:LX*LY*LZ)=0 + LL4=0 + KEL=0 + DO 22 K0=1,LZ + DO 21 K1=1,LY + DO 20 K2=1,LX + KEL=KEL+1 + IF(MAT(KEL).EQ.0) GO TO 20 + LL4=LL4+1 + IWRK((K0-1)*LX*LY+(K1-1)*LX+K2)=LL4 + 20 CONTINUE + 21 CONTINUE + 22 CONTINUE +*---- +* COMPUTE THE PERMUTATION VECTORS IPY AND IPZ +*---- + IF(IDIM.GE.2) THEN + INX1=0 + DO 52 K0=1,LZ + DO 51 K2=1,LX + DO 50 K1=1,LY + INX2=IWRK((K0-1)*LX*LY+(K1-1)*LX+K2) + IF(INX2.LE.0) GO TO 50 + INX1=INX1+1 + IF(IDIM.EQ.2) THEN + DO 31 K=0,IELEM-1 + DO 30 J=0,IELEM-1 + I=IORD(J,K,0,LL4,IELEM,INX1) + IPY(IORD(K,J,0,LL4,IELEM,INX2))=I + 30 CONTINUE + 31 CONTINUE + ELSE IF(IDIM.EQ.3) THEN + DO 42 L=0,IELEM-1 + DO 41 K=0,IELEM-1 + DO 40 J=0,IELEM-1 + I=IORD(J,K,L,LL4,IELEM,INX1) + IPY(IORD(K,J,L,LL4,IELEM,INX2))=I + 40 CONTINUE + 41 CONTINUE + 42 CONTINUE + ENDIF + 50 CONTINUE + 51 CONTINUE + 52 CONTINUE + IF(INX1.NE.LL4) CALL XABORT('TRICH1: FAILURE OF THE RENUMBERI' + 1 //'NG ALGORITHM(1)') + IF(IDIM.EQ.3) THEN + INX1=0 + DO 72 K1=1,LY + DO 71 K2=1,LX + DO 70 K0=1,LZ + INX2=IWRK((K0-1)*LX*LY+(K1-1)*LX+K2) + IF(INX2.LE.0) GO TO 70 + INX1=INX1+1 + DO 62 L=0,IELEM-1 + DO 61 K=0,IELEM-1 + DO 60 J=0,IELEM-1 + I=IORD(J,K,L,LL4,IELEM,INX1) + IPZ(IORD(K,L,J,LL4,IELEM,INX2))=I + 60 CONTINUE + 61 CONTINUE + 62 CONTINUE + 70 CONTINUE + 71 CONTINUE + 72 CONTINUE + IF(INX1.NE.LL4) CALL XABORT('TRICH1: FAILURE OF THE RENUMB' + 1 //'ERING ALGORITHM(2)') + ENDIF + ENDIF +* + L2M=0 + DO 80 KEL=1,LX*LY*LZ + IF(MAT(KEL).EQ.0) GO TO 80 + L2M=L2M+1 + IWRK(KEL)=L2M + 80 CONTINUE + DO 90 I=1,L4 + MUY(I)=0 + MUZ(I)=0 + 90 CONTINUE + LL5=L4/IELEM**(IDIM-1) +*---- +* COMPUTE VECTOR MUX +*---- + NUM1=0 + DO 130 KEL=1,LL4 + KK1=KN(NUM1+1) + KK2=KN(NUM1+2) + DO 100 J=0,IELEM-1 + INX1=IORD(J,0,0,LL4,IELEM,KEL) + MUX(INX1)=J+1 +* X- SIDE: + IF(KK1.GT.0) THEN + INX2=IORD(0,0,0,LL4,IELEM,IWRK(KK1)) + MUX(INX1)=MAX0(MUX(INX1),INX1-INX2+1) + ENDIF +* X+ SIDE: + IF(KK2.GT.0) THEN + INX2=IORD(0,0,0,LL4,IELEM,IWRK(KK2)) + MUX(INX1)=MAX0(MUX(INX1),INX1-INX2+1) + ENDIF + 100 CONTINUE + NUM1=NUM1+6 + 130 CONTINUE +*---- +* COMPUTE VECTOR MUY +*---- + IF(IDIM.GE.2) THEN + NUM1=0 + DO 160 KEL=1,LL4 + KK3=KN(NUM1+3) + KK4=KN(NUM1+4) + DO 140 K=0,IELEM-1 + INY1=IPY(IORD(0,K,0,LL4,IELEM,KEL)) + MUY(INY1)=K+1 +* Y- SIDE: + IF(KK3.GT.0) THEN + INY2=IPY(IORD(0,0,0,LL4,IELEM,IWRK(KK3))) + MUY(INY1)=MAX0(MUY(INY1),INY1-INY2+1) + ENDIF +* Y+ SIDE: + IF(KK4.GT.0) THEN + INY2=IPY(IORD(0,0,0,LL4,IELEM,IWRK(KK4))) + MUY(INY1)=MAX0(MUY(INY1),INY1-INY2+1) + ENDIF + 140 CONTINUE + NUM1=NUM1+6 + 160 CONTINUE +*---- +* COMPUTE VECTOR MUZ +*---- + IF(IDIM.EQ.3) THEN + NUM1=0 + DO 180 KEL=1,LL4 + KK5=KN(NUM1+5) + KK6=KN(NUM1+6) + DO 170 L=0,IELEM-1 + INZ1=IPZ(IORD(0,0,L,LL4,IELEM,KEL)) + MUZ(INZ1)=L+1 +* Z- SIDE: + IF(KK5.GT.0) THEN + INZ2=IPZ(IORD(0,0,0,LL4,IELEM,IWRK(KK5))) + MUZ(INZ1)=MAX0(MUZ(INZ1),INZ1-INZ2+1) + ENDIF +* Z+ SIDE: + IF(KK6.GT.0) THEN + INZ2=IPZ(IORD(0,0,0,LL4,IELEM,IWRK(KK6))) + MUZ(INZ1)=MAX0(MUZ(INZ1),INZ1-INZ2+1) + ENDIF + 170 CONTINUE + NUM1=NUM1+6 + 180 CONTINUE + DO 195 J=1,IELEM-1 + DO 190 I=1,LL5 + MUX(I+J*LL5)=MUX(I) + MUY(I+J*LL5)=MUY(I) + MUZ(I+J*LL5)=MUZ(I) + 190 CONTINUE + 195 CONTINUE + LL5=IELEM*LL5 + ENDIF + DO 205 J=1,IELEM-1 + DO 200 I=1,LL5 + MUX(I+J*LL5)=MUX(I) + MUY(I+J*LL5)=MUY(I) + MUZ(I+J*LL5)=MUZ(I) + 200 CONTINUE + 205 CONTINUE + ENDIF +* + MUXMAX=0 + MUYMAX=0 + MUZMAX=0 + IIMAXX=0 + IIMAXY=0 + IIMAXZ=0 + DO 210 I=1,L4 + MUXMAX=MAX(MUXMAX,MUX(I)) + MUYMAX=MAX(MUYMAX,MUY(I)) + MUZMAX=MAX(MUZMAX,MUZ(I)) + IIMAXX=IIMAXX+MUX(I) + MUX(I)=IIMAXX + IIMAXY=IIMAXY+MUY(I) + MUY(I)=IIMAXY + IIMAXZ=IIMAXZ+MUZ(I) + MUZ(I)=IIMAXZ + 210 CONTINUE + IF(IMPX.GT.0) WRITE (6,230) MUXMAX,MUYMAX,MUZMAX +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IWRK) + RETURN +* + 230 FORMAT(/41H TRICH1: MAXIMUM BANDWIDTH ALONG X AXIS =,I5/ + 1 27X,14HALONG Y AXIS =,I5/27X,14HALONG Z AXIS =,I5) + END diff --git a/Trivac/src/TRICH3.f b/Trivac/src/TRICH3.f new file mode 100755 index 0000000..e96e2dd --- /dev/null +++ b/Trivac/src/TRICH3.f @@ -0,0 +1,257 @@ +*DECK TRICH3 + SUBROUTINE TRICH3(ISPLH,IPTRK,LX,LZ,L4,MAT,KN,MUW,MUX,MUY,MUZ, + 1 IPW,IPX,IPY,IPZ,IMPX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the compressed diagonal storage indices (MUW, MUX, MUY and +* MUZ) an the permutation vectors (IPW, IPX, IPY and IPZ) for an ADI +* splitting of a mesh corner finite difference discretization in +* hexagonal geometry. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Benaboud +* +*Parameters: input +* ISPLH type of mesh-splitting: =1 for complete hexagons; =2 for +* triangular mesh-splitting. +* IPTRK L_TRACK pointer to the Trivac tracking information. +* LX number of hexagons in a plane. +* LZ number of axial planes. +* L4 order of system matrices. +* MAT mixture index assigned to each element. +* KN element-ordered unknown list. Dimensionned to LL*LX*LZ +* where LL=12 (hexagons) or 14 (triangles). +* IMPX print parameter (equal to zero for no print). +* +*Parameters: output +* MUW W-oriented compressed storage mode indices. +* MUX X-oriented compressed storage mode indices. +* MUY Y-oriented compressed storage mode indices. +* MUZ Z-oriented compressed storage mode indices. +* IPW W-oriented permutation matrices. +* IPX X-oriented permutation matrices. +* IPY Y-oriented permutation matrices. +* IPZ Z-oriented permutation matrices. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK + INTEGER ISPLH,LX,LZ,L4,MAT(LX*LZ),KN(*),MUW(L4),MUX(L4),MUY(L4), + 1 MUZ(L4),IPW(L4),IPX(L4),IPY(L4),IPZ(L4),IMPX +*---- +* LOCAL VARIABLES +*---- + REAL HW(14,14),HX(14,14),HY(14,14),HZ(14,14),HL(2,2),RFAC(28,7), + 1 RF6(24,6),RF7(28,7) + INTEGER NCODE(6),IJ1(14),IJ2(14),IJ27(14),IJ16(12),IJ26(12), + 1 IJ17(14) + INTEGER, DIMENSION(:), ALLOCATABLE :: IDX,IDY + COMMON /ELEMB/LC,T(5),TS(5),R(5,5),RS(5,5),Q(5,5),QS(5,5),V(5,4), + 1 E(5,5),RH(7,7),QH(7,7),RT(3,3),QT(3,3) + DATA HL / 1.0,2*0.0,1.0/ + DATA IJ16,IJ26 /1,2,3,4,5,6,1,2,3,4,5,6,6*1,6*2/ + DATA IJ17,IJ27 /1,2,3,4,5,6,7,1,2,3,4,5,6,7,7*1,7*2/ + DATA RF6/ + >1.0,0.0,0.0,0.0,0.0,0.0,1.0,1.0,0.0,0.0,1.0,0.5, + >1.0,0.0,1.0,1.0,0.0,0.5,1.0,0.0,0.0,0.0,0.0,0.0, + >0.0,1.0,1.0,1.0,0.5,0.0,1.0,1.0,0.0,0.0,0.5,1.0, + >0.0,1.0,0.0,0.0,0.0,0.0,0.0,1.0,0.0,0.0,0.0,0.0, + >0.0,1.0,1.0,0.5,1.0,0.0,0.0,0.0,1.0,0.0,0.0,0.0, + >1.0,0.0,1.0,0.5,0.0,1.0,0.0,0.0,1.0,0.0,0.0,0.0, + >0.0,1.0,0.5,1.0,1.0,0.0,0.0,0.0,0.0,1.0,0.0,0.0, + >1.0,0.0,0.5,1.0,0.0,1.0,0.0,0.0,0.0,1.0,0.0,0.0, + >0.0,0.5,1.0,1.0,1.0,0.0,1.0,0.5,0.0,0.0,1.0,1.0, + >0.0,0.0,0.0,0.0,1.0,0.0,0.0,0.0,0.0,0.0,1.0,0.0, + >0.0,0.0,0.0,0.0,0.0,1.0,0.5,1.0,0.0,0.0,1.0,1.0, + >0.5,0.0,1.0,1.0,0.0,1.0,0.0,0.0,0.0,0.0,0.0,1.0/ + DATA RF7/ + >1.0,0.0,0.0,0.0,0.0,0.0,0.0,1.0,1.0,0.0,0.5,0.0,1.0,0.5, + >1.0,0.0,1.0,0.5,1.0,0.0,0.5,1.0,0.0,0.0,0.0,0.0,0.0,0.0, + >0.0,1.0,1.0,0.5,1.0,0.5,0.0,1.0,1.0,0.0,0.5,0.0,0.5,1.0, + >0.0,1.0,0.0,0.0,0.0,0.0,0.0,0.0,1.0,0.0,0.0,0.0,0.0,0.0, + >0.0,1.0,1.0,0.5,0.5,1.0,0.0,0.0,0.0,1.0,0.0,0.0,0.0,0.0, + >1.0,0.0,1.0,0.5,0.5,0.0,1.0,0.0,0.0,1.0,0.0,0.0,0.0,0.0, + >0.0,0.5,0.5,1.0,0.5,0.5,0.0,0.5,0.5,0.0,1.0,0.0,0.5,0.5, + >0.5,0.0,0.5,1.0,0.5,0.0,0.5,0.0,0.0,0.0,1.0,0.0,0.0,0.0, + >0.0,1.0,0.5,0.5,1.0,1.0,0.0,0.0,0.0,0.0,0.0,1.0,0.0,0.0, + >1.0,0.0,0.5,0.5,1.0,0.0,1.0,0.0,0.0,0.0,0.0,1.0,0.0,0.0, + >0.0,0.5,1.0,0.5,1.0,1.0,0.0,1.0,0.5,0.0,0.5,0.0,1.0,1.0, + >0.0,0.0,0.0,0.0,0.0,1.0,0.0,0.0,0.0,0.0,0.0,0.0,1.0,0.0, + >0.0,0.0,0.0,0.0,0.0,0.0,1.0,0.5,1.0,0.0,0.5,0.0,1.0,1.0, + >0.5,0.0,1.0,0.5,1.0,0.0,1.0,0.0,0.0,0.0,0.0,0.0,0.0,1.0/ +* + IF(ISPLH.EQ.1) THEN + LC=6 + DO 10 I=1,2*LC + IJ1(I)=IJ16(I) + IJ2(I)=IJ26(I) + 10 CONTINUE + DO 25 I=1,4*LC + DO 20 J=1,LC + RFAC(I,J)=RF6(I,J) + 20 CONTINUE + 25 CONTINUE + ELSE + LC=7 + DO 30 I=1,2*LC + IJ1(I)=IJ17(I) + IJ2(I)=IJ27(I) + 30 CONTINUE + DO 45 I=1,4*LC + DO 40 J=1,LC + RFAC(I,J)=RF7(I,J) + 40 CONTINUE + 45 CONTINUE + ENDIF + LL=2*LC + DO 55 I=1,LL + I1=IJ1(I) + I2=IJ2(I) + DO 50 J=1,LL + J1=IJ1(J) + J2=IJ2(J) + HW(I,J) = RFAC(I1 ,J1) * HL(I2,J2) + HX(I,J) = RFAC(I1+LC ,J1) * HL(I2,J2) + HY(I,J) = RFAC(I1+2*LC,J1) * HL(I2,J2) + HZ(I,J) = RFAC(I1+3*LC,J1) + 50 CONTINUE + 55 CONTINUE +* + DO 65 I=1,LL + I1 = IJ1(I) + I2 = IJ2(I) + DO 60 J=1,LL + J1 = IJ1(J) + J2 = IJ2(J) + HW(I,J) = RFAC(I1 ,J1) * HL(I2,J2) + HX(I,J) = RFAC(I1+LC ,J1) * HL(I2,J2) + HY(I,J) = RFAC(I1+2*LC,J1) * HL(I2,J2) + HZ(I,J) = RFAC(I1+3*LC,J1) + 60 CONTINUE + 65 CONTINUE +*---- +* COMPUTE THE PERMUTATION VECTORS +*---- + DO 70 I=1,L4 + IPW(I)=I + IPX(I)=0 + IPY(I)=0 + IPZ(I)=0 + 70 CONTINUE + LT4 = L4 + LPZ = LZ + IF(LZ.GT.1) THEN + LPZ = LZ+1 + CALL LCMGET (IPTRK,'NCODE',NCODE) + IF((NCODE(5).EQ.7).OR.(NCODE(6).EQ.7)) LPZ = LZ + IF((NCODE(5).EQ.7).AND.(NCODE(6).EQ.7)) LPZ = LZ-1 + LT4 = L4/LPZ + ENDIF + ALLOCATE(IDX(LT4),IDY(LT4)) + CALL LCMGET (IPTRK,'ILX',IDX) + CALL LCMGET (IPTRK,'ILY',IDY) + DO 85 KZ = 1, LPZ + DO 80 KX = 1, LT4 + IPX(KX+(KZ-1)*LT4) = IDX(KX) + (KZ-1)*LT4 + IPY(KX+(KZ-1)*LT4) = IDY(KX) + (KZ-1)*LT4 + 80 CONTINUE + 85 CONTINUE + DEALLOCATE(IDY,IDX) + KEL = 0 + DO 95 KX = 1, LT4 + DO 90 KZ = 1, LPZ + KEL = KEL + 1 + IPZ(KX+(KZ-1)*LT4) = KEL + 90 CONTINUE + 95 CONTINUE +*---- +* COMPUTE THE COMPRESSED DIAGONAL STORAGE INDICES +*---- + DO 100 I=1,L4 + MUW(I)=1 + MUX(I)=1 + MUY(I)=1 + MUZ(I)=1 + 100 CONTINUE + NUM1=0 + DO 130 K=1,LX*LZ + IF(MAT(K).LE.0) GO TO 130 + DO 120 I=1,LL + INW1=KN(NUM1+I) + IF(INW1.EQ.0) GO TO 120 + INX1=IPX(INW1) + INY1=IPY(INW1) + INZ1=IPZ(INW1) + DO 110 J=1,LL + INW2=KN(NUM1+J) + IF(INW2.EQ.0) GO TO 110 + INX2=IPX(INW2) + INY2=IPY(INW2) + INZ2=IPZ(INW2) + IF((HW(I,J).NE.0.0).AND.(INW2.LT.INW1)) + > MUW(INW1)=MAX0(MUW(INW1),INW1-INW2+1) + IF((HX(I,J).NE.0.0).AND.(INX2.LT.INX1)) + > MUX(INX1)=MAX0(MUX(INX1),INX1-INX2+1) + IF((HY(I,J).NE.0.0).AND.(INY2.LT.INY1)) + > MUY(INY1)=MAX0(MUY(INY1),INY1-INY2+1) + IF((HZ(I,J).NE.0.0).AND.(INZ2.LT.INZ1)) + > MUZ(INZ1)=MAX0(MUZ(INZ1),INZ1-INZ2+1) + 110 CONTINUE + 120 CONTINUE + NUM1=NUM1+LL + 130 CONTINUE + IF(IMPX.GE.5) THEN + WRITE(6,510) 'IPW :',(IPW(I),I=1,L4) + WRITE(6,510) 'MUW :',(MUW(I),I=1,L4) + WRITE(6,510) 'IPX :',(IPX(I),I=1,L4) + WRITE(6,510) 'MUX :',(MUX(I),I=1,L4) + WRITE(6,510) 'IPY :',(IPY(I),I=1,L4) + WRITE(6,510) 'MUY :',(MUY(I),I=1,L4) + IF(LZ.GT.1) THEN + WRITE(6,510) 'IPZ :',(IPZ(I),I=1,L4) + WRITE(6,510) 'MUZ :',(MUZ(I),I=1,L4) + ENDIF + ENDIF +* + MUWMAX=0 + MUXMAX=0 + MUYMAX=0 + MUZMAX=0 + IIMAWW=0 + IIMAWX=0 + IIMAWY=0 + IIMAWZ=0 + DO 140 I=1,L4 + MUWMAX=MAX(MUWMAX,MUW(I)) + MUXMAX=MAX(MUXMAX,MUX(I)) + MUYMAX=MAX(MUYMAX,MUY(I)) + MUZMAX=MAX(MUZMAX,MUZ(I)) + IIMAWW=IIMAWW+MUW(I) + MUW(I)=IIMAWW + IIMAWX=IIMAWX+MUX(I) + MUX(I)=IIMAWX + IIMAWY=IIMAWY+MUY(I) + MUY(I)=IIMAWY + IIMAWZ=IIMAWZ+MUZ(I) + MUZ(I)=IIMAWZ + 140 CONTINUE + IF(IMPX.GT.0) WRITE (6,500) MUWMAX,MUXMAX,MUYMAX,MUZMAX + RETURN +* + 500 FORMAT(/41H TRICH3: MAXIMUM BANDWIDTH ALONG W AXIS =,I5/ + 1 27X,14HALONG X AXIS =,I5/27X,14HALONG Y AXIS =,I5/27X, + 2 14HALONG Z AXIS =,I5) + 510 FORMAT(/1X,A5/(1X,20I6)) + END diff --git a/Trivac/src/TRICH4.f b/Trivac/src/TRICH4.f new file mode 100755 index 0000000..179618e --- /dev/null +++ b/Trivac/src/TRICH4.f @@ -0,0 +1,369 @@ +*DECK TRICH4 + SUBROUTINE TRICH4(ISPLH,IPTRK,IDIM,LX,LZ,L4,MAT,KN,MUW,MUX,MUY, + 1 MUZ,IPW,IPX,IPY,IPZ,IMPX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the compressed diagonal storage indices (MUW, MUX, MUY and +* MUZ) an the permutation vectors (IPW, IPX, IPY and IPZ) for an ADI +* splitting of a mesh centered finite difference discretization in +* hexagonal geometry. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Benaboud +* +*Parameters: input +* ISPLH type of mesh-splitting: =1 for complete hexagons; =2 for +* triangular mesh-splitting. +* IPTRK L_TRACK pointer to the Trivac tracking information. +* IDIM number of dimensions (2 or 3). +* LX number of hexagons in a plane. +* LZ number of axial planes. +* L4 order of system matrices. +* MAT mixture index assigned to each element. +* KN element-ordered unknown list. Dimensionned to 8*L4 +* for hexagons and to (18*(ISPLH-1)**2+3)*LX*LZ for +* triangular mesh-splitting. +* IMPX print parameter (equal to zero for no print). +* +*Parameters: output +* MUW W-oriented compressed storage mode indices. +* MUX X-oriented compressed storage mode indices. +* MUY Y-oriented compressed storage mode indices. +* MUZ Z-oriented compressed storage mode indices. +* IPW W-oriented permutation matrices. +* IPX X-oriented permutation matrices. +* IPY Y-oriented permutation matrices. +* IPZ Z-oriented permutation matrices. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK + INTEGER ISPLH,IDIM,LX,LZ,L4,MAT(LX*LZ),KN(*),MUW(L4),MUX(L4), + 1 MUY(L4),MUZ(L4),IPW(L4),IPX(L4),IPY(L4),IPZ(L4),IMPX +*---- +* LOCAL VARIABLES +*---- + INTEGER, DIMENSION(:), ALLOCATABLE :: IWRK,I1,I2,I3,I4,IDX,IDY +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IWRK(LX*LZ)) +* + IF(ISPLH.EQ.1) THEN + ALLOCATE(I1(LX),I2(LX),I3(LX),I4(LX)) + LT4=L4/LZ + MEL = 0 + DO 250 KEL=1,LX + I4(KEL) = 0 + IF(MAT(KEL).GT.0) THEN + MEL = MEL + 1 + I4(KEL) = MEL + ENDIF + 250 CONTINUE +*---- +* COMPUTE THE PERMUTATION VECTORS +*---- + DO 260 I=1,L4 + IPW(I)=0 + IPX(I)=0 + IPY(I)=0 + IPZ(I)=0 + 260 CONTINUE + NC = INT((SQRT(REAL((4*LX-1)/3))+1.)/2.) + J1 = 2 + 3*(NC-1)*(NC-2) + IF(NC.EQ.1) J1=1 + J2 = J1 + NC - 1 + J3 = J2 + NC - 1 + CALL BIVPER(J1,1,LX,LT4,I1,I4) + CALL BIVPER(J2,2,LX,LT4,I2,I4) + CALL BIVPER(J3,3,LX,LT4,I3,I4) + KEL = 0 + DO 275 K0 = 1,LZ + DO 270 K1 = 1,LT4 + KEL = KEL + 1 + IV = (K0-1)*LT4 + IPW(KEL) = I1(K1)+IV + IPX(KEL) = I2(K1)+IV + IPY(KEL) = I3(K1)+IV + 270 CONTINUE + 275 CONTINUE + IF(IDIM.EQ.3) THEN + JEL = 0 + DO 285 K1=1,LT4 + DO 280 K0=1,LZ + JEL = JEL + 1 + IPZ((K0-1)*LT4+I1(K1)) = JEL + 280 CONTINUE + 285 CONTINUE + ENDIF + DEALLOCATE(I4,I3,I2,I1) +* + DO 300 I=1,L4 + MUW(I)=0 + MUX(I)=0 + MUY(I)=0 + MUZ(I)=0 + 300 CONTINUE +*---- +* COMPUTE THE COMPRESSED DIAGONAL STORAGE INDICES +*---- + NUM1=0 + DO 320 KEL=1,L4 + KK1=KN(NUM1+6) + KK2=KN(NUM1+3) + INW1=IPW(KEL) + MUW(INW1)=1 + IF(KK1.GT.0) THEN + INW2=IPW(KK1) + MUW(INW1)=MAX0(MUW(INW1),INW1-INW2+1) + ENDIF + IF(KK2.GT.0) THEN + INW2=IPW(KK2) + MUW(INW1)=MAX0(MUW(INW1),INW1-INW2+1) + ENDIF + NUM1=NUM1+8 + 320 CONTINUE +* + NUM1=0 + DO 330 KEL=1,L4 + KK3=KN(NUM1+1) + KK4=KN(NUM1+4) + INX1=IPX(KEL) + MUX(INX1)=1 + IF(KK3.GT.0) THEN + INX2=IPX(KK3) + MUX(INX1)=MAX0(MUX(INX1),INX1-INX2+1) + ENDIF + IF(KK4.GT.0) THEN + INX2=IPX(KK4) + MUX(INX1)=MAX0(MUX(INX1),INX1-INX2+1) + ENDIF + NUM1=NUM1+8 + 330 CONTINUE +* + NUM1=0 + DO 340 KEL=1,L4 + KK5=KN(NUM1+2) + KK6=KN(NUM1+5) + INY1=IPY(KEL) + MUY(INY1)=1 + IF(KK5.GT.0) THEN + INY2=IPY(KK5) + MUY(INY1)=MAX0(MUY(INY1),INY1-INY2+1) + ENDIF + IF(KK6.GT.0) THEN + INY2=IPY(KK6) + MUY(INY1)=MAX0(MUY(INY1),INY1-INY2+1) + ENDIF + NUM1=NUM1+8 + 340 CONTINUE + IF(IDIM.EQ.3) THEN + NUM1=0 + DO 350 KEL=1,L4 + KK7=KN(NUM1+7) + KK8=KN(NUM1+8) + INZ1=IPZ(KEL) + MUZ(INZ1)=1 + IF(KK7.GT.0) THEN + INZ2=IPZ(KK7) + MUZ(INZ1)=MAX0(MUZ(INZ1),INZ1-INZ2+1) + ENDIF + IF(KK8.GT.0) THEN + INZ2=IPZ(KK8) + MUZ(INZ1)=MAX0(MUZ(INZ1),INZ1-INZ2+1) + ENDIF + NUM1=NUM1+8 + 350 CONTINUE + ENDIF +* + ELSE IF(ISPLH.GE.2) THEN +* + NTPH = 6*(ISPLH-1)**2 + NTPL = 1+2*(ISPLH-1) + NVT1 = NTPL + 2 * (ISPLH-2) + NTPH / 2 + NVT2 = NTPH - NTPL - (ISPLH-4) * (NTPL+2) + NVT3 = NTPH - (ISPLH-4) * NTPL + IVAL = 3*NTPH + 8 + IF(ISPLH.EQ.3) NVT2 = NTPH + IF(ISPLH.LE.3) ISAU = 2*(ISPLH-2) + IF(ISPLH.GE.4) ISAU = 6*(ISPLH-3) + ICR = ISAU*(1+2*(ISPLH-2)) +*---- +* COMPUTE THE PERMUTATION VECTORS. +*---- + DO 400 I=1,L4 + IPW(I)=I + IPX(I)=0 + IPY(I)=0 + IPZ(I)=0 + 400 CONTINUE + LI4 = L4/LZ + ALLOCATE(IDX(LI4),IDY(LI4)) + CALL LCMGET(IPTRK,'ILX',IDX) + CALL LCMGET(IPTRK,'ILY',IDY) + DO 415 KZ=1,LZ + DO 410 KI=1,LI4 + IPX(KI+(KZ-1)*LI4) = IDX(KI) + (KZ-1)*LI4 + IPY(KI+(KZ-1)*LI4) = IDY(KI) + (KZ-1)*LI4 + 410 CONTINUE + 415 CONTINUE + DEALLOCATE(IDY,IDX) + IF(IDIM.EQ.3) THEN + DO 425 K1=1,LI4 + DO 420 K0=1,LZ + IPZ((K0-1)*LI4+K1) = K0 + (K1-1)*LZ + 420 CONTINUE + 425 CONTINUE + ENDIF +* + DO 500 I=1,L4 + MUW(I)=0 + MUX(I)=0 + MUY(I)=0 + MUZ(I)=0 + 500 CONTINUE +*---- +* COMPUTE THE COMPRESSED DIAGONAL STORAGE INDICES +*---- + NUM1=0 + DO 520 K0=1,LX*LZ + IF(MAT(K0).LE.0) GO TO 520 + DO 510 I = 1,NTPH + CALL TRINEI(3,1,2,ISPLH,ICR,I,KK1,KK2,KK3,KEL,IQF,NUM1,NTPH, + > NTPL,NVT1,NVT2,NVT3,IVAL,KN) + INW1=IPW(KEL) + MUW(INW1)=1 + IF(KK1.GT.0) THEN + INW2=IPW(KK1) + MUW(INW1)=MAX0(MUW(INW1),INW1-INW2+1) + ENDIF + IF(KK2.GT.0) THEN + INW2=IPW(KK2) + MUW(INW1)=MAX0(MUW(INW1),INW1-INW2+1) + ENDIF + 510 CONTINUE + NUM1=NUM1+IVAL + 520 CONTINUE +* + NUM1=0 + DO 540 K0=1,LX*LZ + IF(MAT(K0).LE.0) GO TO 540 + DO 530 I = 1,NTPH + CALL TRINEI(3,2,2,ISPLH,ICR,I,KK1,KK2,KK3,KEL,IQF,NUM1,NTPH, + > NTPL,NVT1,NVT2,NVT3,IVAL,KN) + INX1=IPX(KEL) + MUX(INX1)=1 + IF(KK1.GT.0) THEN + INX2=IPX(KK1) + MUX(INX1)=MAX0(MUX(INX1),INX1-INX2+1) + ENDIF + IF(KK2.GT.0) THEN + INX2=IPX(KK2) + MUX(INX1)=MAX0(MUX(INX1),INX1-INX2+1) + ENDIF + 530 CONTINUE + NUM1=NUM1+IVAL + 540 CONTINUE +* + NUM1=0 + DO 560 K0=1,LX*LZ + IF(MAT(K0).LE.0) GO TO 560 + DO 550 I = 1,NTPH + CALL TRINEI(3,3,2,ISPLH,ICR,I,KK1,KK2,KK3,KEL,IQF,NUM1,NTPH, + > NTPL,NVT1,NVT2,NVT3,IVAL,KN) + INY1=IPY(KEL) + MUY(INY1)=1 + IF(KK1.GT.0) THEN + INY2=IPY(KK1) + MUY(INY1)=MAX0(MUY(INY1),INY1-INY2+1) + ENDIF + IF(KK2.GT.0) THEN + INY2=IPY(KK2) + MUY(INY1)=MAX0(MUY(INY1),INY1-INY2+1) + ENDIF + 550 CONTINUE + NUM1=NUM1+IVAL + 560 CONTINUE + IF(IDIM.EQ.3) THEN +* + NUM1=0 + DO 580 K0=1,LX*LZ + IF(MAT(K0).LE.0) GO TO 580 + DO 570 I = 1,NTPH + KK1 = KN(NUM1+NTPH+I) + KK2 = KN(NUM1+2*NTPH+I) + KEL = KN(NUM1+I) + INZ1=IPZ(KEL) + MUZ(INZ1)=1 + IF(KK1.GT.0) THEN + INZ2=IPZ(KK1) + MUZ(INZ1)=MAX0(MUZ(INZ1),INZ1-INZ2+1) + ENDIF + IF(KK2.GT.0) THEN + INZ2=IPZ(KK2) + MUZ(INZ1)=MAX0(MUZ(INZ1),INZ1-INZ2+1) + ENDIF + 570 CONTINUE + NUM1=NUM1+IVAL + 580 CONTINUE + ENDIF + ENDIF + IF(IMPX.GE.4) THEN + WRITE(6,710) 'IPW :',(IPW(I),I=1,L4) + WRITE(6,710) 'MUW :',(MUW(I),I=1,L4) + WRITE(6,710) 'IPX :',(IPX(I),I=1,L4) + WRITE(6,710) 'MUX :',(MUX(I),I=1,L4) + WRITE(6,710) 'IPY :',(IPY(I),I=1,L4) + WRITE(6,710) 'MUY :',(MUY(I),I=1,L4) + IF(IDIM.EQ.3) THEN + WRITE(6,710) 'IPZ :',(IPZ(I),I=1,L4) + WRITE(6,710) 'MUZ :',(MUZ(I),I=1,L4) + ENDIF + ENDIF +* + MUWMAX=0 + MUXMAX=0 + MUYMAX=0 + MUZMAX=0 + IIMAWW=0 + IIMAWX=0 + IIMAWY=0 + IIMAWZ=0 + DO 590 I=1,L4 + MUWMAX=MAX(MUWMAX,MUW(I)) + MUXMAX=MAX(MUXMAX,MUX(I)) + MUYMAX=MAX(MUYMAX,MUY(I)) + MUZMAX=MAX(MUZMAX,MUZ(I)) + IIMAWW=IIMAWW+MUW(I) + MUW(I)=IIMAWW + IIMAWX=IIMAWX+MUX(I) + MUX(I)=IIMAWX + IIMAWY=IIMAWY+MUY(I) + MUY(I)=IIMAWY + IIMAWZ=IIMAWZ+MUZ(I) + MUZ(I)=IIMAWZ + 590 CONTINUE + IF(IMPX.GE.0) WRITE (6,720) MUWMAX,MUXMAX,MUYMAX,MUZMAX +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IWRK) + RETURN +* + 710 FORMAT(/1X,A5/(1X,20I6)) + 720 FORMAT(/41H TRICH4: MAXIMUM BANDWIDTH ALONG W AXIS =,I5/ + 1 27X,14HALONG X AXIS =,I5/27X,14HALONG Y AXIS =,I5/27X, + 2 14HALONG Z AXIS =,I5) + END diff --git a/Trivac/src/TRICHD.f b/Trivac/src/TRICHD.f new file mode 100755 index 0000000..a18d1f1 --- /dev/null +++ b/Trivac/src/TRICHD.f @@ -0,0 +1,316 @@ +*DECK TRICHD + SUBROUTINE TRICHD(IMPX,LX,LY,LZ,CYLIND,IELEM,L4,LL4F,LL4X, + 1 LL4Y,LL4Z,MAT,VOL,XX,YY,ZZ,DD,KN,V,MUX,MUY,MUZ,IPBBX,IPBBY,IPBBZ, + 2 BBX,BBY,BBZ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Thomas-Raviart (dual) finite element unknown numbering for ADI +* solution in a 3D domain. Compute the storage info for ADI matrices +* in compressed diagonal storage mode. Compute the ADI permutation +* vectors. Compute the group-independent XB, YB and ZB matrices. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IMPX print parameter. +* LX number of elements along the X axis. +* LY number of elements along the Y axis. +* LZ number of elements along the Z axis. +* CYLIND cylindrical geometry flag (set with CYLIND=.true.). +* IELEM degree of the Lagrangian finite elements: =1 (linear); +* =2 (parabolic); =3 (cubic). +* L4 total number of unknown (variational coefficients) per +* energy group (order of system matrices). +* LL4F exact number of flux unknowns. +* LL4X exact number of X-directed current unknowns. +* LL4Y exact number of Y-directed current unknowns. +* LL4Z exact number of Z-directed current unknowns. +* MAT mixture index assigned to each element. +* VOL volume of each element. +* XX X-directed mesh spacings. +* YY Y-directed mesh spacings. +* ZZ Z-directed mesh spacings. +* DD used with cylindrical geometry. +* KN element-ordered unknown list. +* V finite element unit matrix. +* +*Parameters: output +* MUX X-directed compressed diagonal mode indices. +* MUY Y-directed compressed diagonal mode indices. +* MUZ Z-directed compressed diagonal mode indices. +* IPBBX X-directed perdue storage indices. +* IPBBY Y-directed perdue storage indices. +* IPBBZ Z-directed perdue storage indices. +* BBX X-directed flux-current matrices. +* BBY Y-directed flux-current matrices. +* BBZ Z-directed flux-current matrices. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + LOGICAL CYLIND + INTEGER IMPX,LX,LY,LZ,IELEM,L4,LL4F,LL4X,LL4Y,LL4Z, + 1 MAT(LX*LY*LZ),KN(LX*LY*LZ*(1+6*IELEM**2)),MUX(L4),MUY(L4), + 2 MUZ(L4),IPBBX(2*IELEM,LL4X),IPBBY(2*IELEM,LL4Y), + 3 IPBBZ(2*IELEM,LL4Z) + REAL VOL(LX*LY*LZ),XX(LX*LY*LZ),YY(LX*LY*LZ),ZZ(LX*LY*LZ), + 1 DD(LX*LY*LZ),V(IELEM+1,IELEM),BBX(2*IELEM,LL4X), + 2 BBY(2*IELEM,LL4Y),BBZ(2*IELEM,LL4Z) +* + IF(IELEM.GT.4) CALL XABORT('TRICHD: 1 .LE. IELEM .LE. 3.') + IF(L4.NE.LL4F+LL4X+LL4Y+LL4Z) CALL XABORT('TRICHD: INVALID L4.') +*---- +* COMPUTE THE X-ORIENTED SYSTEM BANDWIDTH VECTOR +*---- + MUX(:L4)=1 + IPBBX(:2*IELEM,:LL4X)=0 + NUM1=0 + DO 20 KEL=1,LX*LY*LZ + IF(MAT(KEL).EQ.0) GO TO 20 + DO 12 K3=0,IELEM-1 + DO 11 K2=0,IELEM-1 + KN1=KN(NUM1+2+K3*IELEM+K2) + KN2=KN(NUM1+2+IELEM**2+K3*IELEM+K2) + INX1=ABS(KN1)-LL4F + INX2=ABS(KN2)-LL4F + IF((KN1.NE.0).AND.(KN2.NE.0)) THEN + MUX(INX2)=MAX(MUX(INX2),INX2-INX1+1) + MUX(INX1)=MAX(MUX(INX1),INX1-INX2+1) + ENDIF + DO 10 K1=0,IELEM-1 + JND1=KN(NUM1+1)+(K3*IELEM+K2)*IELEM+K1 + IF(KN1.NE.0) CALL TRINDX(JND1,IPBBX(1,INX1),2*IELEM) + IF(KN2.NE.0) CALL TRINDX(JND1,IPBBX(1,INX2),2*IELEM) + 10 CONTINUE + 11 CONTINUE + 12 CONTINUE + NUM1=NUM1+1+6*IELEM**2 + 20 CONTINUE +*---- +* COMPUTE THE Y-ORIENTED SYSTEM BANDWIDTH VECTOR +*---- + MUY(:L4)=1 + IPBBY(:2*IELEM,:LL4Y)=0 + NUM1=0 + DO 50 KEL=1,LX*LY*LZ + IF(MAT(KEL).EQ.0) GO TO 50 + DO 42 K3=0,IELEM-1 + DO 41 K1=0,IELEM-1 + KN1=KN(NUM1+2+2*IELEM**2+K3*IELEM+K1) + KN2=KN(NUM1+2+3*IELEM**2+K3*IELEM+K1) + INY1=ABS(KN1)-LL4F-LL4X + INY2=ABS(KN2)-LL4F-LL4X + IF((KN1.NE.0).AND.(KN2.NE.0)) THEN + MUY(INY2)=MAX(MUY(INY2),INY2-INY1+1) + MUY(INY1)=MAX(MUY(INY1),INY1-INY2+1) + ENDIF + DO 40 K2=0,IELEM-1 + JND1=KN(NUM1+1)+(K3*IELEM+K2)*IELEM+K1 + IF(KN1.NE.0) CALL TRINDX(JND1,IPBBY(1,INY1),2*IELEM) + IF(KN2.NE.0) CALL TRINDX(JND1,IPBBY(1,INY2),2*IELEM) + 40 CONTINUE + 41 CONTINUE + 42 CONTINUE + NUM1=NUM1+1+6*IELEM**2 + 50 CONTINUE +*---- +* COMPUTE THE Z-ORIENTED SYSTEM BANDWIDTH VECTOR +*---- + MUZ(:L4)=1 + IPBBZ(:2*IELEM,:LL4Z)=0 + NUM1=0 + DO 70 KEL=1,LX*LY*LZ + IF(MAT(KEL).EQ.0) GO TO 70 + DO 62 K2=0,IELEM-1 + DO 61 K1=0,IELEM-1 + KN1=KN(NUM1+2+4*IELEM**2+K2*IELEM+K1) + KN2=KN(NUM1+2+5*IELEM**2+K2*IELEM+K1) + INZ1=ABS(KN1)-LL4F-LL4X-LL4Y + INZ2=ABS(KN2)-LL4F-LL4X-LL4Y + IF((KN1.NE.0).AND.(KN2.NE.0)) THEN + MUZ(INZ2)=MAX(MUZ(INZ2),INZ2-INZ1+1) + MUZ(INZ1)=MAX(MUZ(INZ1),INZ1-INZ2+1) + ENDIF + DO 60 K3=0,IELEM-1 + JND1=KN(NUM1+1)+(K3*IELEM+K2)*IELEM+K1 + IF(KN1.NE.0) CALL TRINDX(JND1,IPBBZ(1,INZ1),2*IELEM) + IF(KN2.NE.0) CALL TRINDX(JND1,IPBBZ(1,INZ2),2*IELEM) + 60 CONTINUE + 61 CONTINUE + 62 CONTINUE + NUM1=NUM1+1+6*IELEM**2 + 70 CONTINUE +* + MUXMAX=0 + IIMAXX=0 + DO 80 I=1,LL4X + MUXMAX=MAX(MUXMAX,MUX(I)) + IIMAXX=IIMAXX+MUX(I) + MUX(I)=IIMAXX + 80 CONTINUE +* + MUYMAX=0 + IIMAXY=0 + DO 90 I=1,LL4Y + MUYMAX=MAX(MUYMAX,MUY(I)) + IIMAXY=IIMAXY+MUY(I) + MUY(I)=IIMAXY + 90 CONTINUE +* + MUZMAX=0 + IIMAXZ=0 + DO 100 I=1,LL4Z + MUZMAX=MAX(MUZMAX,MUZ(I)) + IIMAXZ=IIMAXZ+MUZ(I) + MUZ(I)=IIMAXZ + 100 CONTINUE + IF(IMPX.GT.0) THEN + WRITE (6,600) MUXMAX,MUYMAX,MUZMAX + WRITE (6,610) IIMAXX,IIMAXY,IIMAXZ + ENDIF +*---- +* COMPUTE THE FLUX-CURRENT COUPLING MATRICES XB, YB AND ZB. +*---- + BBX(:2*IELEM,:LL4X)=0.0 + BBY(:2*IELEM,:LL4Y)=0.0 + BBZ(:2*IELEM,:LL4Z)=0.0 + NUM1=0 + DO 270 IE=1,LX*LY*LZ + L=MAT(IE) + IF(L.EQ.0) GO TO 270 + VOL0=VOL(IE) + IF(VOL0.EQ.0.0) GO TO 260 + DX=XX(IE) + DY=YY(IE) + DZ=ZZ(IE) + IF(CYLIND) THEN + DIN=1.0-0.5*DX/DD(IE) + DOT=1.0+0.5*DX/DD(IE) + ELSE + DIN=1.0 + DOT=1.0 + ENDIF +* + DO 152 K3=0,IELEM-1 + DO 151 K2=0,IELEM-1 + INX1=ABS(KN(NUM1+2+K3*IELEM+K2))-LL4F + INX2=ABS(KN(NUM1+2+IELEM**2+K3*IELEM+K2))-LL4F + DO 150 K1=0,IELEM-1 + JND1=KN(NUM1+1)+(K3*IELEM+K2)*IELEM+K1 + IF(KN(NUM1+2+K3*IELEM+K2).NE.0) THEN + KK=0 + DO 110 I=1,2*IELEM + IF(IPBBX(I,INX1).EQ.JND1) THEN + KK=I + GO TO 120 + ENDIF + 110 CONTINUE + CALL XABORT('TRICHD: BUG1.') + 120 SG=REAL(SIGN(1,KN(NUM1+2+K3*IELEM+K2))) + BBX(KK,INX1)=BBX(KK,INX1)+SG*(VOL0/DX)*DIN*V(1,K1+1) + ENDIF + IF(KN(NUM1+2+IELEM**2+K3*IELEM+K2).NE.0) THEN + KK=0 + DO 130 I=1,2*IELEM + IF(IPBBX(I,INX2).EQ.JND1) THEN + KK=I + GO TO 140 + ENDIF + 130 CONTINUE + CALL XABORT('TRICHD: BUG2.') + 140 SG=REAL(SIGN(1,KN(NUM1+2+IELEM**2+K3*IELEM+K2))) + BBX(KK,INX2)=BBX(KK,INX2)+SG*(VOL0/DX)*DOT*V(IELEM+1,K1+1) + ENDIF + 150 CONTINUE + 151 CONTINUE + 152 CONTINUE +* + DO 202 K3=0,IELEM-1 + DO 201 K1=0,IELEM-1 + INY1=ABS(KN(NUM1+2+2*IELEM**2+K3*IELEM+K1))-LL4F-LL4X + INY2=ABS(KN(NUM1+2+3*IELEM**2+K3*IELEM+K1))-LL4F-LL4X + DO 200 K2=0,IELEM-1 + JND1=KN(NUM1+1)+(K3*IELEM+K2)*IELEM+K1 + IF(KN(NUM1+2+2*IELEM**2+K3*IELEM+K1).NE.0) THEN + KK=0 + DO 160 I=1,2*IELEM + IF(IPBBY(I,INY1).EQ.JND1) THEN + KK=I + GO TO 170 + ENDIF + 160 CONTINUE + CALL XABORT('TRICHD: BUG3.') + 170 SG=REAL(SIGN(1,KN(NUM1+2+2*IELEM**2+K3*IELEM+K1))) + BBY(KK,INY1)=BBY(KK,INY1)+SG*(VOL0/DY)*V(1,K2+1) + ENDIF + IF(KN(NUM1+2+3*IELEM**2+K3*IELEM+K1).NE.0) THEN + KK=0 + DO 180 I=1,2*IELEM + IF(IPBBY(I,INY2).EQ.JND1) THEN + KK=I + GO TO 190 + ENDIF + 180 CONTINUE + CALL XABORT('TRICHD: BUG4.') + 190 SG=REAL(SIGN(1,KN(NUM1+2+3*IELEM**2+K3*IELEM+K1))) + BBY(KK,INY2)=BBY(KK,INY2)+SG*(VOL0/DY)*V(IELEM+1,K2+1) + ENDIF + 200 CONTINUE + 201 CONTINUE + 202 CONTINUE +* + DO 252 K2=0,IELEM-1 + DO 251 K1=0,IELEM-1 + INZ1=ABS(KN(NUM1+2+4*IELEM**2+K2*IELEM+K1))-LL4F-LL4X-LL4Y + INZ2=ABS(KN(NUM1+2+5*IELEM**2+K2*IELEM+K1))-LL4F-LL4X-LL4Y + DO 250 K3=0,IELEM-1 + JND1=KN(NUM1+1)+(K3*IELEM+K2)*IELEM+K1 + IF(KN(NUM1+2+4*IELEM**2+K2*IELEM+K1).NE.0) THEN + KK=0 + DO 210 I=1,2*IELEM + IF(IPBBZ(I,INZ1).EQ.JND1) THEN + KK=I + GO TO 220 + ENDIF + 210 CONTINUE + CALL XABORT('TRICHD: BUG5.') + 220 SG=REAL(SIGN(1,KN(NUM1+2+4*IELEM**2+K2*IELEM+K1))) + BBZ(KK,INZ1)=BBZ(KK,INZ1)+SG*(VOL0/DZ)*V(1,K3+1) + ENDIF + IF(KN(NUM1+2+5*IELEM**2+K2*IELEM+K1).NE.0) THEN + KK=0 + DO 230 I=1,2*IELEM + IF(IPBBZ(I,INZ2).EQ.JND1) THEN + KK=I + GO TO 240 + ENDIF + 230 CONTINUE + CALL XABORT('TRICHD: BUG6.') + 240 SG=REAL(SIGN(1,KN(NUM1+2+5*IELEM**2+K2*IELEM+K1))) + BBZ(KK,INZ2)=BBZ(KK,INZ2)+SG*(VOL0/DZ)*V(IELEM+1,K3+1) + ENDIF + 250 CONTINUE + 251 CONTINUE + 252 CONTINUE + 260 NUM1=NUM1+1+6*IELEM**2 + 270 CONTINUE + RETURN +* + 600 FORMAT(/52H TRICHD: MAXIMUM BANDWIDTH FOR X-ORIENTED MATRICES =, + 1 I4/27X,25HFOR Y-ORIENTED MATRICES =,I4/27X,16HFOR Z-ORIENTED M, + 2 9HATRICES =,I4) + 610 FORMAT(/40H TRICHD: LENGTH OF X-ORIENTED MATRICES =,I10/16X, + 1 24HOF Y-ORIENTED MATRICES =,I10/16X,24HOF Z-ORIENTED MATRICES =, + 2 I10) + END diff --git a/Trivac/src/TRICHH.f b/Trivac/src/TRICHH.f new file mode 100755 index 0000000..5f46445 --- /dev/null +++ b/Trivac/src/TRICHH.f @@ -0,0 +1,364 @@ +*DECK TRICHH + SUBROUTINE TRICHH(IMPX,MAXKN,NBLOS,LXH,LZ,IELEM,ISPLH,L4,LL4F, + 1 LL4W,LL4X,LL4Y,LL4Z,SIDE,ZZ,FRZ,IPERT,KN,V,H,MUW,MUX,MUY,MUZ, + 2 IPBBW,IPBBX,IPBBY,IPBBZ,BBW,BBX,BBY,BBZ,CTRAN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Thomas-Raviart-Schneider (dual) finite element unknown numbering for +* ADI solution in a 3D hexagonal domain. Compute the storage info for +* ADI matrices in compressed diagonal storage mode. Compute the ADI +* permutation vectors. Compute the group-independent WB, XB, YB and ZB +* matrices. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IMPX print parameter. +* MAXKN number of components in KN. +* NBLOS number of lozenges per direction in 3D with mesh-splitting. +* LXH number of hexagons in a plane. +* LZ number of elements along the Z axis. +* IELEM degree of the Lagrangian finite elements: =1 (linear); +* =2 (parabolic); =3 (cubic). +* ISPLH mesh-splitting in 3*ISPLH**2 lozenges per hexagon. +* L4 total number of unknown (variational coefficients) per +* energy group (order of system matrices). +* LL4F exact number of flux unknowns. +* LL4W exact number of W-directed current unknowns. +* LL4X exact number of X-directed current unknowns. +* LL4Y exact number of Y-directed current unknowns. +* LL4Z exact number of Z-directed current unknowns. +* SIDE side of an hexagon. +* ZZ Z-directed mesh spacings. +* FRZ volume fractions for the axial SYME boundary condition. +* IPERT mixture permutation index. +* KN ADI permutation indices for the volumes and currents. +* V nodal coupling matrix matrix. +* H Piolat (hexagonal) coupling matrix. +* +*Parameters: output +* MUW W-directed compressed diagonal mode indices. +* MUX X-directed compressed diagonal mode indices. +* MUY Y-directed compressed diagonal mode indices. +* MUZ Z-directed compressed diagonal mode indices. +* IPBBW W-directed perdue storage indices. +* IPBBX X-directed perdue storage indices. +* IPBBY Y-directed perdue storage indices. +* IPBBZ Z-directed perdue storage indices. +* BBW W-directed flux-current matrices. +* BBX X-directed flux-current matrices. +* BBY Y-directed flux-current matrices. +* BBZ Z-directed flux-current matrices. +* CTRAN tranverse coupling Piolat unit matrix. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IMPX,MAXKN,NBLOS,LXH,LZ,IELEM,ISPLH,L4,IPERT(NBLOS), + 1 KN(NBLOS,MAXKN/NBLOS),LL4F,LL4W,LL4X,LL4Y,LL4Z,MUW(L4), + 2 MUX(L4),MUY(L4),MUZ(L4),IPBBW(2*IELEM,LL4W),IPBBX(2*IELEM,LL4X), + 3 IPBBY(2*IELEM,LL4Y),IPBBZ(2*IELEM,LL4Z) + REAL SIDE,ZZ(3,NBLOS),FRZ(NBLOS),V(IELEM+1,IELEM), + 1 H(IELEM+1,IELEM),BBW(2*IELEM,LL4W),BBX(2*IELEM,LL4X), + 2 BBY(2*IELEM,LL4Y),BBZ(2*IELEM,LL4Z) + DOUBLE PRECISION CTRAN((IELEM+1)*IELEM,(IELEM+1)*IELEM) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION TTTT,DENOM,VOL0 +* + NELEH=(IELEM+1)*IELEM**2 + NELEZ=6*IELEM**2 + NBC=INT((SQRT(REAL((4*LXH-1)/3))+1.)/2.) + IF(LL4F.GT.3*NBLOS*IELEM**3) CALL XABORT('TRICHH: BUG1.') + IF(LL4W.GT.(2*NBLOS*IELEM+(2*NBC-1)*ISPLH*LZ)*IELEM**2) + 1 CALL XABORT('TRICHH: BUG2.') +*---- +* COMPUTE THE TRANVERSE COUPLING PIOLAT UNIT MATRIX +*---- + CTRAN(:(IELEM+1)*IELEM,:(IELEM+1)*IELEM)=0.0D0 + CNORM=SIDE*SIDE/SQRT(3.) + I=0 + DO 22 JS=1,IELEM + DO 21 JT=1,IELEM+1 + J=0 + I=I+1 + SSS=1.0 + DO 20 IT=1,IELEM + DO 10 IS=1,IELEM+1 + J=J+1 + CTRAN(I,J)=SSS*CNORM*H(IS,JS)*H(JT,IT) + 10 CONTINUE + SSS=-SSS + 20 CONTINUE + 21 CONTINUE + 22 CONTINUE + IF(IMPX.GT.1) THEN + WRITE(6,*) 'TRICHH: MATRIX CTRAN' + DO 30 I=1,(IELEM+1)*IELEM + WRITE(6,'(10(1X,1P,E12.4))') (CTRAN(I,J),J=1,(IELEM+1)*IELEM) + 30 CONTINUE + WRITE(6,*) ' ' + ENDIF +*---- +* COMPUTE THE W-, X- ,Y- AND Z-ORIENTED SYSTEM BANDWIDTH VECTORS +*---- + MUW(:L4)=1 + MUX(:L4)=1 + MUY(:L4)=1 + MUZ(:L4)=1 + IPBBW(:2*IELEM,:LL4W)=0 + IPBBX(:2*IELEM,:LL4X)=0 + IPBBY(:2*IELEM,:LL4Y)=0 + IPBBZ(:2*IELEM,:LL4Z)=0 + NUM=0 + DO 80 KEL=1,NBLOS + IF(IPERT(KEL).EQ.0) GO TO 80 + NUM=NUM+1 + DO 64 K5=0,1 ! TWO LOZENGES PER HEXAGON + DO 63 K4=0,IELEM-1 + DO 62 K3=0,IELEM-1 + DO 61 K2=1,IELEM+1 + KNW1=KN(NUM,3+K5*NELEH+(K4*IELEM+K3)*(IELEM+1)+K2) + KNX1=KN(NUM,3+(K5+2)*NELEH+(K4*IELEM+K3)*(IELEM+1)+K2) + KNY1=KN(NUM,3+(K5+4)*NELEH+(K4*IELEM+K3)*(IELEM+1)+K2) + INW1=ABS(KNW1) + INX1=ABS(KNX1)-LL4W + INY1=ABS(KNY1)-LL4W-LL4X + DO 40 K1=1,IELEM+1 + KNW2=KN(NUM,3+K5*NELEH+(K4*IELEM+K3)*(IELEM+1)+K1) + KNX2=KN(NUM,3+(K5+2)*NELEH+(K4*IELEM+K3)*(IELEM+1)+K1) + KNY2=KN(NUM,3+(K5+4)*NELEH+(K4*IELEM+K3)*(IELEM+1)+K1) + INW2=ABS(KNW2) + INX2=ABS(KNX2)-LL4W + INY2=ABS(KNY2)-LL4W-LL4X + IF((KNW2.NE.0).AND.(KNW1.NE.0)) THEN + MUW(INW1)=MAX(MUW(INW1),INW1-INW2+1) + MUW(INW2)=MAX(MUW(INW2),INW2-INW1+1) + ENDIF + IF((KNX2.NE.0).AND.(KNX1.NE.0)) THEN + MUX(INX1)=MAX(MUX(INX1),INX1-INX2+1) + MUX(INX2)=MAX(MUX(INX2),INX2-INX1+1) + ENDIF + IF((KNY2.NE.0).AND.(KNY1.NE.0)) THEN + MUY(INY1)=MAX(MUY(INY1),INY1-INY2+1) + MUY(INY2)=MAX(MUY(INY2),INY2-INY1+1) + ENDIF + 40 CONTINUE + DO 60 K1=0,IELEM-1 + IF(V(K2,K1+1).EQ.0.0) GO TO 60 + IF(K5.EQ.0) THEN + JND1=(NUM-1)*IELEM**3+K4*IELEM**2+K3*IELEM+K1+1 + JND2=(KN(NUM,1)-1)*IELEM**3+K4*IELEM**2+K3*IELEM+K1+1 + JND3=(KN(NUM,2)-1)*IELEM**3+K4*IELEM**2+K3*IELEM+K1+1 + ELSE + JND1=(KN(NUM,1)-1)*IELEM**3+K4*IELEM**2+K1*IELEM+K3+1 + JND2=(KN(NUM,2)-1)*IELEM**3+K4*IELEM**2+K1*IELEM+K3+1 + JND3=(KN(NUM,3)-1)*IELEM**3+K4*IELEM**2+K1*IELEM+K3+1 + ENDIF + IF(KNW1.NE.0) CALL TRINDX(JND1,IPBBW(1,INW1),2*IELEM) + IF(KNX1.NE.0) CALL TRINDX(JND2,IPBBX(1,INX1),2*IELEM) + IF(KNY1.NE.0) CALL TRINDX(JND3,IPBBY(1,INY1),2*IELEM) + 60 CONTINUE + 61 CONTINUE + 62 CONTINUE + 63 CONTINUE + 64 CONTINUE + DO 73 K5=0,2 ! THREE LOZENGES PER HEXAGON + DO 72 K2=0,IELEM-1 + DO 71 K1=0,IELEM-1 + KNZ1=KN(NUM,3+6*NELEH+2*K5*IELEM**2+K2*IELEM+K1+1) + KNZ2=KN(NUM,3+6*NELEH+(2*K5+1)*IELEM**2+K2*IELEM+K1+1) + INZ1=ABS(KNZ1)-LL4W-LL4X-LL4Y + INZ2=ABS(KNZ2)-LL4W-LL4X-LL4Y + IF((KNZ1.NE.0).AND.(KNZ2.NE.0)) THEN + MUZ(INZ2)=MAX(MUZ(INZ2),INZ2-INZ1+1) + MUZ(INZ1)=MAX(MUZ(INZ1),INZ1-INZ2+1) + ENDIF + DO 70 K3=0,IELEM-1 + IF(K5.EQ.0) THEN + JND1=(NUM-1)*IELEM**3+K3*IELEM**2+K2*IELEM+K1+1 + ELSE + JND1=(KN(NUM,K5)-1)*IELEM**3+K3*IELEM**2+K2*IELEM+K1+1 + ENDIF + IF(KNZ1.NE.0) CALL TRINDX(JND1,IPBBZ(1,INZ1),2*IELEM) + IF(KNZ2.NE.0) CALL TRINDX(JND1,IPBBZ(1,INZ2),2*IELEM) + 70 CONTINUE + 71 CONTINUE + 72 CONTINUE + 73 CONTINUE + 80 CONTINUE +* + MUWMAX=0 + IIMAXW=0 + DO 90 I=1,LL4W + MUWMAX=MAX(MUWMAX,MUW(I)) + IIMAXW=IIMAXW+MUW(I) + MUW(I)=IIMAXW + 90 CONTINUE + MUXMAX=0 + IIMAXX=0 + DO 100 I=1,LL4X + MUXMAX=MAX(MUXMAX,MUX(I)) + IIMAXX=IIMAXX+MUX(I) + MUX(I)=IIMAXX + 100 CONTINUE + MUYMAX=0 + IIMAXY=0 + DO 110 I=1,LL4Y + MUYMAX=MAX(MUYMAX,MUY(I)) + IIMAXY=IIMAXY+MUY(I) + MUY(I)=IIMAXY + 110 CONTINUE + MUZMAX=0 + IIMAXZ=0 + DO 120 I=1,LL4Z + MUZMAX=MAX(MUZMAX,MUZ(I)) + IIMAXZ=IIMAXZ+MUZ(I) + MUZ(I)=IIMAXZ + 120 CONTINUE + IF(IMPX.GT.0) THEN + WRITE (6,600) MUWMAX,MUXMAX,MUYMAX,MUZMAX + WRITE (6,610) IIMAXW,IIMAXX,IIMAXY,IIMAXZ + ENDIF +*---- +* COMPUTE THE FLUX-CURRENT COUPLING MATRICES WB, XB, YB AND ZB. +*---- + BBW(:2*IELEM,:LL4W)=0.0 + BBX(:2*IELEM,:LL4X)=0.0 + BBY(:2*IELEM,:LL4Y)=0.0 + BBZ(:2*IELEM,:LL4Z)=0.0 + TTTT=0.5D0*SQRT(3.D00)*SIDE*SIDE + DENOM=0.5D0*SQRT(3.D00)*SIDE + NUM=0 + DO 260 KEL=1,NBLOS + IF(IPERT(KEL).EQ.0) GO TO 260 + NUM=NUM+1 + DZ=ZZ(1,IPERT(KEL)) + VOL0=TTTT*DZ*FRZ(KEL) + DO 194 K5=0,1 + DO 193 K4=0,IELEM-1 + DO 192 K3=0,IELEM-1 + DO 191 K2=1,IELEM+1 + KNW1=KN(NUM,3+K5*NELEH+(K4*IELEM+K3)*(IELEM+1)+K2) + KNX1=KN(NUM,3+(K5+2)*NELEH+(K4*IELEM+K3)*(IELEM+1)+K2) + KNY1=KN(NUM,3+(K5+4)*NELEH+(K4*IELEM+K3)*(IELEM+1)+K2) + INW1=ABS(KNW1) + INX1=ABS(KNX1)-LL4W + INY1=ABS(KNY1)-LL4W-LL4X + DO 190 K1=0,IELEM-1 + IF(V(K2,K1+1).EQ.0.0) GO TO 190 + IF(K5.EQ.0) THEN + SSS=(-1.0)**K1 + JND1=(NUM-1)*IELEM**3+K4*IELEM**2+K3*IELEM+K1+1 + JND2=(KN(NUM,1)-1)*IELEM**3+K4*IELEM**2+K3*IELEM+K1+1 + JND3=(KN(NUM,2)-1)*IELEM**3+K4*IELEM**2+K3*IELEM+K1+1 + ELSE + SSS=1.0 + JND1=(KN(NUM,1)-1)*IELEM**3+K4*IELEM**2+K1*IELEM+K3+1 + JND2=(KN(NUM,2)-1)*IELEM**3+K4*IELEM**2+K1*IELEM+K3+1 + JND3=(KN(NUM,3)-1)*IELEM**3+K4*IELEM**2+K1*IELEM+K3+1 + ENDIF + IF(KNW1.NE.0.0) THEN + KK=0 + DO 130 I=1,2*IELEM + IF(IPBBW(I,INW1).EQ.JND1) THEN + KK=I + GO TO 140 + ENDIF + 130 CONTINUE + CALL XABORT('TRICHH: BUG3.') + 140 SG=REAL(SIGN(1,KNW1)) + BBW(KK,INW1)=BBW(KK,INW1)+SG*SSS*REAL(VOL0/DENOM)*V(K2,K1+1) + ENDIF + IF(KNX1.NE.0.0) THEN + KK=0 + DO 150 I=1,2*IELEM + IF(IPBBX(I,INX1).EQ.JND2) THEN + KK=I + GO TO 160 + ENDIF + 150 CONTINUE + CALL XABORT('TRICHH: BUG4.') + 160 SG=REAL(SIGN(1,KNX1)) + BBX(KK,INX1)=BBX(KK,INX1)+SG*SSS*REAL(VOL0/DENOM)*V(K2,K1+1) + ENDIF + IF(KNY1.NE.0.0) THEN + KK=0 + DO 170 I=1,2*IELEM + IF(IPBBY(I,INY1).EQ.JND3) THEN + KK=I + GO TO 180 + ENDIF + 170 CONTINUE + CALL XABORT('TRICHH: BUG5.') + 180 SG=REAL(SIGN(1,KNY1)) + BBY(KK,INY1)=BBY(KK,INY1)+SG*SSS*REAL(VOL0/DENOM)*V(K2,K1+1) + ENDIF + 190 CONTINUE + 191 CONTINUE + 192 CONTINUE + 193 CONTINUE + 194 CONTINUE + DO 253 K5=0,2 ! THREE LOZENGES PER HEXAGON + DO 252 K2=0,IELEM-1 + DO 251 K1=0,IELEM-1 + KNZ1=KN(NUM,3+6*NELEH+2*K5*IELEM**2+K2*IELEM+K1+1) + KNZ2=KN(NUM,3+6*NELEH+(2*K5+1)*IELEM**2+K2*IELEM+K1+1) + INZ1=ABS(KNZ1)-LL4W-LL4X-LL4Y + INZ2=ABS(KNZ2)-LL4W-LL4X-LL4Y + DO 250 K3=0,IELEM-1 + IF(K5.EQ.0) THEN + JND1=(NUM-1)*IELEM**3+K3*IELEM**2+K2*IELEM+K1+1 + ELSE + JND1=(KN(NUM,K5)-1)*IELEM**3+K3*IELEM**2+K2*IELEM+K1+1 + ENDIF + IF(KNZ1.NE.0) THEN + KK=0 + DO 210 I=1,2*IELEM + IF(IPBBZ(I,INZ1).EQ.JND1) THEN + KK=I + GO TO 220 + ENDIF + 210 CONTINUE + CALL XABORT('TRICHH: BUG6.') + 220 SG=REAL(SIGN(1,KNZ1)) + BBZ(KK,INZ1)=BBZ(KK,INZ1)+SG*REAL(VOL0/DZ)*V(1,K3+1) + ENDIF + IF(KNZ2.NE.0) THEN + KK=0 + DO 230 I=1,2*IELEM + IF(IPBBZ(I,INZ2).EQ.JND1) THEN + KK=I + GO TO 240 + ENDIF + 230 CONTINUE + CALL XABORT('TRICHH: BUG7.') + 240 SG=REAL(SIGN(1,KNZ2)) + BBZ(KK,INZ2)=BBZ(KK,INZ2)+SG*REAL(VOL0/DZ)*V(IELEM+1,K3+1) + ENDIF + 250 CONTINUE + 251 CONTINUE + 252 CONTINUE + 253 CONTINUE + 260 CONTINUE + RETURN +* + 600 FORMAT(/52H TRICHH: MAXIMUM BANDWIDTH FOR W-ORIENTED MATRICES =, + 1 I4/27X,25HFOR X-ORIENTED MATRICES =,I4/27X,16HFOR Y-ORIENTED M, + 2 9HATRICES =,I4/27X,25HFOR Z-ORIENTED MATRICES =,I4) + 610 FORMAT(/40H TRICHH: LENGTH OF W-ORIENTED MATRICES =,I10/16X, + 1 24HOF X-ORIENTED MATRICES =,I10/16X,24HOF Y-ORIENTED MATRICES =, + 2 I10/16X,24HOF Z-ORIENTED MATRICES =,I10) + END diff --git a/Trivac/src/TRICHK.f b/Trivac/src/TRICHK.f new file mode 100755 index 0000000..d336d1b --- /dev/null +++ b/Trivac/src/TRICHK.f @@ -0,0 +1,135 @@ +*DECK TRICHK + SUBROUTINE TRICHK (HNAMT,IPTRK,IPSYS,IDIM,DIAG,CHEX,IPR,LL4) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Partial consistency check for an ADI-splitted system matrix. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* HNAMT name of the matrix to check. +* IPTRK L_TRACK pointer to the tracking information. +* IPSYS L_SYSTEM pointer to system matrices. +* IDIM number of dimensions. +* DIAG diagonal symmetry flag for cartesian geometries. +* CHEX hexagonal geometry flag. +* IPR perturbation flag (if IPR.ne.0, matrix may contain +* perturbation values). +* LL4 order of system matrices. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPSYS + CHARACTER HNAMT*10 + INTEGER IDIM,IPR,LL4 + LOGICAL DIAG,CHEX +*---- +* LOCAL VARIABLES +*---- + PARAMETER (EPSMAX=5.0E-5) + CHARACTER TEXT10*10,HSMG*60,TEXT8*8 + INTEGER, DIMENSION(:), ALLOCATABLE :: MU,IP + REAL, DIMENSION(:), ALLOCATABLE :: XTT1 + REAL, DIMENSION(:), POINTER :: A11 + TYPE(C_PTR) A11_PTR +* + TEXT10=HNAMT(:10) +*---- +* DIMENSION X +*---- + ALLOCATE(XTT1(LL4),MU(LL4),IP(LL4)) + CALL LCMGET(IPTRK,'IPX',IP) + IF(.NOT.DIAG) THEN + CALL LCMGET(IPTRK,'MUX',MU) + CALL LCMGPD(IPSYS,'X_'//TEXT10,A11_PTR) + ELSE +* DIAGONAL SYMMETRY + CALL LCMGET(IPTRK,'MUY',MU) + CALL LCMGPD(IPSYS,'Y_'//TEXT10,A11_PTR) + ENDIF + CALL C_F_POINTER(A11_PTR,A11,(/ MU(LL4) /)) + DO 10 I=1,LL4 + IGAR=MU(IP(I)) + XTT1(I)=A11(IGAR) + IF((IPR.EQ.0).AND.(XTT1(I).EQ.0.0)) THEN + WRITE (TEXT8,'(I8)') I + CALL XABORT('TRICHK: ZERO ELEMENT ON DIAGONAL ELEMENT'// + 1 TEXT8//' OF MATRIX '//TEXT10//'.') + ENDIF + 10 CONTINUE + DEALLOCATE(IP,MU) + IF(IDIM.EQ.1) GO TO 50 +*---- +* DIMENSION W +*---- + IF(CHEX) THEN + ALLOCATE(MU(LL4),IP(LL4)) + CALL LCMGET(IPTRK,'MUW',MU) + CALL LCMGET(IPTRK,'IPW',IP) + CALL LCMGPD(IPSYS,'W_'//TEXT10,A11_PTR) + CALL C_F_POINTER(A11_PTR,A11,(/ MU(LL4) /)) + DO 20 I=1,LL4 + RR=XTT1(I) + IGAR=MU(IP(I)) + IF(ABS(RR-A11(IGAR)).GT.ABS(RR)*EPSMAX) THEN + WRITE(HSMG,'(8H: DIAGX(,I6,3H )=,1P,E12.5,7H DIAGW(,I6, + 1 3H )=,E12.5)') I,RR,I,A11(IGAR) + CALL XABORT('TRICHK: W-AXIS INCONSISTENT ASSEMBLY(1)'//HSMG) + ENDIF + 20 CONTINUE + DEALLOCATE(IP,MU) + ENDIF +*---- +* DIMENSION Y +*---- + ALLOCATE(MU(LL4),IP(LL4)) + CALL LCMGET(IPTRK,'MUY',MU) + CALL LCMGET(IPTRK,'IPY',IP) + CALL LCMGPD(IPSYS,'Y_'//TEXT10,A11_PTR) + CALL C_F_POINTER(A11_PTR,A11,(/ MU(LL4) /)) + DO 30 I=1,LL4 + RR=XTT1(I) + IGAR=MU(IP(I)) + IF(ABS(RR-A11(IGAR)).GT.ABS(RR)*EPSMAX) THEN + WRITE(HSMG,'(8H: DIAGX(,I6,3H )=,1P,E12.5,7H DIAGY(,I6,3H )=, + 1 E12.5)') I,RR,I,A11(IGAR) + CALL XABORT('TRICHK: Y-AXIS INCONSISTENT ASSEMBLY(1)'//HSMG) + ENDIF + 30 CONTINUE + DEALLOCATE(IP,MU) +*---- +* DIMENSION Z +*---- + IF(IDIM.GT.2) THEN + ALLOCATE(MU(LL4),IP(LL4)) + CALL LCMGET(IPTRK,'MUZ',MU) + CALL LCMGET(IPTRK,'IPZ',IP) + CALL LCMGPD(IPSYS,'Z_'//TEXT10,A11_PTR) + CALL C_F_POINTER(A11_PTR,A11,(/ MU(LL4) /)) + DO 40 I=1,LL4 + RR=XTT1(I) + IGAR=MU(IP(I)) + IF(ABS(RR-A11(IGAR)).GT.ABS(RR)*EPSMAX) THEN + WRITE(HSMG,'(8H: DIAGX(,I6,3H )=,1P,E12.5,7H DIAGZ(,I6, + 1 3H )=,E12.5)') I,RR,I,A11(IGAR) + CALL XABORT('TRICHK: Z-AXIS INCONSISTENT ASSEMBLY(1)'//HSMG) + ENDIF + 40 CONTINUE + DEALLOCATE(IP,MU) + ENDIF + 50 DEALLOCATE(XTT1) + RETURN + END diff --git a/Trivac/src/TRICHP.f b/Trivac/src/TRICHP.f new file mode 100755 index 0000000..b518acf --- /dev/null +++ b/Trivac/src/TRICHP.f @@ -0,0 +1,222 @@ +*DECK TRICHP + SUBROUTINE TRICHP(IEL,LX,LY,LZ,L4,MAT,KN,MUX,MUY,MUZ,IPY,IPZ, + 1 IMPX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Primal finite element unknown numbering for ADI solution in a 3D +* domain. Compute the storage info for ADI matrices in compressed +* diagona storage mode. Compute the ADI permutation vectors. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IMPX print parameter. +* LX number of elements along the X axis. +* LY number of elements along the Y axis. +* LZ number of elements along the Z axis. +* IEL degree of the Lagrangian finite elements. =1 (linear); +* =2 (parabolic); =3 (cubic); =4 (quartic). +* L4 total number of unknown (variational coefficients) per +* energy group (order of system matrices). +* MAT mixture index assigned to each element. +* KN element-ordered unknown list. +* +*Parameters: output +* MUX X-directed compressed diagonal storage mode indices. +* MUY Y-directed compressed diagonal storage mode indices. +* MUZ Z-directed compressed diagonal storage mode indices. +* IPY Y-directed permutation vectors. +* IPZ Z-directed permutation vectors. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IEL,LX,LY,LZ,L4,MAT(LX*LY*LZ),KN(LX*LY*LZ*(IEL+1)**3), + 1 MUX(L4),MUY(L4),MUZ(L4),IPY(L4),IPZ(L4),IMPX +*---- +* LOCAL VARIABLES +*---- + INTEGER IJ1(125),IJ2(125),IJ3(125) + INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: IWRK +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IWRK(LX*IEL+1,LY*IEL+1,LZ*IEL+1)) +* + LC=IEL+1 + LL=LC*LC*LC + DO 5 L=1,LL + L1=1+MOD(L-1,LC) + L2=1+(L-L1)/LC + L3=1+MOD(L2-1,LC) + IJ1(L)=L1 + IJ2(L)=L3 + IJ3(L)=1+(L2-L3)/LC + 5 CONTINUE +*---- +* JUXTAPOSITION OF A CHECKERBOARD OVER A PLANE IN THE REACTOR +*---- + L2M=0 + LZTOT=LZ*(LC-1)+1 + LYTOT=LY*(LC-1)+1 + LXTOT=LX*(LC-1)+1 + DO 12 K=1,LZTOT + DO 11 J=1,LYTOT + DO 10 I=1,LXTOT + IWRK(I,J,K)=0 + 10 CONTINUE + 11 CONTINUE + 12 CONTINUE + NUM1=0 + KEL=0 + DO 32 K0=1,LZ + LK0=(K0-1)*(LC-1) + DO 31 K1=1,LY + LK1=(K1-1)*(LC-1) + DO 30 K2=1,LX + KEL=KEL+1 + IF(MAT(KEL).EQ.0) GO TO 30 + L2M=L2M+1 + LK2=(K2-1)*(LC-1) + L=0 + DO 22 IK0=LK0+1,LK0+LC + DO 21 IK1=LK1+1,LK1+LC + DO 20 IK2=LK2+1,LK2+LC + L=L+1 + IND1=KN(NUM1+L) + IF(IND1.EQ.0) GO TO 20 + IF(IWRK(IK2,IK1,IK0).EQ.0) THEN + IWRK(IK2,IK1,IK0)=IND1 + ELSE IF(IWRK(IK2,IK1,IK0).NE.IND1) THEN + CALL XABORT('TRICHP: FAILURE OF THE RENUMBERING ALGORITHM(1).') + ENDIF + 20 CONTINUE + 21 CONTINUE + 22 CONTINUE + NUM1=NUM1+LL + 30 CONTINUE + 31 CONTINUE + 32 CONTINUE +*---- +* CALCULATION OF PERMUTATION VECTORS IPY AND IPZ +*---- + DO 40 I=1,L4 + IPY(I)=0 + IPZ(I)=0 + 40 CONTINUE + INEW=0 + DO 52 K0=1,LZTOT + DO 51 K2=1,LXTOT + IF(IWRK(K2,1,K0).EQ.IWRK(K2,LC,K0)) THEN + K1MIN=1+LC/2 + ELSE + K1MIN=1 + ENDIF + DO 50 K1=K1MIN,LYTOT + I=IWRK(K2,K1,K0) + IF(I.EQ.0) GO TO 50 + IF(IPY(I).EQ.0) THEN + INEW=INEW+1 + IPY(I)=INEW + ENDIF + 50 CONTINUE + 51 CONTINUE + 52 CONTINUE + IF(INEW.NE.L4) THEN + CALL XABORT('TRICHP: FAILURE OF THE RENUMBERING ALGORITHM(2).') + ENDIF + INEW=0 + DO 72 K1=1,LYTOT + DO 71 K2=1,LXTOT + IF(IWRK(K2,K1,1).EQ.IWRK(K2,K1,LC)) THEN + K0MIN=1+LC/2 + ELSE + K0MIN=1 + ENDIF + DO 70 K0=K0MIN,LZTOT + I=IWRK(K2,K1,K0) + IF(I.EQ.0) GO TO 70 + IF(IPZ(I).EQ.0) THEN + INEW=INEW+1 + IPZ(I)=INEW + ENDIF + 70 CONTINUE + 71 CONTINUE + 72 CONTINUE + IF(INEW.NE.L4) THEN + CALL XABORT('TRICHP: FAILURE OF THE RENUMBERING ALGORITHM(3).') + ENDIF +*---- +* CALCULATION OF VECTORS MUX, MUY AND MUZ +*---- + DO 100 I=1,L4 + MUX(I)=1 + MUY(I)=1 + MUZ(I)=1 + 100 CONTINUE + NUM1=0 + DO 130 K=1,L2M + DO 120 I=1,LL + INX1=KN(NUM1+I) + IF(INX1.EQ.0) GO TO 120 + INY1=IPY(INX1) + INZ1=IPZ(INX1) + DO 110 J=1,LL + INX2=KN(NUM1+J) + IF(INX2.EQ.0) GO TO 110 + INY2=IPY(INX2) + INZ2=IPZ(INX2) + IF((IJ2(I).EQ.IJ2(J)).AND.(IJ3(I).EQ.IJ3(J)).AND.(INX2.LT.INX1)) + 1 THEN + MUX(INX1)=MAX0(MUX(INX1),INX1-INX2+1) + ELSE IF((IJ1(I).EQ.IJ1(J)).AND.(IJ3(I).EQ.IJ3(J)).AND. + 1 (INY2.LT.INY1)) THEN + MUY(INY1)=MAX0(MUY(INY1),INY1-INY2+1) + ELSE IF((IJ1(I).EQ.IJ1(J)).AND.(IJ2(I).EQ.IJ2(J)).AND. + 1 (INZ2.LT.INZ1)) THEN + MUZ(INZ1)=MAX0(MUZ(INZ1),INZ1-INZ2+1) + ENDIF + 110 CONTINUE + 120 CONTINUE + NUM1=NUM1+LL + 130 CONTINUE +* + MUXMAX=0 + MUYMAX=0 + MUZMAX=0 + IIMAXX=0 + IIMAXY=0 + IIMAXZ=0 + DO 140 I=1,L4 + MUXMAX=MAX(MUXMAX,MUX(I)) + MUYMAX=MAX(MUYMAX,MUY(I)) + MUZMAX=MAX(MUZMAX,MUZ(I)) + IIMAXX=IIMAXX+MUX(I) + MUX(I)=IIMAXX + IIMAXY=IIMAXY+MUY(I) + MUY(I)=IIMAXY + IIMAXZ=IIMAXZ+MUZ(I) + MUZ(I)=IIMAXZ + 140 CONTINUE + IF(IMPX.GT.0) WRITE (6,500) MUXMAX,MUYMAX,MUZMAX +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IWRK) + RETURN +* + 500 FORMAT(/52H TRICHP: MAXIMUM BANDWIDTH FOR X-ORIENTED MATRICES =, + 1 I4/27X,25HFOR Y-ORIENTED MATRICES =,I4/27X,16HFOR Z-ORIENTED M, + 2 9HATRICES =,I4) + END diff --git a/Trivac/src/TRICO.f b/Trivac/src/TRICO.f new file mode 100755 index 0000000..d5b0254 --- /dev/null +++ b/Trivac/src/TRICO.f @@ -0,0 +1,159 @@ +*DECK TRICO + SUBROUTINE TRICO (IELEM,IR,NEL,K,VOL0,MAT,DIF,XX,YY,ZZ,DD,KN,QFR, + 1 CYLIND,A) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the mesh centered finite difference coefficients in element K. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IELEM degree of the polynomial basis: =1 (linear/finite +* differences); =2 (parabolic); =3 (cubic); =4 (quartic). +* IR first dimension of matrix DIF. +* NEL total number of finite elements. +* K index of finite element under consideration. +* VOL0 volume of finite element under consideration. +* MAT mixture index assigned to each element. +* DIF directional diffusion coefficients. +* XX X-directed mesh spacings. +* YY Y-directed mesh spacings. +* ZZ Z-directed mesh spacings. +* DD used with cylindrical geometry. +* KN element-ordered unknown list: +* .GT.0: neighbour index; +* =-1: void/albedo boundary condition; +* =-2: reflection boundary condition; +* =-3: ZERO flux boundary condition; +* =-4: SYME boundary condition (axial symmetry). +* QFR element-ordered boundary conditions. +* CYLIND cylindrical geometry flag (set with CYLIND=.true.). +* +*Parameters: output +* A mesh centered finite difference coefficients. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IELEM,IR,NEL,K,MAT(NEL),KN(6) + REAL VOL0,DIF(IR,3),XX(NEL),YY(NEL),ZZ(NEL),DD(NEL),QFR(6) + LOGICAL CYLIND + DOUBLE PRECISION A(6) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION DHARM,DIN,DOT + DHARM(X1,X2,DIF1,DIF2)=2.0D0*DIF1*DIF2/(X1*DIF2+X2*DIF1) +* + DENOM=REAL((IELEM+1)*IELEM) + L=MAT(K) + DX=XX(K) + DY=YY(K) + DZ=ZZ(K) + IF(CYLIND) THEN + DIN=1.0D0-0.5D0*DX/DD(K) + DOT=1.0D0+0.5D0*DX/DD(K) + ELSE + DIN=1.0D0 + DOT=1.0D0 + ENDIF + KK1=KN(1) + KK2=KN(2) + KK3=KN(3) + KK4=KN(4) + KK5=KN(5) + KK6=KN(6) +* X- SIDE: + IF(KK1.GT.0) THEN + A(1)=DHARM(DX,XX(KK1),DIF(L,1),DIF(MAT(KK1),1))*DIN*VOL0/DX + ELSE IF(KK1.EQ.-1) THEN + A(1)=DHARM(DX,DX,DIF(L,1),DX*QFR(1)/DENOM)*DIN*VOL0/DX + ELSE IF(KK1.EQ.-2) THEN + A(1)=0.0D0 + ELSE IF(KK1.EQ.-3) THEN + A(1)=2.0D0*DHARM(DX,DX,DIF(L,1),DIF(L,1))*DIN*VOL0/DX + ENDIF +* X+ SIDE: + IF(KK2.GT.0) THEN + A(2)=DHARM(DX,XX(KK2),DIF(L,1),DIF(MAT(KK2),1))*DOT*VOL0/DX + ELSE IF(KK2.EQ.-1) THEN + A(2)=DHARM(DX,DX,DIF(L,1),DX*QFR(2)/DENOM)*DOT*VOL0/DX + ELSE IF(KK2.EQ.-2) THEN + A(2)=0.0D0 + ELSE IF(KK2.EQ.-3) THEN + A(2)=2.0D0*DHARM(DX,DX,DIF(L,1),DIF(L,1))*DOT*VOL0/DX + ELSE IF(KK2.EQ.-4) THEN + IF(KK1.EQ.-4) CALL XABORT('TRICO: INCONSISTENT SYME (1).') + A(2)=A(1) + ENDIF + IF(KK1.EQ.-4) THEN + IF(KK2.EQ.-4) CALL XABORT('TRICO: INCONSISTENT SYME (2).') + A(1)=A(2) + ENDIF +* Y- SIDE: + IF(KK3.GT.0) THEN + A(3)=DHARM(DY,YY(KK3),DIF(L,2),DIF(MAT(KK3),2))*VOL0/DY + ELSE IF(KK3.EQ.-1) THEN + A(3)=DHARM(DY,DY,DIF(L,2),DY*QFR(3)/DENOM)*VOL0/DY + ELSE IF(KK3.EQ.-2) THEN + A(3)=0.0D0 + ELSE IF(KK3.EQ.-3) THEN + A(3)=2.0D0*DHARM(DY,DY,DIF(L,2),DIF(L,2))*VOL0/DY + ENDIF +* Y+ SIDE: + IF(KK4.GT.0) THEN + A(4)=DHARM(DY,YY(KK4),DIF(L,2),DIF(MAT(KK4),2))*VOL0/DY + ELSE IF(KK4.EQ.-1) THEN + A(4)=DHARM(DY,DY,DIF(L,2),DY*QFR(4)/DENOM)*VOL0/DY + ELSE IF(KK4.EQ.-2) THEN + A(4)=0.0D0 + ELSE IF(KK4.EQ.-3) THEN + A(4)=2.0D0*DHARM(DY,DY,DIF(L,2),DIF(L,2))*VOL0/DY + ELSE IF(KK4.EQ.-4) THEN + IF(KK3.EQ.-4) CALL XABORT('TRICO: INCONSISTENT SYME (3).') + A(4)=A(3) + ENDIF + IF(KK3.EQ.-4) THEN + IF(KK4.EQ.-4) CALL XABORT('TRICO: INCONSISTENT SYME (4).') + A(3)=A(4) + ENDIF +* Z- SIDE: + IF(KK5.GT.0) THEN + A(5)=DHARM(DZ,ZZ(KK5),DIF(L,3),DIF(MAT(KK5),3))*VOL0/DZ + ELSE IF(KK5.EQ.-1) THEN + A(5)=DHARM(DZ,DZ,DIF(L,3),DZ*QFR(5)/DENOM)*VOL0/DZ + ELSE IF(KK5.EQ.-2) THEN + A(5)=0.0D0 + ELSE IF(KK5.EQ.-3) THEN + A(5)=2.0D0*DHARM(DZ,DZ,DIF(L,3),DIF(L,3))*VOL0/DZ + ENDIF +* Z+ SIDE: + IF(KK6.GT.0) THEN + A(6)=DHARM(DZ,ZZ(KK6),DIF(L,3),DIF(MAT(KK6),3))*VOL0/DZ + ELSE IF(KK6.EQ.-1) THEN + A(6)=DHARM(DZ,DZ,DIF(L,3),DZ*QFR(6)/DENOM)*VOL0/DZ + ELSE IF(KK6.EQ.-2) THEN + A(6)=0.0D0 + ELSE IF(KK6.EQ.-3) THEN + A(6)=2.0D0*DHARM(DZ,DZ,DIF(L,3),DIF(L,3))*VOL0/DZ + ELSE IF(KK6.EQ.-4) THEN + IF(KK5.EQ.-4) CALL XABORT('TRICO: INCONSISTENT SYME (5).') + A(6)=A(5) + ENDIF + IF(KK5.EQ.-4) THEN + IF(KK6.EQ.-4) CALL XABORT('TRICO: INCONSISTENT SYME (6).') + A(5)=A(6) + ENDIF + RETURN + END diff --git a/Trivac/src/TRICYL.f b/Trivac/src/TRICYL.f new file mode 100755 index 0000000..324e63c --- /dev/null +++ b/Trivac/src/TRICYL.f @@ -0,0 +1,277 @@ +*DECK TRICYL + SUBROUTINE TRICYL(MAXMIX,IMPX,ICHX,IDIM,LX,LY,LZ,XX,YY,ZZ,VOL, + 1 MAT,NCODE,ZALB,NR0,RR0,XR0,ANG,SGD,QFR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the albedo term corresponding to a cylinderized boundary +* in Cartesian geometry. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* MAXMIX first dimension of matrix SGD. +* IMPX print parameter (equal to zero for no print). +* ICHX type of finite element approximation: +* =1 primal (Lagrangian) finite elements or mesh corner finit +* differences; +* =2 dual finite elements; +* =3 or 4 nodal collocation method or mesh centered finite +* differences. +* IDIM number of dimensions. +* LX number of elements along the X axis. +* LY number of elements along the Y axis. +* LZ number of elements along the Z axis. +* XX X-directed mesh spacings. +* YY Y-directed mesh spacings. +* ZZ Z-directed mesh spacings. +* VOL volume of each element. +* MAT mixture index of each element. +* NCODE type of boundary condition applied on each side +* (i=1: X- i=2: X+ i=3: Y- i=4: Y+): +* NCODE(I)=1: VOID; NCODE(I)=2: REFL; NCODE(I)=5: SYME; +* NCODE(I)=7: ZERO; NCODE(I)=20: VOID on cylindrical boundary. +* ZALB albedo function corresponding to boundary condition 'VOID' on +* each side (ZALB(I)=0.0 by default). +* NR0 number of radii. +* RR0 radii. +* XR0 coordinates on principal axis. +* ANG angles for applying circular correction. +* SGD directional diffusion coefficients per mixture. +* +*Parameters: output +* QFR boundary transmission factor. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MAXMIX,IMPX,ICHX,IDIM,LX,LY,LZ,MAT(LX*LY*LZ),NCODE(6),NR0 + REAL XX(LX*LY*LZ),YY(LX*LY*LZ),ZZ(LX*LY*LZ),VOL(LX*LY*LZ), + 1 ZALB(6),RR0(NR0),XR0(NR0),ANG(NR0),SGD(MAXMIX,3),QFR(6*LX*LY*LZ) +*---- +* LOCAL VARIABLES +*---- + LOGICAL LL1 + CHARACTER*4 CAXE(3) + REAL CENTER(3),CELEM(3) + REAL, DIMENSION(:), ALLOCATABLE :: XXX,YYY,ZZZ + DATA CAXE / '(X) ', '(Y) ', '(Z) ' / +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(XXX(LX+1),YYY(LY+1),ZZZ(LZ+1)) +*---- +* DETERMINE CARTESIAN COORDINATES +*---- + KEL=0 + ZZZ(1)=0.0 + DO 12 K0=1,LZ + YYY(1)=0.0 + DO 11 K1=1,LY + XXX(1)=0.0 + DO 10 K2=1,LX + KEL=KEL+1 + IF(MAT(KEL).LE.0) GO TO 10 + XXX(K2+1)=XXX(K2)+XX(KEL) + YYY(K1+1)=YYY(K1)+YY(KEL) + ZZZ(K0+1)=ZZZ(K0)+ZZ(KEL) + 10 CONTINUE + 11 CONTINUE + 12 CONTINUE +* + CALL TRIKAX (IDIM,NCODE,XXX,YYY,ZZZ,LX,LY,LZ,IAXIS,CENTER) + IF((IAXIS.GT.0).AND.(IMPX.GT.0)) THEN + WRITE(6,600) CAXE(IAXIS), + 1 CAXE(MOD(IAXIS ,3)+1), CENTER(MOD(IAXIS ,3)+1), + 2 CAXE(MOD(IAXIS+1,3)+1), CENTER(MOD(IAXIS+1,3)+1) + ENDIF + IF(NR0.LE.0) CALL XABORT('TRICYL: B.C. RADIUS NOT DEFINED.') +* + NUM2=0 + KEL=0 + DO 152 K0=1,LZ + DO 151 K1=1,LY + DO 150 K2=1,LX + KEL=KEL+1 + L=MAT(KEL) + IF(L.LE.0) GO TO 150 +* + IF(K2.EQ.1) THEN + LL1=.TRUE. + ELSE + LL1=(MAT(KEL-1).EQ.0) + ENDIF + IF(LL1.AND.(NCODE(1).EQ.20)) THEN + CELEM(1)=XXX(K2) + CELEM(2)=0.5*(YYY(K1+1)+YYY(K1)) + CELEM(3)=0.5*(ZZZ(K0+1)+ZZZ(K0)) + CALL TRIZNR(IMPX,1,CENTER,CELEM,IAXIS,NR0,RR0,XR0,ANG,QFRI, + 1 QTRI) + IF(ICHX.EQ.2) THEN + QFR(NUM2+1)=(SGD(L,1)*ZALB(1)+QTRI)/(SGD(L,1)*QFRI) + ELSE + QFR(NUM2+1)=SGD(L,1)*QFRI*ZALB(1)/(SGD(L,1)+QTRI*ZALB(1)) + ENDIF + IF((ICHX.EQ.1).OR.(ICHX.EQ.2)) THEN + QFR(NUM2+1)=QFR(NUM2+1)*VOL(KEL)/(XXX(K2+1)-XXX(K2)) + ENDIF + ENDIF +* + IF(K2.EQ.LX) THEN + LL1=.TRUE. + ELSE + LL1=(MAT(KEL+1).EQ.0) + ENDIF + IF(LL1.AND.(NCODE(2).EQ.20)) THEN + CELEM(1)=XXX(K2+1) + CELEM(2)=0.5*(YYY(K1+1)+YYY(K1)) + CELEM(3)=0.5*(ZZZ(K0+1)+ZZZ(K0)) + CALL TRIZNR(IMPX,2,CENTER,CELEM,IAXIS,NR0,RR0,XR0,ANG,QFRI, + 1 QTRI) + IF(ICHX.EQ.2) THEN + QFR(NUM2+2)=(SGD(L,1)*ZALB(2)+QTRI)/(SGD(L,1)*QFRI) + ELSE + QFR(NUM2+2)=SGD(L,1)*QFRI*ZALB(2)/(SGD(L,1)+QTRI*ZALB(2)) + ENDIF + IF((ICHX.EQ.1).OR.(ICHX.EQ.2)) THEN + QFR(NUM2+2)=QFR(NUM2+2)*VOL(KEL)/(XXX(K2+1)-XXX(K2)) + ENDIF + ENDIF +* + IF(K1.EQ.1) THEN + LL1=.TRUE. + ELSE + LL1=(MAT(KEL-LX).EQ.0) + ENDIF + IF(LL1.AND.(NCODE(3).EQ.20)) THEN + CELEM(1)=0.5*(XXX(K2+1)+XXX(K2)) + CELEM(2)=YYY(K1) + CELEM(3)=0.5*(ZZZ(K0+1)+ZZZ(K0)) + CALL TRIZNR(IMPX,3,CENTER,CELEM,IAXIS,NR0,RR0,XR0,ANG,QFRI, + 1 QTRI) + IF(ICHX.EQ.2) THEN + QFR(NUM2+3)=(SGD(L,2)*ZALB(3)+QTRI)/(SGD(L,2)*QFRI) + ELSE + QFR(NUM2+3)=SGD(L,2)*QFRI*ZALB(3)/(SGD(L,2)+QTRI*ZALB(3)) + ENDIF + IF((ICHX.EQ.1).OR.(ICHX.EQ.2)) THEN + QFR(NUM2+3)=QFR(NUM2+3)*VOL(KEL)/(YYY(K1+1)-YYY(K1)) + ENDIF + ENDIF +* + IF(K1.EQ.LY) THEN + LL1=.TRUE. + ELSE + LL1=(MAT(KEL+LX).EQ.0) + ENDIF + IF(LL1.AND.(NCODE(4).EQ.20)) THEN + CELEM(1)=0.5*(XXX(K2+1)+XXX(K2)) + CELEM(2)=YYY(K1+1) + CELEM(3)=0.5*(ZZZ(K0+1)+ZZZ(K0)) + CALL TRIZNR(IMPX,4,CENTER,CELEM,IAXIS,NR0,RR0,XR0,ANG,QFRI, + 1 QTRI) + IF(ICHX.EQ.2) THEN + QFR(NUM2+4)=(SGD(L,2)*ZALB(4)+QTRI)/(SGD(L,2)*QFRI) + ELSE + QFR(NUM2+4)=SGD(L,2)*QFRI*ZALB(4)/(SGD(L,2)+QTRI*ZALB(4)) + ENDIF + IF((ICHX.EQ.1).OR.(ICHX.EQ.2)) THEN + QFR(NUM2+4)=QFR(NUM2+4)*VOL(KEL)/(YYY(K1+1)-YYY(K1)) + ENDIF + ENDIF +* + IF(K0.EQ.1) THEN + LL1=.TRUE. + ELSE + LL1=(MAT(KEL-LX*LY).EQ.0) + ENDIF + IF(LL1.AND.(NCODE(5).EQ.20)) THEN + CELEM(1)=0.5*(XXX(K2+1)+XXX(K2)) + CELEM(2)=0.5*(YYY(K1+1)+YYY(K1)) + CELEM(3)=ZZZ(K0) + CALL TRIZNR(IMPX,5,CENTER,CELEM,IAXIS,NR0,RR0,XR0,ANG,QFRI, + 1 QTRI) + IF(ICHX.EQ.2) THEN + QFR(NUM2+5)=(SGD(L,3)*ZALB(5)+QTRI)/(SGD(L,3)*QFRI) + ELSE + QFR(NUM2+5)=SGD(L,3)*QFRI*ZALB(5)/(SGD(L,3)+QTRI*ZALB(5)) + ENDIF + IF((ICHX.EQ.1).OR.(ICHX.EQ.2)) THEN + QFR(NUM2+5)=QFR(NUM2+5)*VOL(KEL)/(ZZZ(K0+1)-ZZZ(K0)) + ENDIF + ENDIF +* + IF(K0.EQ.LZ) THEN + LL1=.TRUE. + ELSE + LL1=(MAT(KEL+LX*LY).EQ.0) + ENDIF + IF(LL1.AND.(NCODE(6).EQ.20)) THEN + CELEM(1)=0.5*(XXX(K2+1)+XXX(K2)) + CELEM(2)=0.5*(YYY(K1+1)+YYY(K1)) + CELEM(3)=ZZZ(K0+1) + CALL TRIZNR(IMPX,6,CENTER,CELEM,IAXIS,NR0,RR0,XR0,ANG,QFRI, + 1 QTRI) + IF(ICHX.EQ.2) THEN + QFR(NUM2+6)=(SGD(L,3)*ZALB(6)+QTRI)/(SGD(L,3)*QFRI) + ELSE + QFR(NUM2+6)=SGD(L,3)*QFRI*ZALB(6)/(SGD(L,3)+QTRI*ZALB(6)) + ENDIF + IF((ICHX.EQ.1).OR.(ICHX.EQ.2)) THEN + QFR(NUM2+6)=QFR(NUM2+6)*VOL(KEL)/(ZZZ(K0+1)-ZZZ(K0)) + ENDIF + ENDIF +* + IF((NCODE(1).EQ.5).AND.(NCODE(2).EQ.20).AND.(LX.EQ.1)) THEN + QFR(NUM2+1)=QFR(NUM2+2) + ELSE IF((NCODE(1).EQ.20).AND.(NCODE(2).EQ.5).AND.(LX.EQ.1)) THEN + QFR(NUM2+2)=QFR(NUM2+1) + ENDIF + IF((NCODE(3).EQ.5).AND.(NCODE(4).EQ.20).AND.(LY.EQ.1)) THEN + QFR(NUM2+3)=QFR(NUM2+4) + ELSE IF((NCODE(3).EQ.20).AND.(NCODE(4).EQ.5).AND.(LY.EQ.1)) THEN + QFR(NUM2+4)=QFR(NUM2+3) + ENDIF + IF((NCODE(5).EQ.5).AND.(NCODE(6).EQ.20).AND.(LZ.EQ.1)) THEN + QFR(NUM2+5)=QFR(NUM2+6) + ELSE IF((NCODE(5).EQ.20).AND.(NCODE(6).EQ.5).AND.(LZ.EQ.1)) THEN + QFR(NUM2+6)=QFR(NUM2+5) + ENDIF +* + NUM2=NUM2+6 + 150 CONTINUE + 151 CONTINUE + 152 CONTINUE +* + IF(IMPX.GE.2) THEN + WRITE (6,610) + NUM2=0 + DO 160 KEL=1,LX*LY*LZ + IF(MAT(KEL).LE.0) GO TO 160 + WRITE (6,620) KEL,(QFR(NUM2+I),I=1,6) + NUM2=NUM2+6 + 160 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(XXX,YYY,ZZZ) + RETURN +* + 600 FORMAT (/52H TRICYL: CYLINDRICAL ALBEDO BOUNDARY CONDITION ON A , + 1 17HCYLINDER OF AXIS ,A4/ + 2 9X,12HCENTER IS ( ,A4,1H=,1P,E15.7,3H , ,A4,1H=,E15.7 ,1H) ) + 610 FORMAT(///53H VOID BOUNDARY CONDITION WITH CYLINDRICAL CORRECTION: + 1 //8H ELEMENT,5X,3HQFR) + 620 FORMAT(1X,I6,4X,1P,6E11.2) + END diff --git a/Trivac/src/TRIDCO.f b/Trivac/src/TRIDCO.f new file mode 100755 index 0000000..cfa4e0d --- /dev/null +++ b/Trivac/src/TRIDCO.f @@ -0,0 +1,282 @@ +*DECK TRIDCO + SUBROUTINE TRIDCO (IELEM,IR,NEL,K,VOL0,MAT,DIF,DDF,XX,YY,ZZ,DD,KN, + 1 QFR,CYLIND,IPR,A) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the derivative or variation of mesh centered finite difference +* coefficients in element K. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IELEM degree of the polynomial basis: =1 (linear/finite +* differences); =2 (parabolic); =3 (cubic); =4 (quartic). +* IR first dimension of matrix DIF. +* NEL total number of finite elements. +* K index of finite element under consideration. +* VOL0 volume of finite element under consideration. +* MAT mixture index assigned to each element. +* DIF directional diffusion coefficients +* DDF derivative or variation of directional diffusion coefficients. +* XX X-directed mesh spacings. +* YY Y-directed mesh spacings. +* ZZ Z-directed mesh spacings. +* DD used with cylindrical geometry. +* KN element-ordered unknown list: +* .GT.0: neighbour index; +* =-1: void/albedo boundary condition; +* =-2: reflection boundary condition; +* =-3: ZERO flux boundary condition; +* =-4: SYME boundary condition (axial symmetry). +* QFR element-ordered boundary conditions. +* CYLIND cylindrical geometry flag (set with CYLIND =.true.). +* IPR type of coefficient calculation: +* .eq.1 take derivative of MCFD coefficients; +* .ge.2 take variation of MCFD coefficients. +* +*Parameters: output +* A derivative or variation of mesh centered finite difference +* coefficients. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IELEM,IR,NEL,K,MAT(NEL),KN(6),IPR + REAL VOL0,DIF(IR,3),DDF(IR,3),XX(NEL),YY(NEL),ZZ(NEL),DD(NEL), + 1 QFR(6) + LOGICAL CYLIND + DOUBLE PRECISION A(6) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION VHARM,DHARM,DIN,DOT +* +* VARIATION FORMULA: + VHARM(X1,X2,DIF1,DIF2,DDF1,DDF2)=2.0D0*((DIF1+DDF1)*(DIF2+DDF2) + 1 /(X1*(DIF2+DDF2)+X2*(DIF1+DDF1))-DIF1*DIF2/(X1*DIF2+X2*DIF1)) +* DERIVATIVE FORMULA: + DHARM(X1,X2,DIF1,DIF2,DDF1,DDF2)=2.0D0*(X1*DIF2*DIF2*DDF1+ + 1 X2*DIF1*DIF1*DDF2)/(X1*DIF2+X2*DIF1)**2 +* + DENOM=REAL((IELEM+1)*IELEM) + L=MAT(K) + DX=XX(K) + DY=YY(K) + DZ=ZZ(K) + IF(CYLIND) THEN + DIN=1.0D0-0.5D0*DX/DD(K) + DOT=1.0D0+0.5D0*DX/DD(K) + ELSE + DIN=1.0D0 + DOT=1.0D0 + ENDIF + KK1=KN(1) + KK2=KN(2) + KK3=KN(3) + KK4=KN(4) + KK5=KN(5) + KK6=KN(6) + IF(IPR.EQ.1) THEN +* DERIVATIVE FORMULA. +* X- SIDE: + IF(KK1.GT.0) THEN + A(1)=DHARM(DX,XX(KK1),DIF(L,1),DIF(MAT(KK1),1),DDF(L,1), + 1 DDF(MAT(KK1),1))*DIN*VOL0/DX + ELSE IF(KK1.EQ.-1) THEN + A(1)=DHARM(DX,DX,DIF(L,1),DX*QFR(1)/DENOM,DDF(L,1),0.0) + 1 *DIN*VOL0/DX + ELSE IF(KK1.EQ.-2) THEN + A(1)=0.0D0 + ELSE IF(KK1.EQ.-3) THEN + A(1)=2.0D0*DDF(L,1)*DIN*VOL0/(DX*DX) + ENDIF +* X+ SIDE: + IF(KK2.GT.0) THEN + A(2)=DHARM(DX,XX(KK2),DIF(L,1),DIF(MAT(KK2),1),DDF(L,1), + 1 DDF(MAT(KK2),1))*DOT*VOL0/DX + ELSE IF(KK2.EQ.-1) THEN + A(2)=DHARM(DX,DX,DIF(L,1),DX*QFR(2)/DENOM,DDF(L,1),0.0) + 1 *DOT*VOL0/DX + ELSE IF(KK2.EQ.-2) THEN + A(2)=0.0D0 + ELSE IF(KK2.EQ.-3) THEN + A(2)=2.0D0*DDF(L,1)*DOT*VOL0/(DX*DX) + ELSE IF(KK2.EQ.-4) THEN + IF(KK1.EQ.-4) CALL XABORT('TRIDCO: INCONSISTENT SYME (1).') + A(2)=A(1) + ENDIF + IF(KK1.EQ.-4) THEN + IF(KK2.EQ.-4) CALL XABORT('TRIDCO: INCONSISTENT SYME (2).') + A(1)=A(2) + ENDIF +* Y- SIDE: + IF(KK3.GT.0) THEN + A(3)=DHARM(DY,YY(KK3),DIF(L,2),DIF(MAT(KK3),2),DDF(L,2), + 1 DDF(MAT(KK3),2))*VOL0/DY + ELSE IF(KK3.EQ.-1) THEN + A(3)=DHARM(DY,DY,DIF(L,2),DY*QFR(3)/DENOM,DDF(L,2),0.0) + 1 *VOL0/DY + ELSE IF(KK3.EQ.-2) THEN + A(3)=0.0D0 + ELSE IF(KK3.EQ.-3) THEN + A(3)=2.0D0*DDF(L,2)*VOL0/(DY*DY) + ENDIF +* Y+ SIDE: + IF(KK4.GT.0) THEN + A(4)=DHARM(DY,YY(KK4),DIF(L,2),DIF(MAT(KK4),2),DDF(L,2), + 1 DDF(MAT(KK4),2))*VOL0/DY + ELSE IF(KK4.EQ.-1) THEN + A(4)=DHARM(DY,DY,DIF(L,2),DY*QFR(4)/DENOM,DDF(L,2),0.0) + 1 *VOL0/DY + ELSE IF(KK4.EQ.-2) THEN + A(4)=0.0D0 + ELSE IF(KK4.EQ.-3) THEN + A(4)=2.0D0*DDF(L,2)*VOL0/(DY*DY) + ELSE IF(KK4.EQ.-4) THEN + IF(KK3.EQ.-4) CALL XABORT('TRIDCO: INCONSISTENT SYME (3).') + A(4)=A(3) + ENDIF + IF(KK3.EQ.-4) THEN + IF(KK4.EQ.-4) CALL XABORT('TRIDCO: INCONSISTENT SYME (4).') + A(3)=A(4) + ENDIF +* Z- SIDE: + IF(KK5.GT.0) THEN + A(5)=DHARM(DZ,ZZ(KK5),DIF(L,3),DIF(MAT(KK5),3),DDF(L,3), + 1 DDF(MAT(KK5),3))*VOL0/DZ + ELSE IF(KK5.EQ.-1) THEN + A(5)=DHARM(DZ,DZ,DIF(L,3),DZ*QFR(5)/DENOM,DDF(L,3),0.0) + 1 *VOL0/DZ + ELSE IF(KK5.EQ.-2) THEN + A(5)=0.0D0 + ELSE IF(KK5.EQ.-3) THEN + A(5)=2.0D0*DDF(L,3)*VOL0/(DZ*DZ) + ENDIF +* Z+ SIDE: + IF(KK6.GT.0) THEN + A(6)=DHARM(DZ,ZZ(KK6),DIF(L,3),DIF(MAT(KK6),3),DDF(L,3), + 1 DDF(MAT(KK6),3))*VOL0/DZ + ELSE IF(KK6.EQ.-1) THEN + A(6)=DHARM(DZ,DZ,DIF(L,3),DZ*QFR(6)/DENOM,DDF(L,3),0.0) + 1 *VOL0/DZ + ELSE IF(KK6.EQ.-2) THEN + A(6)=0.0D0 + ELSE IF(KK6.EQ.-3) THEN + A(6)=2.0D0*DDF(L,3)*VOL0/(DZ*DZ) + ELSE IF(KK6.EQ.-4) THEN + IF(KK5.EQ.-4) CALL XABORT('TRIDCO: INCONSISTENT SYME (5).') + A(6)=A(5) + ENDIF + IF(KK5.EQ.-4) THEN + IF(KK6.EQ.-4) CALL XABORT('TRIDCO: INCONSISTENT SYME (6).') + A(5)=A(6) + ENDIF + ELSE +* VARIATION FORMULA. +* X- SIDE: + IF(KK1.GT.0) THEN + A(1)=VHARM(DX,XX(KK1),DIF(L,1),DIF(MAT(KK1),1),DDF(L,1), + 1 DDF(MAT(KK1),1))*DIN*VOL0/DX + ELSE IF(KK1.EQ.-1) THEN + A(1)=VHARM(DX,DX,DIF(L,1),DX*QFR(1)/DENOM,DDF(L,1),0.0) + 1 *DIN*VOL0/DX + ELSE IF(KK1.EQ.-2) THEN + A(1)=0.0D0 + ELSE IF(KK1.EQ.-3) THEN + A(1)=2.0D0*DDF(L,1)*DIN*VOL0/(DX*DX) + ENDIF +* X+ SIDE: + IF(KK2.GT.0) THEN + A(2)=VHARM(DX,XX(KK2),DIF(L,1),DIF(MAT(KK2),1),DDF(L,1), + 1 DDF(MAT(KK2),1))*DOT*VOL0/DX + ELSE IF(KK2.EQ.-1) THEN + A(2)=VHARM(DX,DX,DIF(L,1),DX*QFR(2)/DENOM,DDF(L,1),0.0) + 1 *DOT*VOL0/DX + ELSE IF(KK2.EQ.-2) THEN + A(2)=0.0D0 + ELSE IF(KK2.EQ.-3) THEN + A(2)=2.0D0*DDF(L,1)*DOT*VOL0/(DX*DX) + ELSE IF(KK2.EQ.-4) THEN + IF(KK1.EQ.-4) CALL XABORT('TRIDCO: INCONSISTENT SYME (7).') + A(2)=A(1) + ENDIF + IF(KK1.EQ.-4) THEN + IF(KK2.EQ.-4) CALL XABORT('TRIDCO: INCONSISTENT SYME (8).') + A(1)=A(2) + ENDIF +* Y- SIDE: + IF(KK3.GT.0) THEN + A(3)=VHARM(DY,YY(KK3),DIF(L,2),DIF(MAT(KK3),2),DDF(L,2), + 1 DDF(MAT(KK3),2))*VOL0/DY + ELSE IF(KK3.EQ.-1) THEN + A(3)=VHARM(DY,DY,DIF(L,2),DY*QFR(3)/DENOM,DDF(L,2),0.0) + 1 *VOL0/DY + ELSE IF(KK3.EQ.-2) THEN + A(3)=0.0D0 + ELSE IF(KK3.EQ.-3) THEN + A(3)=2.0D0*DDF(L,2)*VOL0/(DY*DY) + ENDIF +* Y+ SIDE: + IF(KK4.GT.0) THEN + A(4)=VHARM(DY,YY(KK4),DIF(L,2),DIF(MAT(KK4),2),DDF(L,2), + 1 DDF(MAT(KK4),2))*VOL0/DY + ELSE IF(KK4.EQ.-1) THEN + A(4)=VHARM(DY,DY,DIF(L,2),DY*QFR(4)/DENOM,DDF(L,2),0.0) + 1 *VOL0/DY + ELSE IF(KK4.EQ.-2) THEN + A(4)=0.0D0 + ELSE IF(KK4.EQ.-3) THEN + A(4)=2.0D0*DDF(L,2)*VOL0/(DY*DY) + ELSE IF(KK4.EQ.-4) THEN + IF(KK3.EQ.-4) CALL XABORT('TRIDCO: INCONSISTENT SYME (9).') + A(4)=A(3) + ENDIF + IF(KK3.EQ.-4) THEN + IF(KK4.EQ.-4) CALL XABORT('TRIDCO: INCONSISTENT SYME (10).') + A(3)=A(4) + ENDIF +* Z- SIDE: + IF(KK5.GT.0) THEN + A(5)=VHARM(DZ,ZZ(KK5),DIF(L,3),DIF(MAT(KK5),3),DDF(L,3), + 1 DDF(MAT(KK5),3))*VOL0/DZ + ELSE IF(KK5.EQ.-1) THEN + A(5)=VHARM(DZ,DZ,DIF(L,3),DZ*QFR(5)/DENOM,DDF(L,3),0.0) + 1 *VOL0/DZ + ELSE IF(KK5.EQ.-2) THEN + A(5)=0.0D0 + ELSE IF(KK5.EQ.-3) THEN + A(5)=2.0D0*DDF(L,3)*VOL0/(DZ*DZ) + ENDIF +* Z+ SIDE: + IF(KK6.GT.0) THEN + A(6)=VHARM(DZ,ZZ(KK6),DIF(L,3),DIF(MAT(KK6),3),DDF(L,3), + 1 DDF(MAT(KK6),3))*VOL0/DZ + ELSE IF(KK6.EQ.-1) THEN + A(6)=VHARM(DZ,DZ,DIF(L,3),DZ*QFR(6)/DENOM,DDF(L,3),0.0) + 1 *VOL0/DZ + ELSE IF(KK6.EQ.-2) THEN + A(6)=0.0D0 + ELSE IF(KK6.EQ.-3) THEN + A(6)=2.0D0*DDF(L,3)*VOL0/(DZ*DZ) + ELSE IF(KK6.EQ.-4) THEN + IF(KK5.EQ.-4) CALL XABORT('TRIDCO: INCONSISTENT SYME (11).') + A(6)=A(5) + ENDIF + IF(KK5.EQ.-4) THEN + IF(KK6.EQ.-4) CALL XABORT('TRIDCO: INCONSISTENT SYME (12).') + A(5)=A(6) + ENDIF + ENDIF + RETURN + END diff --git a/Trivac/src/TRIDFC.f b/Trivac/src/TRIDFC.f new file mode 100755 index 0000000..01fe12a --- /dev/null +++ b/Trivac/src/TRIDFC.f @@ -0,0 +1,327 @@ +*DECK TRIDFC + SUBROUTINE TRIDFC(IMPX,LX,LY,LZ,CYLIND,NCODE,ICODE,ZCODE,MAT,XXX, + 1 YYY,ZZZ,LL4,VOL,XX,YY,ZZ,DD,KN,QFR,IQFR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Numbering corresponding to a mesh centered finite difference (CHEBY +* type) or nodal collocation discretization in a 3-D geometry. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IMPX print parameter. +* LX number of elements along the X axis. +* LY number of elements along the Y axis. +* LZ number of elements along the Z axis. +* CYLIND cylindrical geometry flag (set with CYLIND=.true.). +* NCODE type of boundary condition applied on each side: +* I=1: X-; I=2: X+; I=3: Y-; I=4: Y+; I=5: Z-; I=6: Z+; +* NCODE(I)=1: VOID; NCODE(I)=2: REFL; NCODE(I)=4: TRAN; +* NCODE(I)=5: SYME; NCODE(I)=7: ZERO; NCODE(I)=20: CYLI. +* ICODE physical albedo index on each side of the domain. +* ZCODE albedo corresponding to boundary condition 'VOID' on each +* side (ZCODE(i)=0.0 by default). +* MAT mixture index assigned to each element. +* XXX Cartesian coordinates along the X axis. +* YYY Cartesian coordinates along the Y axis. +* ZZZ Cartesian coordinates along the Z axis. +* +*Parameters: output +* LL4 total number of unknown (variational coefficients) per +* energy group (order of system matrices). +* VOL volume of each element. +* XX X-directed mesh spacings. +* YY Y-directed mesh spacings. +* ZZ Z-directed mesh spacings. +* DD used with cylindrical geometry. +* KN element-ordered unknown list: +* .GT.0; neighbour index; +* =-1; void/albedo boundary condition; +* =-2; reflection boundary condition; +* =-3; ZERO flux boundary condition; +* =-4; SYME boundary condition (axial symmetry). +* QFR element-ordered boundary conditions. +* IQFR element-ordered physical albedo indices. +* +*----------------------------------------------------------------------- +* + INTEGER IMPX,LX,LY,LZ,NCODE(6),ICODE(6),MAT(LX*LY*LZ),LL4, + 1 KN(6*LX*LY*LZ),IQFR(6*LX*LY*LZ) + REAL ZCODE(6),XXX(LX+1),YYY(LY+1),ZZZ(LZ+1),VOL(LX*LY*LZ), + 1 XX(LX*LY*LZ),YY(LX*LY*LZ),ZZ(LX*LY*LZ),DD(LX*LY*LZ), + 2 QFR(6*LX*LY*LZ) + LOGICAL CYLIND +*---- +* LOCAL VARIABLES +*---- + LOGICAL LL1,LALB +* + ALB(X)=0.5*(1.0-X)/(1.0+X) +*---- +* IDENTIFICATION OF THE GEOMETRY. MAIN LOOP OVER THE ELEMENTS +*---- + IF(IMPX.GT.0) WRITE(6,700) LX,LY,LZ + LXY=LX*LY + NUM1=0 + KEL=0 + DO 22 K0=1,LZ + DO 21 K1=1,LY + DO 20 K2=1,LX + KEL=KEL+1 + XX(KEL)=0.0 + YY(KEL)=0.0 + ZZ(KEL)=0.0 + VOL(KEL)=0.0 + IF(MAT(KEL).LE.0) GO TO 20 + XX(KEL)=XXX(K2+1)-XXX(K2) + YY(KEL)=YYY(K1+1)-YYY(K1) + ZZ(KEL)=ZZZ(K0+1)-ZZZ(K0) + IF(CYLIND) DD(KEL)=0.5*(XXX(K2)+XXX(K2+1)) + DO 10 IC=1,6 + QFR(NUM1+IC)=0.0 + IQFR(NUM1+IC)=0 + 10 CONTINUE + FRX=1.0 + FRY=1.0 + FRZ=1.0 + KK1=KEL-1 + KK2=KEL+1 + KK3=KEL-LX + KK4=KEL+LX + KK5=KEL-LXY + KK6=KEL+LXY +*---- +* VOID, REFL, ZERO OR CYLI BOUNDARY CONTITION +*---- + IF(K2.EQ.1) THEN + LL1=.TRUE. + ELSE + LL1=(MAT(KK1).EQ.0) + ENDIF + IF(LL1) THEN + LALB=(NCODE(1).EQ.1).OR.(NCODE(1).EQ.6) + IF(LALB.AND.(ICODE(1).EQ.0)) THEN + KK1=-1 + QFR(NUM1+1)=ALB(ZCODE(1)) + ELSE IF(LALB) THEN + KK1=-1 + QFR(NUM1+1)=1.0 + IQFR(NUM1+1)=ICODE(1) + ELSE IF(NCODE(1).EQ.2) THEN + KK1=-2 + ELSE IF(NCODE(1).EQ.7) THEN + KK1=-3 + ELSE IF(NCODE(1).EQ.20) THEN + KK1=-1 + ENDIF + ENDIF +* + IF(K2.EQ.LX) THEN + LL1=.TRUE. + ELSE + LL1=(MAT(KK2).EQ.0) + ENDIF + IF(LL1) THEN + LALB=(NCODE(2).EQ.1).OR.(NCODE(2).EQ.6) + IF(LALB.AND.(ICODE(2).EQ.0)) THEN + KK2=-1 + QFR(NUM1+2)=ALB(ZCODE(2)) + ELSE IF(LALB) THEN + KK2=-1 + QFR(NUM1+2)=1.0 + IQFR(NUM1+2)=ICODE(2) + ELSE IF(NCODE(2).EQ.2) THEN + KK2=-2 + ELSE IF(NCODE(2).EQ.7) THEN + KK2=-3 + ELSE IF(NCODE(2).EQ.20) THEN + KK2=-1 + ENDIF + ENDIF +* + IF(K1.EQ.1) THEN + LL1=.TRUE. + ELSE + LL1=(MAT(KK3).EQ.0) + ENDIF + IF(LL1) THEN + LALB=(NCODE(3).EQ.1).OR.(NCODE(3).EQ.6) + IF(LALB.AND.(ICODE(3).EQ.0)) THEN + KK3=-1 + QFR(NUM1+3)=ALB(ZCODE(3)) + ELSE IF(LALB) THEN + KK3=-1 + QFR(NUM1+3)=1.0 + IQFR(NUM1+3)=ICODE(3) + ELSE IF(NCODE(3).EQ.2) THEN + KK3=-2 + ELSE IF(NCODE(3).EQ.7) THEN + KK3=-3 + ELSE IF(NCODE(3).EQ.20) THEN + KK3=-1 + ENDIF + ENDIF +* + IF(K1.EQ.LY) THEN + LL1=.TRUE. + ELSE + LL1=(MAT(KK4).EQ.0) + ENDIF + IF(LL1) THEN + LALB=(NCODE(4).EQ.1).OR.(NCODE(4).EQ.6) + IF(LALB.AND.(ICODE(4).EQ.0)) THEN + KK4=-1 + QFR(NUM1+4)=ALB(ZCODE(4)) + ELSE IF(LALB) THEN + KK4=-1 + QFR(NUM1+4)=1.0 + IQFR(NUM1+4)=ICODE(4) + ELSE IF(NCODE(4).EQ.2) THEN + KK4=-2 + ELSE IF(NCODE(4).EQ.7) THEN + KK4=-3 + ELSE IF(NCODE(4).EQ.20) THEN + KK4=-1 + ENDIF + ENDIF +* + IF(K0.EQ.1) THEN + LL1=.TRUE. + ELSE + LL1=(MAT(KK5).EQ.0) + ENDIF + IF(LL1) THEN + LALB=(NCODE(5).EQ.1).OR.(NCODE(5).EQ.6) + IF(LALB.AND.(ICODE(5).EQ.0)) THEN + KK5=-1 + QFR(NUM1+5)=ALB(ZCODE(5)) + ELSE IF(LALB) THEN + KK5=-1 + QFR(NUM1+5)=1.0 + IQFR(NUM1+5)=ICODE(5) + ELSE IF(NCODE(5).EQ.2) THEN + KK5=-2 + ELSE IF(NCODE(5).EQ.7) THEN + KK5=-3 + ELSE IF(NCODE(5).EQ.20) THEN + KK5=-1 + ENDIF + ENDIF +* + IF(K0.EQ.LZ) THEN + LL1=.TRUE. + ELSE + LL1=(MAT(KK6).EQ.0) + ENDIF + IF(LL1) THEN + LALB=(NCODE(6).EQ.1).OR.(NCODE(6).EQ.6) + IF(LALB.AND.(ICODE(6).EQ.0)) THEN + KK6=-1 + QFR(NUM1+6)=ALB(ZCODE(6)) + ELSE IF(LALB) THEN + KK6=-1 + QFR(NUM1+6)=1.0 + IQFR(NUM1+6)=ICODE(6) + ELSE IF(NCODE(6).EQ.2) THEN + KK6=-2 + ELSE IF(NCODE(6).EQ.7) THEN + KK6=-3 + ELSE IF(NCODE(6).EQ.20) THEN + KK6=-1 + ENDIF + ENDIF +*---- +* TRAN BOUNDARY CONDITION +*---- + IF((K2.EQ.1).AND.(NCODE(1).EQ.4)) THEN + KK1=KEL+LX-1 + ENDIF + IF((K2.EQ.LX).AND.(NCODE(2).EQ.4)) THEN + KK2=KEL+1-LX + ENDIF + IF((K1.EQ.1).AND.(NCODE(3).EQ.4)) THEN + KK3=KEL+(LY-1)*LX + ENDIF + IF((K1.EQ.LY).AND.(NCODE(4).EQ.4)) THEN + KK4=KEL-(LY-1)*LX + ENDIF + IF((K0.EQ.1).AND.(NCODE(5).EQ.4)) THEN + KK5=KEL+(LZ-1)*LXY + ENDIF + IF((K0.EQ.LZ).AND.(NCODE(6).EQ.4)) THEN + KK6=KEL-(LZ-1)*LXY + ENDIF +*---- +* SYME BOUNDARY CONDITION +*---- + IF((NCODE(1).EQ.5).AND.(K2.EQ.1)) THEN + KK1=-4 + FRX=0.5 + ELSE IF((NCODE(2).EQ.5).AND.(K2.EQ.LX)) THEN + KK2=-4 + FRX=0.5 + ENDIF + IF((NCODE(3).EQ.5).AND.(K1.EQ.1)) THEN + KK3=-4 + FRY=0.5 + ELSE IF((NCODE(4).EQ.5).AND.(K1.EQ.LY)) THEN + KK4=-4 + FRY=0.5 + ENDIF + IF((NCODE(5).EQ.5).AND.(K0.EQ.1)) THEN + KK5=-4 + FRZ=0.5 + ELSE IF((NCODE(6).EQ.5).AND.(K0.EQ.LZ)) THEN + KK6=-4 + FRZ=0.5 + ENDIF +* + VOL0=XX(KEL)*YY(KEL)*ZZ(KEL)*FRX*FRY*FRZ + IF(CYLIND) VOL0=6.2831853072*DD(KEL)*VOL0 + VOL(KEL)=VOL0 + KN(NUM1+1)=KK1 + KN(NUM1+2)=KK2 + KN(NUM1+3)=KK3 + KN(NUM1+4)=KK4 + KN(NUM1+5)=KK5 + KN(NUM1+6)=KK6 + NUM1=NUM1+6 + 20 CONTINUE + 21 CONTINUE + 22 CONTINUE +* END OF THE MAIN LOOP OVER ELEMENTS. +* + LL4=0 + DO 40 KEL=1,LXY*LZ + IF(MAT(KEL).NE.0) LL4=LL4+1 + 40 CONTINUE +* + IF(IMPX.GE.2) THEN + WRITE(6,720) (VOL(I),I=1,LXY*LZ) + WRITE(6,750) + NUM1=0 + DO 50 KEL=1,LXY*LZ + IF(MAT(KEL).LE.0) GO TO 50 + WRITE (6,760) KEL,(KN(NUM1+I),I=1,6),(QFR(NUM1+I),I=1,6) + NUM1=NUM1+6 + 50 CONTINUE + ENDIF + RETURN +* + 700 FORMAT(/53H TRIDFC: MESH CENTERED FINITE DIFFERENCE OR NODAL COL, + 1 16HLOCATION METHOD.//34H NUMBER OF ELEMENTS ALONG X AXIS =,I3/ + 2 20X,14HALONG Y AXIS =,I3/20X,14HALONG Z AXIS =,I3) + 720 FORMAT(/20H VOLUMES PER ELEMENT/(1X,1P,10E13.4)) + 750 FORMAT(/22H NUMBERING OF UNKNOWNS/1X,21(1H-)// + 1 8H ELEMENT,5X,7HNUMBERS,50X,23HVOID BOUNDARY CONDITION) + 760 FORMAT(1X,I6,7X,6I8,6X,6F9.2) + END diff --git a/Trivac/src/TRIDFH.f b/Trivac/src/TRIDFH.f new file mode 100755 index 0000000..fd71a19 --- /dev/null +++ b/Trivac/src/TRIDFH.f @@ -0,0 +1,330 @@ +*DECK TRIDFH + SUBROUTINE TRIDFH (ISPLH,IPTRK,IDIM,LX,LZ,LL4,NUN,SIDE,ZZZ,ZZ, + 1 KN,QFR,IQFR,VOL,MAT,IDL,NCODE,ICODE,ZCODE,IMPX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Numbering corresponding to a mesh centered finite difference +* discretization of a 3-D hexagonal geometry. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Benaboud +* +*Parameters: input +* IMPX print parameter. +* ISPLH type of mesh-splitting: =1 for complete hexagons; =2 for +* triangular mesh-splitting. +* IPTRK L_TRACK pointer to the tracking information. +* IDIM number of dimensions (2 or 3). +* LX number of hexagons. +* LZ number of axial planes. +* SIDE side of an hexagon. +* ZZZ Z-coordinates of the axial planes. +* NCODE type of boundary condition applied on each side (I=1: hbc): +* NCODE(I)=1: VOID; =2: REFL; =6: ALBE; +* =5: SYME; =7: ZERO. +* ICODE physical albedo index on each side of the domain. +* ZCODE albedo corresponding to boundary condition 'VOID' on each +* side (ZCODE(I)=0.0 by default). +* MAT mixture index assigned to each element. +* +*Parameters: output +* LL4 order of the system matrices. +* NUN number of unknowns per energy group. +* VOL volume of each element. +* KN element-ordered unknown list. +* QFR element-ordered boundary conditions. +* IQFR element-ordered physical albedo indices. +* IDL position of the average flux component associated with each +* volume. +* ZZ Z-sides of each hexagon. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK + INTEGER ISPLH,IDIM,LX,LZ,LL4,NUN,KN(8*LX*LZ),IQFR(8*LX*LZ), + 1 MAT(LX*LZ),IDL(LX*LZ),NCODE(6),ICODE(6),IMPX + REAL SIDE,ZZZ(LZ+1),ZZ(LX*LZ),QFR(8*LX*LZ),VOL(LX*LZ),ZCODE(6) +*---- +* LOCAL VARIABLES +*---- + LOGICAL LL1,LL2 + INTEGER, DIMENSION(:), ALLOCATABLE :: I1,KN1,KN2,KN3,KN4 + ALB(X)=0.5*(1.0-X)/(1.0+X) +*---- +* MAIN LOOP OVER THE FINITE ELEMENTS +*---- + ALLOCATE(I1(LX*LZ),KN4(8*LX*LZ)) + MEL=0 + DO 10 KXZ=1,LX*LZ + I1(KXZ) = 0 + IF(MAT(KXZ).LE.0) GO TO 10 + MEL=MEL+1 + I1(KXZ) = MEL + 10 CONTINUE + IDEB = 0 + IFIN = 0 + IVAL=0 + NUM1=0 + MEL = MEL/LZ + KEL =0 + DO 45 KZ=1,LZ + LL1 = .FALSE. + LL2 = .FALSE. + DO 40 KX=1,LX + KEL = KEL + 1 + ZZ(KEL) = 0.0 + IF(MAT(KEL).LE.0) GO TO 40 + ZZ(KEL) = ZZZ(KZ+1)-ZZZ(KZ) + DO 20 IC=1,8 + QFR(NUM1+IC) = 0.0 + IQFR(NUM1+IC) = 0 + 20 CONTINUE + DO 30 IX=1,6 + KN4(NUM1+IX) = 0 + N1 = NEIGHB (KX,IX,9,LX,POIDS) + IF(N1.GT.0) N1 = N1+(KZ-1)*LX + IF(N1.GT.(LX+(KZ-1)*LX)) THEN + IF((NCODE(1).EQ.1).AND.(ICODE(1).EQ.0)) THEN + N1 = -1 + QFR(NUM1+IX)=ALB(ZCODE(1)) + ELSE IF(NCODE(1).EQ.1) THEN + N1 = -1 + QFR(NUM1+IX)=1.0 + IQFR(NUM1+IX)=ICODE(1) + ELSE IF(NCODE(1).EQ.2) THEN + N1 = -2 + ELSE IF(NCODE(1).EQ.7) THEN + N1 = -3 + ENDIF + ELSE IF(MAT(N1).LE.0) THEN + IF((NCODE(1).EQ.1).AND.(ICODE(1).EQ.0)) THEN + N1 = -1 + QFR(NUM1+IX)=ALB(ZCODE(1)) + ELSE IF(NCODE(1).EQ.1) THEN + N1 = -1 + QFR(NUM1+IX)=1.0 + IQFR(NUM1+IX)=ICODE(1) + ELSE IF(NCODE(1).EQ.2) THEN + N1 = -2 + ELSE IF(NCODE(1).EQ.7) THEN + N1 = -3 + ENDIF + ENDIF + IF(N1.GT.0) N1 = I1(N1) + KN4(NUM1+IX) = N1 +30 CONTINUE + KK7 = I1(KEL) - MEL + KK8 = I1(KEL) + MEL +* +* VOID, REFL OR ZERO BOUNDARY CONDITIONS. + IF(KZ.EQ.1) THEN + LL1 = .TRUE. + ENDIF + IF(LL1) THEN + IF((NCODE(5).EQ.1).AND.(ICODE(5).EQ.0)) THEN + KK7=-1 + QFR(NUM1+7)=ALB(ZCODE(5)) + ELSE IF(NCODE(5).EQ.1) THEN + KK7=-1 + QFR(NUM1+7)=1.0 + IQFR(NUM1+7)=ICODE(5) + ELSE IF(NCODE(5).EQ.2) THEN + KK7=-2 + ELSE IF(NCODE(5).EQ.7) THEN + KK7=-3 + ENDIF + ENDIF +* + IF(KZ.EQ.LZ) THEN + LL2 = .TRUE. + ENDIF + IF(LL2) THEN + IF((NCODE(6).EQ.1).AND.(ICODE(6).EQ.0)) THEN + KK8=-1 + QFR(NUM1+8)=ALB(ZCODE(6)) + ELSE IF(NCODE(6).EQ.1) THEN + KK8=-1 + QFR(NUM1+8)=1.0 + IQFR(NUM1+8)=ICODE(6) + ELSE IF(NCODE(6).EQ.2) THEN + KK8=-2 + ELSE IF(NCODE(6).EQ.7) THEN + KK8=-3 + ENDIF + ENDIF +* +* TRAN BOUNDARY CONDITION. + IF((KZ.EQ.1).AND.(NCODE(5).EQ.4)) THEN + KK7=-2 + ELSE IF((KZ.EQ.LZ).AND.(NCODE(6).EQ.4)) THEN + KK8=-2 + ENDIF +* +* SYME BOUNDARY CONDITION. + IF((KZ.EQ.1).AND.(NCODE(5).EQ.5)) THEN + KK7=-2 + ZZ(KEL)=0.5*ZZ(KEL) + ELSE IF((KZ.EQ.LZ).AND.(NCODE(6).EQ.5)) THEN + KK8=-2 + ZZ(KEL)=0.5*ZZ(KEL) + ENDIF +* + IF(KZ.EQ.1) IDEB = KK7 + IF(KZ.EQ.LZ) IFIN = KK8 + KN4(NUM1+7) = KK7 + KN4(NUM1+8) = KK8 + NUM1=NUM1+8 +40 CONTINUE +45 CONTINUE +* END OF THE MAIN LOOP OVER FINITE ELEMENTS. +* +*---- +* VOLUME CALCULATION +*---- + DO 55 KZ=1,LZ + DO 50 KX=1,LX + KEL = KX+(KZ-1)*LX + IF(MAT(KEL).EQ.0) THEN + VOL0 = 0.0 + ELSE + VOL0 = 2.59807621*SIDE*SIDE*ZZ(KEL) + ENDIF + VOL(KEL) = VOL0 + 50 CONTINUE + 55 CONTINUE + IF(IMPX.NE.0) THEN + WRITE(6,222) 'ZZ ',(ZZ(I),I=1,LX*LZ) + WRITE(6,222) 'VOL',(VOL(I),I=1,LX*LZ) + ENDIF + LL4=0 + DO 60 KXZ=1,LX*LZ + IF(MAT(KXZ).GT.0) LL4=LL4+1 + 60 CONTINUE +* + IF(ISPLH.EQ.1) THEN + IVAL = 8 + DO 70 I=1,8*LL4 + KN(I) = 0 + KN(I) = KN4(I) + 70 CONTINUE + DEALLOCATE(KN4) + ELSE IF(ISPLH.GE.2) THEN + IVAL =18*(ISPLH-1)**2+8 + CALL TRINTR(ISPLH,IPTRK,LX,LL4,9,MAT) + ALLOCATE(KN1(LL4),KN2(LL4),KN3(LL4)) + CALL LCMGET (IPTRK,'IKN',KN1) + NUM1 = 0 + NUM3 = 0 + DO 80 I=1,LZ*LX*IVAL + KN(I) = 0 + 80 CONTINUE + DO 90 I=1,LL4 + KN2(I) = IDEB + KN3(I) = IFIN + 90 CONTINUE + DO 115 K=1,LZ + NUM2 = 0 + DO 110 I=1,LX + IF(MAT(I+(K-1)*LX).LE.0) GO TO 110 + DO 100 J=1,6*(ISPLH-1)**2 + IVAL1 = KN1(NUM2+J) + (K-1)*LL4 + IVAL2 = KN2(NUM2+J) + IVAL3 = KN3(NUM2+J) + IF(IDIM.EQ.3.AND.K.GT.1) IVAL2 = IVAL1 - LL4 + IF(IDIM.EQ.3.AND.K.LT.LZ) IVAL3 = IVAL1 + LL4 + KN(NUM1+J ) = IVAL1 + KN(NUM1+J+ 6*(ISPLH-1)**2) = IVAL2 + KN(NUM1+J+12*(ISPLH-1)**2) = IVAL3 + 100 CONTINUE + DO 105 KX=1,6 + KN(NUM1+KX+18*(ISPLH-1)**2) = KN4(NUM3+KX) + 105 CONTINUE + KN(NUM1+IVAL-1) = KN4(NUM3+7) + KN(NUM1+IVAL ) = KN4(NUM3+8) + NUM1 = NUM1 + IVAL + NUM2 = NUM2 + 6*(ISPLH-1)**2 + NUM3 = NUM3 + 8 + 110 CONTINUE + 115 CONTINUE + LL4 = LZ * LL4 + DEALLOCATE(KN3,KN2,KN1,KN4) + ENDIF + IF(IMPX.GE.1) THEN + NUM1=0 + NUM2=0 + IF(ISPLH.EQ.1) THEN + WRITE (6,570) + DO 130 KZ=1,LZ + WRITE(6,'(/13H PLANE NUMBER,I6)') KZ + WRITE (6,520) + DO 120 KX=1,LX + KEL = KX+(KZ-1)*LX + IF(MAT(KEL).LE.0) GO TO 120 + WRITE (6,530) I1(KEL),(KN(NUM1+I),I=1,IVAL), + > (QFR(NUM2+I),I=1,8),VOL(KEL) + NUM1 = NUM1 + IVAL + NUM2 = NUM2 + 8 +120 CONTINUE +130 CONTINUE + ELSE + WRITE (6,570) + DO 160 KZ=1,LZ + WRITE(6,'(/13H PLANE NUMBER,I6)') KZ + WRITE (6,575) + DO 140 KX=1,LX + KEL = KX+(KZ-1)*LX + IF(MAT(KEL).LE.0) GO TO 140 + WRITE (6,580) I1(KEL),(KN(NUM1+I),I=1,IVAL-8) + NUM1 = NUM1 + IVAL +140 CONTINUE + WRITE (6,585) + DO 150 KX=1,LX + KEL = KX+(KZ-1)*LX + IF(MAT(KEL).LE.0) GO TO 150 + WRITE (6,590) I1(KEL),(QFR(NUM2+I),I=1,8), + * VOL(KEL) + NUM2 = NUM2 + 8 +150 CONTINUE +160 CONTINUE + ENDIF + WRITE (6,560) LL4 + ENDIF + DEALLOCATE(I1) +*---- +* APPEND THE AVERAGED FLUXES AT THE END OF UNKNOWN VECTOR +*---- + NUN=0 + IF(ISPLH.GT.1) NUN=LL4 + DO 190 I=1,LX*LZ + IF(MAT(I).EQ.0) THEN + IDL(I)=0 + ELSE + NUN=NUN+1 + IDL(I)=NUN + ENDIF +190 CONTINUE + RETURN +* +222 FORMAT(1X,A3,/,7(2X,E12.5)) +520 FORMAT (/8H ELEMENT,6X,10HNEIGHBOURS,37X,20HVOID BOUNDARY CONDIT, + 1 3HION,28X,6HVOLUME) +530 FORMAT (1X,I6,2X,8I6,2X,8F6.2,5X,E13.6) +560 FORMAT (/40H NUMBER OF NON VIRTUAL FINITE ELEMENTS =,I6/) +570 FORMAT (/22H NUMBERING OF UNKNOWNS/1X,21(1H-)) +575 FORMAT (/8H ELEMENT,44X,10HNEIGHBOURS) +580 FORMAT (1X,I6,2X,20I6/(9X,20I6)) +585 FORMAT (/8H ELEMENT,3X,23HVOID BOUNDARY CONDITION,28X,6HVOLUME) +590 FORMAT (1X,I6,2X,8F6.2,5X,E13.6) + END diff --git a/Trivac/src/TRIDIG.f b/Trivac/src/TRIDIG.f new file mode 100755 index 0000000..479353e --- /dev/null +++ b/Trivac/src/TRIDIG.f @@ -0,0 +1,171 @@ +*DECK TRIDIG + SUBROUTINE TRIDIG(HNAME,IPTRK,IPSYS,IMPX,MAXMIX,NEL,IPR,MAT,VOL, + 1 SGD) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Driver for the assembly of a cross section diagonal matrix. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* HNAME name of the diagonal matrix. +* IPTRK L_TRACK pointer to the TRIVAC tracking information. +* IPSYS L_SYSTEM pointer to system matrices. +* IMPX print parameter. Equal to zero for no print. +* MAXMIX dimension of matrix SGD. +* NEL total number of finite elements. +* IPR type of assembly: +* =3: the new contribution is added to existing matrix. +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* SGD cross section per material mixture. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER HNAME*(*) + TYPE(C_PTR) IPTRK,IPSYS + INTEGER IMPX,MAXMIX,NEL,IPR,MAT(NEL) + REAL VOL(NEL),SGD(MAXMIX) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + CHARACTER TEXT12*12 + LOGICAL CYLIND,CHEX + INTEGER ISTATE(NSTATE) + INTEGER, DIMENSION(:), ALLOCATABLE :: KN,IPERT,IPW + REAL, DIMENSION(:), ALLOCATABLE :: T,TS,FRZ + REAL, DIMENSION(:,:), ALLOCATABLE :: R,RH,RT + REAL, DIMENSION(:), ALLOCATABLE :: XORZ,DD + REAL, DIMENSION(:), POINTER :: VEC + TYPE(C_PTR) VEC_PTR +*---- +* RECOVER TRIVAC SPECIFIC TRACKING INFORMATION +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + ITYPE=ISTATE(6) + CYLIND=(ITYPE.EQ.3).OR.(ITYPE.EQ.6) + CHEX=(ITYPE.EQ.8).OR.(ITYPE.EQ.9) + IELEM=ABS(ISTATE(9)) + LL4=ISTATE(11) + ICHX=ISTATE(12) + ISPLH=ISTATE(13) + LX=ISTATE(14) + LY=ISTATE(15) + LZ=ISTATE(16) + LL4F=ISTATE(25) + CALL LCMLEN(IPTRK,'KN',MAXKN,ITYLCM) + ALLOCATE(KN(MAXKN),XORZ(LX*LY*LZ)) + CALL LCMGET(IPTRK,'KN',KN) + IF(CHEX) THEN + CALL LCMGET(IPTRK,'ZZ',XORZ) + CALL LCMGET(IPTRK,'SIDE',SIDE) + ELSE + CALL LCMGET(IPTRK,'XX',XORZ) + ALLOCATE(DD(LX*LY*LZ)) + CALL LCMGET(IPTRK,'DD',DD) + ENDIF + TEXT12=HNAME + IF(IMPX.GT.0) WRITE(6,'(/37H TRIDIG: ASSEMBLY OF DIAGONAL MATRIX , + 1 1H'',A12,2H''.)') TEXT12 +*---- +* INITIALIZATION OF A DIAGONAL SYSTEM MATRIX +*---- + IF(ICHX.EQ.2) THEN + IF(IPR.EQ.3) THEN + CALL LCMGPD(IPSYS,TEXT12,VEC_PTR) + CALL C_F_POINTER(VEC_PTR,VEC,(/ LL4F /)) + ELSE + VEC_PTR=LCMARA(LL4F) + CALL C_F_POINTER(VEC_PTR,VEC,(/ LL4F /)) + VEC(:LL4F)=0.0 + ENDIF + ELSE + IF(IPR.EQ.3) THEN + CALL LCMGPD(IPSYS,TEXT12,VEC_PTR) + CALL C_F_POINTER(VEC_PTR,VEC,(/ LL4 /)) + ELSE + VEC_PTR=LCMARA(LL4) + CALL C_F_POINTER(VEC_PTR,VEC,(/ LL4 /)) + VEC(:LL4)=0.0 + ENDIF + ENDIF +*---- +* COMPUTE THE DIAGONAL SYSTEM MATRIX +*---- + IF((ICHX.EQ.1).AND.(.NOT.CHEX)) THEN +* VARIATIONAL COLLOCATION METHOD. + CALL LCMSIX(IPTRK,'BIVCOL',1) + CALL LCMLEN(IPTRK,'T',LC,ITYLCM) + ALLOCATE(T(LC),TS(LC)) + CALL LCMGET(IPTRK,'T',T) + CALL LCMGET(IPTRK,'TS',TS) + CALL LCMSIX(IPTRK,' ',2) + CALL TRIASP(IELEM,MAXMIX,NEL,LL4,CYLIND,SGD,XORZ,DD,VOL,MAT, + 1 KN,LC,T,TS,VEC) + DEALLOCATE(T,TS) + ELSE IF((ICHX.EQ.1).AND.CHEX) THEN +* MESH CORNER FINITE DIFFERENCES IN HEXAGONAL GEOMETRY. + CALL LCMSIX(IPTRK,'BIVCOL',1) + ALLOCATE(R(2,2),RH(6,6),RT(3,3)) + CALL LCMGET(IPTRK,'R',R) + CALL LCMGET(IPTRK,'RH',RH) + CALL LCMGET(IPTRK,'RT',RT) + CALL LCMSIX(IPTRK,' ',2) + CALL TRIAHP(MAXKN,ISPLH,MAXMIX,NEL,LL4,SGD,SIDE,XORZ,VOL,MAT, + 1 KN,R,RH,RT,VEC) + DEALLOCATE(RT,RH,R) + ELSE IF((ICHX.EQ.2).AND.CHEX) THEN +* DUAL (THOMAS-RAVIART-SCHNEIDER) FINITE ELEMENT METHOD. + NBLOS=LX*LZ/3 + ALLOCATE(IPERT(NBLOS),FRZ(NBLOS)) + CALL LCMGET(IPTRK,'IPERT',IPERT) + CALL LCMGET(IPTRK,'FRZ',FRZ) + CALL TRIASH(IELEM,MAXMIX,LL4,NBLOS,MAT,SIDE,XORZ,FRZ,SGD,KN, + 1 IPERT,VEC) + DEALLOCATE(FRZ,IPERT) + ELSE IF(.NOT.CHEX) THEN +* DUAL FINITE ELEMENT METHOD. + IDIM=1 + IF((ITYPE.EQ.5).OR.(ITYPE.EQ.6).OR.(ITYPE.EQ.8)) IDIM=2 + IF((ITYPE.EQ.7).OR.(ITYPE.EQ.9)) IDIM=3 + CALL TRIASD(MAXKN,IELEM,ICHX,IDIM,MAXMIX,NEL,LL4,SGD,VOL,MAT, + 1 KN,VEC) + ELSE IF(CHEX.AND.(ISPLH.EQ.1)) THEN +* MESH CENTERED FINITE DIFFERENCES IN HEXAGONAL GEOMETRY. + CALL TRIAHD(MAXMIX,NEL,LL4,SGD,VOL,MAT,VEC) + ELSE IF(CHEX.AND.(ISPLH.GT.1)) THEN +* MESH CENTERED FINITE DIFFERENCES IN TRIANGULAR GEOMETRY. + ALLOCATE(IPW(LL4)) + CALL LCMGET(IPTRK,'IPW',IPW) + CALL TRIMTD(ISPLH,MAXMIX,NEL,LL4,VOL,MAT,SGD,KN,IPW,VEC) + DEALLOCATE(IPW) + ENDIF +*---- +* STORAGE OF THE DIAGONAL SYSTEM MATRIX +*---- + IF(ICHX.EQ.2) THEN + CALL LCMPPD(IPSYS,TEXT12,LL4F,2,VEC_PTR) + ELSE + CALL LCMPPD(IPSYS,TEXT12,LL4,2,VEC_PTR) + ENDIF +*---- +* RELEASE TRIVAC SPECIFIC TRACKING INFORMATION +*---- + IF(.NOT.CHEX) DEALLOCATE(DD) + DEALLOCATE(XORZ,KN) + RETURN + END diff --git a/Trivac/src/TRIDKN.f b/Trivac/src/TRIDKN.f new file mode 100755 index 0000000..d16a00b --- /dev/null +++ b/Trivac/src/TRIDKN.f @@ -0,0 +1,418 @@ +*DECK TRIDKN + SUBROUTINE TRIDKN(IMPX,LX,LY,LZ,CYLIND,IELEM,L4,LL4F,LL4X,LL4Y, + 1 LL4Z,NCODE,ICODE,ZCODE,MAT,VOL,XXX,YYY,ZZZ,XX,YY,ZZ,DD,KN,QFR, + 2 IQFR,IDL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Numbering corresponding to a Thomas-Raviart (dual) formulation of the +* finite element discretization in a 3-D Cartesian geometry. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IMPX print parameter. +* LX number of elements along the X axis. +* LY number of elements along the Y axis. +* LZ number of elements along the Z axis. +* CYLIND cylindrical geometry flag (set with CYLIND=.true.). +* IELEM degree of the Lagrangian finite elements: =1 (linear); +* =2 (parabolic); =3 (cubic); =4 (quartic). +* NCODE type of boundary condition applied on each side: +* I=1: X-; I=2: X+; I=3: Y-; I=4: Y+; I=5: Z-; I=6: Z+; +* NCODE(I)=1: VOID; NCODE(I)=2: REFL; NCODE(I)=4: TRAN; +* NCODE(I)=5: SYME; NCODE(I)=7: ZERO; NCODE(I)=20: CYLI. +* ICODE physical albedo index on each side of the domain. +* ZCODE albedo corresponding to boundary condition 'VOID' on each +* side (ZCODE(i)=0.0 by default). +* MAT mixture index assigned to each element. +* XXX Cartesian coordinates along the X axis. +* YYY Cartesian coordinates along the Y axis. +* ZZZ Cartesian coordinates along the Z axis. +* +*Parameters: output +* L4 total number of unknown (variational coefficients) per +* energy group (order of system matrices). +* LL4F number of flux unknowns. +* LL4X number of X-directed currents +* LL4Y number of Y-directed currents +* LL4Z number of Z-directed currents +* VOL volume of each element. +* XX X-directed mesh spacings. +* YY Y-directed mesh spacings. +* ZZ Z-directed mesh spacings. +* DD used with cylindrical geometry. +* KN element-ordered unknown list. +* QFR element-ordered boundary conditions. +* IQFR element-ordered physical albedo indices. +* IDL position of integrated fluxes into unknown vector. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IMPX,LX,LY,LZ,IELEM,L4,LL4F,LL4X,LL4Y,LL4Z,NCODE(6), + 1 ICODE(6),MAT(LX*LY*LZ),KN(LX*LY*LZ*(1+6*IELEM**2)), + 2 IQFR(6*LX*LY*LZ),IDL(LX*LY*LZ) + REAL ZCODE(6),VOL(LX*LY*LZ),XXX(LX+1),YYY(LY+1),ZZZ(LZ+1), + 1 XX(LX*LY*LZ),YY(LX*LY*LZ),ZZ(LX*LY*LZ),DD(LX*LY*LZ), + 2 QFR(6*LX*LY*LZ) + LOGICAL CYLIND +*---- +* LOCAL VARIABLES +*---- + LOGICAL COND,LL1 + REAL ZALB(6) + INTEGER, DIMENSION(:), ALLOCATABLE :: IP +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IP((LX+1)*LY*LZ*IELEM*IELEM + LX*(LY+1)*LZ*IELEM*IELEM + 1 + LX*LY*(LZ+1)*IELEM*IELEM + LX*LY*LZ*IELEM*IELEM*IELEM)) +*---- +* IDENTIFICATION OF THE GEOMETRY. MAIN LOOP OVER THE ELEMENTS +*---- + DO 10 I=1,6 + IF(ZCODE(I).NE.1.0) THEN + ZALB(I)=2.0*(1.0+ZCODE(I))/(1.0-ZCODE(I)) + ELSE + ZALB(I)=1.0E20 + ENDIF + 10 CONTINUE + IF(IMPX.GT.0) WRITE(6,700) LX,LY,LZ + L2=LX*LY*LZ + KN(:L2*(1+6*IELEM**2))=0 + LL4F0=LX*LY*LZ*IELEM**3 + LL4X0=(LX+1)*LY*LZ*IELEM**2 + LL4Y0=LX*(LY+1)*LZ*IELEM**2 + LL4Z0=LX*LY*(LZ+1)*IELEM**2 + NUM1=0 + NUM2=0 + KEL=0 + DO 182 K0=1,LZ + DO 181 K1=1,LY + DO 180 K2=1,LX + KEL=KEL+1 + XX(KEL)=0.0 + YY(KEL)=0.0 + ZZ(KEL)=0.0 + VOL(KEL)=0.0 + IF(MAT(KEL).EQ.0) GO TO 180 + XX(KEL)=XXX(K2+1)-XXX(K2) + YY(KEL)=YYY(K1+1)-YYY(K1) + ZZ(KEL)=ZZZ(K0+1)-ZZZ(K0) + IF(CYLIND) DD(KEL)=0.5*(XXX(K2)+XXX(K2+1)) + KN(NUM1+1)=((K0-1)*LX*LY+(K1-1)*LX+K2-1)*IELEM**3 + 1 + DO 20 IEL=1,IELEM**2 + KN(NUM1+1+IEL)=LL4F0+((K0-1)*LY+K1-1)*(LX+1)*IELEM**2+(LX+1)* + 1 (IEL-1)+K2 + KN(NUM1+1+IELEM**2+IEL)=KN(NUM1+1+IEL)+1 + KN(NUM1+1+2*IELEM**2+IEL)=LL4F0+LL4X0+((K0-1)*LX+K2-1)*(LY+1)* + 1 IELEM**2+(LY+1)*(IEL-1)+K1 + KN(NUM1+1+3*IELEM**2+IEL)=KN(NUM1+1+2*IELEM**2+IEL)+1 + KN(NUM1+1+4*IELEM**2+IEL)=LL4F0+LL4X0+LL4Y0+((K1-1)*LX+K2-1)* + 1 (LZ+1)*IELEM**2+(LZ+1)*(IEL-1)+K0 + KN(NUM1+1+5*IELEM**2+IEL)=KN(NUM1+1+4*IELEM**2+IEL)+1 + 20 CONTINUE + QFR(NUM2+1:NUM2+6)=0.0 + IQFR(NUM2+1:NUM2+6)=0 + FRX=1.0 + FRY=1.0 + FRZ=1.0 +*---- +* VOID, REFL OR ZERO BOUNDARY CONTITION +*---- + IF(K2.EQ.1) THEN + LL1=.TRUE. + ELSE + LL1=(MAT(KEL-1).EQ.0) + ENDIF + IF(LL1) THEN + COND=(NCODE(1).EQ.2).OR.((NCODE(1).EQ.1).AND.(ZCODE(1).EQ.1.0)) + IF(COND) THEN + DO 30 IEL=1,IELEM**2 + KN(NUM1+1+IEL)=0 + 30 CONTINUE + ELSE IF((NCODE(1).EQ.1).AND.(ICODE(1).EQ.0)) THEN + QFR(NUM2+1)=ZALB(1) + ELSE IF(NCODE(1).EQ.1) THEN + QFR(NUM2+1)=1.0 + IQFR(NUM2+1)=ICODE(1) + ENDIF + ENDIF +* + IF(K2.EQ.LX) THEN + LL1=.TRUE. + ELSE + LL1=(MAT(KEL+1).EQ.0) + ENDIF + IF(LL1) THEN + COND=(NCODE(2).EQ.2).OR.((NCODE(2).EQ.1).AND.(ZCODE(2).EQ.1.0)) + IF(COND) THEN + DO 40 IEL=1,IELEM**2 + KN(NUM1+1+IELEM**2+IEL)=0 + 40 CONTINUE + ELSE IF((NCODE(2).EQ.1).AND.(ICODE(2).EQ.0)) THEN + QFR(NUM2+2)=ZALB(2) + ELSE IF(NCODE(2).EQ.1) THEN + QFR(NUM2+2)=1.0 + IQFR(NUM2+2)=ICODE(2) + ENDIF + ENDIF +* + IF(K1.EQ.1) THEN + LL1=.TRUE. + ELSE + LL1=(MAT(KEL-LX).EQ.0) + ENDIF + IF(LL1) THEN + COND=(NCODE(3).EQ.2).OR.((NCODE(3).EQ.1).AND.(ZCODE(3).EQ.1.0)) + IF(COND) THEN + DO 50 IEL=1,IELEM**2 + KN(NUM1+1+2*IELEM**2+IEL)=0 + 50 CONTINUE + ELSE IF((NCODE(3).EQ.1).AND.(ICODE(3).EQ.0)) THEN + QFR(NUM2+3)=ZALB(3) + ELSE IF(NCODE(3).EQ.1) THEN + QFR(NUM2+3)=1.0 + IQFR(NUM2+3)=ICODE(3) + ENDIF + ENDIF +* + IF(K1.EQ.LY) THEN + LL1=.TRUE. + ELSE + LL1=(MAT(KEL+LX).EQ.0) + ENDIF + IF(LL1) THEN + COND=(NCODE(4).EQ.2).OR.((NCODE(4).EQ.1).AND.(ZCODE(4).EQ.1.0)) + IF(COND) THEN + DO 60 IEL=1,IELEM**2 + KN(NUM1+1+3*IELEM**2+IEL)=0 + 60 CONTINUE + ELSE IF((NCODE(4).EQ.1).AND.(ICODE(4).EQ.0)) THEN + QFR(NUM2+4)=ZALB(4) + ELSE IF(NCODE(4).EQ.1) THEN + QFR(NUM2+4)=1.0 + IQFR(NUM2+4)=ICODE(4) + ENDIF + ENDIF +* + IF(K0.EQ.1) THEN + LL1=.TRUE. + ELSE + LL1=(MAT(KEL-LX*LY).EQ.0) + ENDIF + IF(LL1) THEN + COND=(NCODE(5).EQ.2).OR.((NCODE(5).EQ.1).AND.(ZCODE(5).EQ.1.0)) + IF(COND) THEN + DO 70 IEL=1,IELEM**2 + KN(NUM1+1+4*IELEM**2+IEL)=0 + 70 CONTINUE + ELSE IF((NCODE(5).EQ.1).AND.(ICODE(5).EQ.0)) THEN + QFR(NUM2+5)=ZALB(5) + ELSE IF(NCODE(5).EQ.1) THEN + QFR(NUM2+5)=1.0 + IQFR(NUM2+5)=ICODE(5) + ENDIF + ENDIF +* + IF(K0.EQ.LZ) THEN + LL1=.TRUE. + ELSE + LL1=(MAT(KEL+LX*LY).EQ.0) + ENDIF + IF(LL1) THEN + COND=(NCODE(6).EQ.2).OR.((NCODE(6).EQ.1).AND.(ZCODE(6).EQ.1.0)) + IF(COND) THEN + DO 80 IEL=1,IELEM**2 + KN(NUM1+1+5*IELEM**2+IEL)=0 + 80 CONTINUE + ELSE IF((NCODE(6).EQ.1).AND.(ICODE(6).EQ.0)) THEN + QFR(NUM2+6)=ZALB(6) + ELSE IF(NCODE(6).EQ.1) THEN + QFR(NUM2+6)=1.0 + IQFR(NUM2+6)=ICODE(6) + ENDIF + ENDIF +*---- +* TRAN BOUNDARY CONDITION +*---- + IF((K2.EQ.LX).AND.(NCODE(2).EQ.4)) THEN + DO 90 IEL=1,IELEM**2 + KN(NUM1+1+IELEM**2+IEL)=KN(NUM1+1+IELEM**2+IEL)-LX + 90 CONTINUE + ENDIF + IF((K1.EQ.LY).AND.(NCODE(4).EQ.4)) THEN + DO 100 IEL=1,IELEM**2 + KN(NUM1+1+3*IELEM**2+IEL)=KN(NUM1+1+3*IELEM**2+IEL)-LY + 100 CONTINUE + ENDIF + IF((K0.EQ.LZ).AND.(NCODE(6).EQ.4)) THEN + DO 110 IEL=1,IELEM**2 + KN(NUM1+1+5*IELEM**2+IEL)=KN(NUM1+1+5*IELEM**2+IEL)-LZ + 110 CONTINUE + ENDIF +*---- +* SYME BOUNDARY CONDITION +*---- + IF((NCODE(1).EQ.5).AND.(K2.EQ.1)) THEN + QFR(NUM2+1)=QFR(NUM2+2) + IQFR(NUM2+1)=IQFR(NUM2+2) + FRX=0.5 + DO 120 IEL=1,IELEM**2 + KN(NUM1+1+IEL)=-KN(NUM1+1+IELEM**2+IEL) + 120 CONTINUE + ELSE IF((NCODE(2).EQ.5).AND.(K2.EQ.LX)) THEN + QFR(NUM2+2)=QFR(NUM2+1) + IQFR(NUM2+2)=IQFR(NUM2+1) + FRX=0.5 + DO 130 IEL=1,IELEM**2 + KN(NUM1+1+IELEM**2+IEL)=-KN(NUM1+1+IEL) + 130 CONTINUE + ENDIF + IF((NCODE(3).EQ.5).AND.(K1.EQ.1)) THEN + QFR(NUM2+3)=QFR(NUM2+4) + IQFR(NUM2+3)=IQFR(NUM2+4) + FRY=0.5 + DO 140 IEL=1,IELEM**2 + KN(NUM1+1+2*IELEM**2+IEL)=-KN(NUM1+1+3*IELEM**2+IEL) + 140 CONTINUE + ELSE IF((NCODE(4).EQ.5).AND.(K1.EQ.LY)) THEN + QFR(NUM2+4)=QFR(NUM2+3) + IQFR(NUM2+4)=IQFR(NUM2+3) + FRY=0.5 + DO 150 IEL=1,IELEM**2 + KN(NUM1+1+3*IELEM**2+IEL)=-KN(NUM1+1+2*IELEM**2+IEL) + 150 CONTINUE + ENDIF + IF((NCODE(5).EQ.5).AND.(K0.EQ.1)) THEN + QFR(NUM2+5)=QFR(NUM2+6) + IQFR(NUM2+5)=IQFR(NUM2+6) + FRZ=0.5 + DO 160 IEL=1,IELEM**2 + KN(NUM1+1+4*IELEM**2+IEL)=-KN(NUM1+1+5*IELEM**2+IEL) + 160 CONTINUE + ELSE IF((NCODE(6).EQ.5).AND.(K0.EQ.LZ)) THEN + QFR(NUM2+6)=QFR(NUM2+5) + IQFR(NUM2+6)=IQFR(NUM2+5) + FRZ=0.5 + DO 170 IEL=1,IELEM**2 + KN(NUM1+1+5*IELEM**2+IEL)=-KN(NUM1+1+4*IELEM**2+IEL) + 170 CONTINUE + ENDIF +* + VOL0=XX(KEL)*YY(KEL)*ZZ(KEL)*FRX*FRY*FRZ + IF(CYLIND) VOL0=6.2831853072*DD(KEL)*VOL0 + VOL(KEL)=VOL0 + QFR(NUM2+1)=QFR(NUM2+1)*VOL0/XX(KEL) + QFR(NUM2+2)=QFR(NUM2+2)*VOL0/XX(KEL) + QFR(NUM2+3)=QFR(NUM2+3)*VOL0/YY(KEL) + QFR(NUM2+4)=QFR(NUM2+4)*VOL0/YY(KEL) + QFR(NUM2+5)=QFR(NUM2+5)*VOL0/ZZ(KEL) + QFR(NUM2+6)=QFR(NUM2+6)*VOL0/ZZ(KEL) + NUM1=NUM1+1+6*IELEM**2 + NUM2=NUM2+6 + 180 CONTINUE + 181 CONTINUE + 182 CONTINUE +* END OF THE MAIN LOOP OVER ELEMENTS. +* +*---- +* REMOVING THE UNUSED UNKNOWNS INDICES FROM KN +*---- + IP(:LL4F0+LL4X0+LL4Y0+LL4Z0)=0 + DO 190 NUM1=1,L2*(1+6*IELEM**2) + IF(KN(NUM1).NE.0) IP(ABS(KN(NUM1)))=1 + 190 CONTINUE + LL4F=0 + IND=0 + DO 200 KEL=1,L2 + IF(IP(IND+1).EQ.1) THEN + DO 195 IEL=1,IELEM**3 + LL4F=LL4F+1 + IP(IND+IEL)=LL4F + 195 CONTINUE + ENDIF + IND=IND+IELEM**3 + 200 CONTINUE + LL4X=0 + DO 210 IND=LL4F0+1,LL4F0+LL4X0 + IF(IP(IND).EQ.1) THEN + LL4X=LL4X+1 + IP(IND)=LL4F+LL4X + ENDIF + 210 CONTINUE + LL4Y=0 + DO 220 IND=LL4F0+LL4X0+1,LL4F0+LL4X0+LL4Y0 + IF(IP(IND).EQ.1) THEN + LL4Y=LL4Y+1 + IP(IND)=LL4F+LL4X+LL4Y + ENDIF + 220 CONTINUE + LL4Z=0 + DO 230 IND=LL4F0+LL4X0+LL4Y0+1,LL4F0+LL4X0+LL4Y0+LL4Z0 + IF(IP(IND).EQ.1) THEN + LL4Z=LL4Z+1 + IP(IND)=LL4F+LL4X+LL4Y+LL4Z + ENDIF + 230 CONTINUE + DO 240 NUM1=1,L2*(1+6*IELEM**2) + IF(KN(NUM1).NE.0) KN(NUM1)=SIGN(IP(ABS(KN(NUM1))),KN(NUM1)) + 240 CONTINUE + L4=LL4F+LL4X+LL4Y+LL4Z + NUM1=0 + DO 250 KEL=1,L2 + IDL(KEL)=0 + IF(MAT(KEL).EQ.0) GO TO 250 + IDL(KEL)=KN(NUM1+1) + NUM1=NUM1+1+6*IELEM**2 + 250 CONTINUE +* + IF(IMPX.GT.0) WRITE(6,710) L4 + IF(IMPX.GT.2) THEN + WRITE(6,720) (VOL(I),I=1,L2) + NUM1=0 + WRITE (6,730) + DO 500 K=1,L2 + IF(MAT(K).EQ.0) GO TO 500 + WRITE (6,740) K,KN(NUM1+1),'X',(KN(NUM1+I),I=2,1+2*IELEM**2) + WRITE (6,750) 'Y',(KN(NUM1+I),I=2+2*IELEM**2,1+4*IELEM**2) + WRITE (6,750) 'Z',(KN(NUM1+I),I=2+4*IELEM**2,1+6*IELEM**2) + NUM1=NUM1+1+6*IELEM**2 + 500 CONTINUE + WRITE (6,760) + NUM2=0 + DO 510 K=1,L2 + IF(MAT(K).EQ.0) GO TO 510 + WRITE (6,770) K,(QFR(NUM2+I),I=1,6) + NUM2=NUM2+6 + 510 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IP) + RETURN +* + 700 FORMAT(/42H TRIDKN: MIXED-DUAL FINITE ELEMENT METHOD.//7H NUMBER, + 1 27H OF ELEMENTS ALONG X AXIS =,I3/20X,14HALONG Y AXIS =,I3/ + 2 20X,14HALONG Z AXIS =,I3) + 710 FORMAT(31H NUMBER OF UNKNOWNS PER GROUP =,I8) + 720 FORMAT(/20H VOLUMES PER ELEMENT/(1X,1P,10E13.4)) + 730 FORMAT(/22H NUMBERING OF UNKNOWNS/1X,21(1H-)//8H ELEMENT,8X, + 1 4HFLUX,6X,8HCURRENTS,89(1H.)) + 740 FORMAT (1X,I6,5X,I8,6X,A1,12I8/(27X,12I8)) + 750 FORMAT (26X,A1,12I8/(27X,12I8)) + 760 FORMAT(/8H ELEMENT,3X,23HVOID BOUNDARY CONDITION) + 770 FORMAT (1X,I6,5X,1P,6E10.1) + END diff --git a/Trivac/src/TRIDXX.f b/Trivac/src/TRIDXX.f new file mode 100755 index 0000000..86c6280 --- /dev/null +++ b/Trivac/src/TRIDXX.f @@ -0,0 +1,322 @@ +*DECK TRIDXX + SUBROUTINE TRIDXX(NBMIX,CYLIND,IELEM,ICOL,NEL,LL4F,LL4X,MAT,VOL, + 1 XX,YY,ZZ,DD,KN,QFR,SGD,XSGD,MUX,IPBBX,LC,R,V,BBX,TTF,AX,C11X) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Assembly of system matrices for a Thomas-Raviart (dual) finite element +* method in Cartesian 3-D diffusion approximation. +* Note: system matrices should be initialized by the calling program. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NBMIX number of mixtures. +* CYLIND cylindrical geometry flag (set with CYLIND=.true.). +* IELEM degree of the Lagrangian finite elements: =1 (linear); +* =2 (parabolic); =3 (cubic). +* ICOL type of quadrature: =1 (analytical integration); +* =2 (Gauss-Lobatto); =3 (Gauss-Legendre). +* NEL total number of finite elements. +* LL4F number of flux components. +* LL4X number of X-directed currents. +* LL4Y number of Y-directed currents. +* LL4Z number of Z-directed currents. +* MAT mixture index assigned to each element. +* VOL volume of each element. +* XX X-directed mesh spacings. +* YY Y-directed mesh spacings. +* ZZ Z-directed mesh spacings. +* DD used with cylindrical geometry. +* KN element-ordered unknown list. +* QFR element-ordered boundary conditions. +* SGD nuclear properties by material mixture: +* SGD(L,1)= X-oriented diffusion coefficients; +* SGD(L,2)= Y-oriented diffusion coefficients; +* SGD(L,3)= Z-oriented diffusion coefficients; +* SGD(L,4)= removal macroscopic cross section. +* XSGD one over nuclear properties. +* MUX X-directed compressed storage mode indices. +* MUY Y-directed compressed storage mode indices. +* MUZ Z-directed compressed storage mode indices. +* IPBBX X-directed perdue storage indices. +* IPBBY Y-directed perdue storage indices. +* IPBBZ Z-directed perdue storage indices. +* LC order of the unit matrices. +* R unit matrix. +* V unit matrix. +* BBX X-directed flux-current matrices. +* BBY Y-directed flux-current matrices. +* BBZ Z-directed flux-current matrices. +* +*Parameters: output +* TTF flux-flux matrices. +* AX X-directed main current-current matrices. Dimensionned to +* MUX(LL4X). +* AY Y-directed main current-current matrices. Dimensionned to +* MUY(LL4Y). +* AZ Z-directed main current-current matrices. Dimensionned to +* MUZ(LL4Z). +* C11X X-directed main current-current matrices to be factorized. +* Dimensionned to MUX(LL4X). +* C11Y Y-directed main current-current matrices to be factorized. +* Dimensionned to MUY(LL4Y). +* C11Z Z-directed main current-current matrices to be factorized. +* Dimensionned to MUZ(LL4Z). +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NBMIX,IELEM,ICOL,NEL,LL4F,LL4X,MAT(NEL), + 1 KN(NEL*(1+6*IELEM**2)),MUX(LL4X),IPBBX(2*IELEM,LL4X),LC + REAL VOL(NEL),XX(NEL),YY(NEL),ZZ(NEL),DD(NEL),QFR(6*NEL), + 1 SGD(NBMIX,4),XSGD(NBMIX,4),R(LC,LC),V(LC,LC-1),TTF(LL4F), + 2 BBX(2*IELEM,LL4X),AX(*),C11X(*) + LOGICAL CYLIND +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION FFF + REAL QQ(5,5) +*---- +* X-ORIENTED COUPLINGS +*---- + IF((CYLIND).AND.((IELEM.GT.1).OR.(ICOL.NE.2))) + 1 CALL XABORT('TRIDXX: TYPE OF DISCRETIZATION NOT IMPLEMENTED.') + DO 25 I0=1,IELEM + DO 20 J0=1,IELEM + FFF=0.0D0 + DO 10 K0=2,IELEM + FFF=FFF+V(K0,I0)*V(K0,J0)/R(K0,K0) + 10 CONTINUE + IF(ABS(FFF).LE.1.0E-6) FFF=0.0D0 + QQ(I0,J0)=REAL(FFF) + 20 CONTINUE + 25 CONTINUE +* + NUM1=0 + NUM2=0 + DO 60 IE=1,NEL + L=MAT(IE) + IF(L.EQ.0) GO TO 60 + VOL0=VOL(IE) + IF(VOL0.EQ.0.0) GO TO 50 + DX=XX(IE) + DY=YY(IE) + DZ=ZZ(IE) + IF(CYLIND) THEN + DIN=1.0-0.5*DX/DD(IE) + DOT=1.0+0.5*DX/DD(IE) + ELSE + DIN=1.0 + DOT=1.0 + ENDIF +* + DO 45 K3=0,IELEM-1 + DO 40 K2=0,IELEM-1 + KN1=KN(NUM1+2+K3*IELEM+K2) + KN2=KN(NUM1+2+IELEM**2+K3*IELEM+K2) + INX1=ABS(KN1)-LL4F + INX2=ABS(KN2)-LL4F + DO 30 K1=0,IELEM-1 + JND1=KN(NUM1+1)+(K3*IELEM+K2)*IELEM+K1 + TTF(JND1)=TTF(JND1)+VOL0*SGD(L,4)+VOL0*QQ(K1+1,K1+1)*SGD(L,1)/ + 1 (DX*DX) + TTF(JND1)=TTF(JND1)+VOL0*QQ(K2+1,K2+1)*SGD(L,2)/(DY*DY) + TTF(JND1)=TTF(JND1)+VOL0*QQ(K3+1,K3+1)*SGD(L,3)/(DZ*DZ) + 30 CONTINUE + IF(KN1.NE.0) THEN + KEY=MUX(INX1) + AX(KEY)=AX(KEY)-DIN*(VOL0*R(1,1)*XSGD(L,1)+QFR(NUM2+1)) + ENDIF + IF(KN2.NE.0) THEN + KEY=MUX(INX2) + AX(KEY)=AX(KEY)-DOT*(VOL0*R(IELEM+1,IELEM+1)*XSGD(L,1) + 1 +QFR(NUM2+2)) + ENDIF + IF((ICOL.NE.2).AND.(KN1.NE.0).AND.(KN2.NE.0)) THEN + IF(INX2.GT.INX1) KEY=MUX(INX2)-INX2+INX1 + IF(INX2.LE.INX1) KEY=MUX(INX1)-INX1+INX2 + SG=REAL(SIGN(1,KN1)*SIGN(1,KN2)) + IF(INX1.EQ.INX2) SG=2.0*SG + AX(KEY)=AX(KEY)-SG*VOL0*R(IELEM+1,1)*XSGD(L,1) + ENDIF + 40 CONTINUE + 45 CONTINUE + 50 NUM1=NUM1+1+6*IELEM**2 + NUM2=NUM2+6 + 60 CONTINUE +* + DO 121 I0=1,MUX(LL4X) + C11X(I0)=-AX(I0) + 121 CONTINUE + MUIM1=0 + DO 716 I=1,LL4X + MUI=MUX(I) + DO 715 J=I-(MUI-MUIM1)+1,I + KEY=MUI-I+J + DO 714 I0=1,2*IELEM + II=IPBBX(I0,I) + IF(II.EQ.0) GO TO 715 + DO 713 J0=1,2*IELEM + JJ=IPBBX(J0,J) + IF(II.EQ.JJ) C11X(KEY)=C11X(KEY)+BBX(I0,I)*BBX(J0,J)/TTF(II) + 713 CONTINUE + 714 CONTINUE + 715 CONTINUE + MUIM1=MUI + 716 CONTINUE + RETURN + END +* + SUBROUTINE TRIDXY(NBMIX,IELEM,ICOL,NEL,LL4F,LL4X,LL4Y,MAT,VOL,YY, + 1 KN,QFR,XSGD,MUY,IPBBY,LC,R,BBY,TTF,AY,C11Y) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NBMIX,IELEM,ICOL,NEL,LL4F,LL4X,LL4Y,MAT(NEL), + 1 KN(NEL*(1+6*IELEM**2)),MUY(LL4Y),IPBBY(2*IELEM,LL4Y),LC + REAL VOL(NEL),YY(NEL),QFR(6*NEL),XSGD(NBMIX,4),R(LC,LC),TTF(LL4F), + 1 BBY(2*IELEM,LL4Y),AY(*),C11Y(*) +*---- +* Y-ORIENTED COUPLINGS +*---- + NUM1=0 + NUM2=0 + DO 240 IE=1,NEL + L=MAT(IE) + IF(L.EQ.0) GO TO 240 + VOL0=VOL(IE) + IF(VOL0.EQ.0.0) GO TO 230 + DY=YY(IE) +* + DO 195 K3=0,IELEM-1 + DO 190 K1=0,IELEM-1 + KN1=KN(NUM1+2+2*IELEM**2+K3*IELEM+K1) + KN2=KN(NUM1+2+3*IELEM**2+K3*IELEM+K1) + INY1=ABS(KN1)-LL4F-LL4X + INY2=ABS(KN2)-LL4F-LL4X + IF(KN1.NE.0) THEN + KEY=MUY(INY1) + AY(KEY)=AY(KEY)-VOL0*R(1,1)*XSGD(L,2)-QFR(NUM2+3) + ENDIF + IF(KN2.NE.0) THEN + KEY=MUY(INY2) + AY(KEY)=AY(KEY)-VOL0*R(IELEM+1,IELEM+1)*XSGD(L,2) + 1 -QFR(NUM2+4) + ENDIF + IF((ICOL.NE.2).AND.(KN1.NE.0).AND.(KN2.NE.0)) THEN + IF(INY2.GT.INY1) KEY=MUY(INY2)-INY2+INY1 + IF(INY2.LE.INY1) KEY=MUY(INY1)-INY1+INY2 + SG=REAL(SIGN(1,KN1)*SIGN(1,KN2)) + IF(INY1.EQ.INY2) SG=2.0*SG + AY(KEY)=AY(KEY)-SG*VOL0*R(IELEM+1,1)*XSGD(L,2) + ENDIF + 190 CONTINUE + 195 CONTINUE + 230 NUM1=NUM1+1+6*IELEM**2 + NUM2=NUM2+6 + 240 CONTINUE +* + DO 212 I0=1,MUY(LL4Y) + C11Y(I0)=-AY(I0) + 212 CONTINUE + MUIM1=0 + DO 216 I=1,LL4Y + MUI=MUY(I) + DO 215 J=I-(MUI-MUIM1)+1,I + KEY=MUI-I+J + DO 214 I0=1,2*IELEM + II=IPBBY(I0,I) + IF(II.EQ.0) GO TO 215 + DO 213 J0=1,2*IELEM + JJ=IPBBY(J0,J) + IF(II.EQ.JJ) C11Y(KEY)=C11Y(KEY)+BBY(I0,I)*BBY(J0,J)/TTF(II) + 213 CONTINUE + 214 CONTINUE + 215 CONTINUE + MUIM1=MUI + 216 CONTINUE + RETURN + END +* + SUBROUTINE TRIDXZ(NBMIX,IELEM,ICOL,NEL,LL4F,LL4X,LL4Y,LL4Z,MAT, + 1 VOL,ZZ,KN,QFR,XSGD,MUZ,IPBBZ,LC,R,BBZ,TTF,AZ,C11Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NBMIX,IELEM,ICOL,NEL,LL4F,LL4X,LL4Y,LL4Z,MAT(NEL), + 1 KN(NEL*(1+6*IELEM**2)),MUZ(LL4Z),IPBBZ(2*IELEM,LL4Z),LC + REAL VOL(NEL),ZZ(NEL),QFR(6*NEL),XSGD(NBMIX,4),R(LC,LC),TTF(LL4F), + 1 BBZ(2*IELEM,LL4Z),AZ(*),C11Z(*) +*---- +* Z-ORIENTED COUPLINGS +*---- + NUM1=0 + NUM2=0 + DO 340 IE=1,NEL + L=MAT(IE) + IF(L.EQ.0) GO TO 340 + VOL0=VOL(IE) + IF(VOL0.EQ.0.0) GO TO 330 + DZ=ZZ(IE) +* + DO 295 K2=0,IELEM-1 + DO 290 K1=0,IELEM-1 + KN1=KN(NUM1+2+4*IELEM**2+K2*IELEM+K1) + KN2=KN(NUM1+2+5*IELEM**2+K2*IELEM+K1) + INZ1=ABS(KN1)-LL4F-LL4X-LL4Y + INZ2=ABS(KN2)-LL4F-LL4X-LL4Y + IF(KN1.NE.0) THEN + KEY=MUZ(INZ1) + AZ(KEY)=AZ(KEY)-VOL0*R(1,1)*XSGD(L,3)-QFR(NUM2+5) + ENDIF + IF(KN2.NE.0) THEN + KEY=MUZ(INZ2) + AZ(KEY)=AZ(KEY)-VOL0*R(IELEM+1,IELEM+1)*XSGD(L,3) + 1 -QFR(NUM2+6) + ENDIF + IF((ICOL.NE.2).AND.(KN1.NE.0).AND.(KN2.NE.0)) THEN + IF(INZ2.GT.INZ1) KEY=MUZ(INZ2)-INZ2+INZ1 + IF(INZ2.LE.INZ1) KEY=MUZ(INZ1)-INZ1+INZ2 + SG=REAL(SIGN(1,KN1)*SIGN(1,KN2)) + IF(INZ1.EQ.INZ2) SG=2.0*SG + AZ(KEY)=AZ(KEY)-SG*VOL0*R(IELEM+1,1)*XSGD(L,3) + ENDIF + 290 CONTINUE + 295 CONTINUE + 330 NUM1=NUM1+1+6*IELEM**2 + NUM2=NUM2+6 + 340 CONTINUE +* + DO 312 I0=1,MUZ(LL4Z) + C11Z(I0)=-AZ(I0) + 312 CONTINUE + MUIM1=0 + DO 316 I=1,LL4Z + MUI=MUZ(I) + DO 315 J=I-(MUI-MUIM1)+1,I + KEY=MUI-I+J + DO 314 I0=1,2*IELEM + II=IPBBZ(I0,I) + IF(II.EQ.0) GO TO 315 + DO 313 J0=1,2*IELEM + JJ=IPBBZ(J0,J) + IF(II.EQ.JJ) C11Z(KEY)=C11Z(KEY)+BBZ(I0,I)*BBZ(J0,J)/TTF(II) + 313 CONTINUE + 314 CONTINUE + 315 CONTINUE + MUIM1=MUI + 316 CONTINUE + RETURN + END diff --git a/Trivac/src/TRIHCO.f b/Trivac/src/TRIHCO.f new file mode 100755 index 0000000..f900dd7 --- /dev/null +++ b/Trivac/src/TRIHCO.f @@ -0,0 +1,394 @@ +*DECK TRIHCO + SUBROUTINE TRIHCO (IR,K,NEL,VOL0,MAT,DIF,DDF,SIDE,ZZ,KN,QFR,IWRK, + 1 IPR,A) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the value or the derivative or variation of mesh centered +* finite difference coefficients in element K for hexagonal geometry. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Benaboud +* +*Parameters: input +* IR first dimension of matrix DIF. +* K index of finite element under consideration. +* NEL total number of finite elements. +* VOL0 volume of finite element under consideration. +* MAT mixture index assigned to each element. +* DIF directional diffusion coefficients. +* DDF derivative or variation of directional diffusion coefficients. +* SIDE side of the hexagons. +* ZZ Z-directed mesh spacings. +* KN element-ordered unknown list: +* .GT.0 neighbour index; +* =-1 void/albedo boundary condition; +* =-2 reflection boundary condition; +* =-3 ZERO flux boundary condition; +* =-4 SYME boundary condition (axial symmetry). +* QFR element-ordered boundary conditions. +* IWRK non-void indices. +* IPR type of MCFD coefficients: +* .eq.0 direct MCFD coefficients calculation; +* .eq.1 take derivative of MCFD coefficients; +* .ge.2 take variation of MCFD coefficients. +* +*Parameters: output +* A value or derivative or variation of mesh centered finite +* difference coefficients. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IR,K,MAT(NEL),KN(8),IWRK(NEL),IPR + REAL VOL0,DIF(IR,3),DDF(IR,3),SIDE,ZZ(NEL),QFR(8) + DOUBLE PRECISION A(8) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION SHARM,VHARM,DHARM +* +* FORMULE DIRECTE: + SHARM(X1,X2,DIF1,DIF2)=2.0D0*DIF1*DIF2/(X1*DIF2+X2*DIF1) +* FORMULE DE VARIATION: + VHARM(X1,X2,DIF1,DIF2,DDF1,DDF2)=2.0D0*((DIF1+DDF1)*(DIF2+DDF2) + 1 /(X1*(DIF2+DDF2)+X2*(DIF1+DDF1))-DIF1*DIF2/(X1*DIF2+X2*DIF1)) +* FORMULE DE DERIVEE: + DHARM(X1,X2,DIF1,DIF2,DDF1,DDF2)=2.0D0*(X1*DIF2*DIF2*DDF1+ + 1 X2*DIF1*DIF1*DDF2)/(X1*DIF2+X2*DIF1)**2 +* + DENOM=2.0 + L=MAT(K) + DZ=ZZ(K) + DS=SQRT(3.0)*SIDE + IF(IPR.EQ.0) THEN +* COTE W NEGATIF: + KK1=KN(6) + IF(KK1.GT.0) THEN + A(6)=SHARM(DS,DS,DIF(L,1),DIF(MAT(IWRK(KK1)),1))*DZ*SIDE + ELSE IF(KK1.EQ.-1) THEN + A(6)=SHARM(DS,DS,DIF(L,1),DS*QFR(6)/DENOM)*DZ*SIDE + ELSE IF(KK1.EQ.-2) THEN + A(6)=0.0D0 + ELSE IF(KK1.EQ.-3) THEN + A(6)=2.0D0*SHARM(DS,DS,DIF(L,1),DIF(L,1))*DZ*SIDE + ENDIF +* COTE W POSITIF: + KK2=KN(3) + IF(KK2.GT.0) THEN + A(3)=SHARM(DS,DS,DIF(L,1),DIF(MAT(IWRK(KK2)),1))*DZ*SIDE + ELSE IF(KK2.EQ.-1) THEN + A(3)=SHARM(DS,DS,DIF(L,1),DS*QFR(3)/DENOM)*DZ*SIDE + ELSE IF(KK2.EQ.-2) THEN + A(3)=0.0D0 + ELSE IF(KK2.EQ.-3) THEN + A(3)=2.0D0*SHARM(DS,DS,DIF(L,1),DIF(L,1))*DZ*SIDE + ENDIF +* COTE X NEGATIF: + KK3=KN(1) + IF(KK3.GT.0) THEN + A(1)=SHARM(DS,DS,DIF(L,1),DIF(MAT(IWRK(KK3)),1))*DZ*SIDE + ELSE IF(KK3.EQ.-1) THEN + A(1)=SHARM(DS,DS,DIF(L,1),DS*QFR(1)/DENOM)*DZ*SIDE + ELSE IF(KK3.EQ.-2) THEN + A(1)=0.0D0 + ELSE IF(KK3.EQ.-3) THEN + A(1)=2.0D0*SHARM(DS,DS,DIF(L,1),DIF(L,1))*DZ*SIDE + ENDIF +* COTE X POSITIF: + KK4=KN(4) + IF(KK4.GT.0) THEN + A(4)=SHARM(DS,DS,DIF(L,1),DIF(MAT(IWRK(KK4)),1))*DZ*SIDE + ELSE IF(KK4.EQ.-1) THEN + A(4)=SHARM(DS,DS,DIF(L,1),DS*QFR(4)/DENOM)*DZ*SIDE + ELSE IF(KK4.EQ.-2) THEN + A(4)=0.0D0 + ELSE IF(KK4.EQ.-3) THEN + A(4)=2.0D0*SHARM(DS,DS,DIF(L,1),DIF(L,1))*DZ*SIDE + ENDIF +* COTE Y NEGATIF: + KK5=KN(2) + IF(KK5.GT.0) THEN + A(2)=SHARM(DS,DS,DIF(L,1),DIF(MAT(IWRK(KK5)),1))*DZ*SIDE + ELSE IF(KK5.EQ.-1) THEN + A(2)=SHARM(DS,DS,DIF(L,1),DS*QFR(2)/DENOM)*DZ*SIDE + ELSE IF(KK5.EQ.-2) THEN + A(2)=0.0D0 + ELSE IF(KK5.EQ.-3) THEN + A(2)=2.0D0*SHARM(DS,DS,DIF(L,1),DIF(L,1))*DZ*SIDE + ENDIF +* COTE Y POSITIF: + KK6=KN(5) + IF(KK6.GT.0) THEN + A(5)=SHARM(DS,DS,DIF(L,1),DIF(MAT(IWRK(KK6)),1))*DZ*SIDE + ELSE IF(KK6.EQ.-1) THEN + A(5)=SHARM(DS,DS,DIF(L,1),DS*QFR(5)/DENOM)*DZ*SIDE + ELSE IF(KK6.EQ.-2) THEN + A(5)=0.0D0 + ELSE IF(KK6.EQ.-3) THEN + A(5)=2.0D0*SHARM(DS,DS,DIF(L,1),DIF(L,1))*DZ*SIDE + ENDIF +* COTE Z NEGATIF: + KK7=KN(7) + IF(KK7.GT.0) THEN + A(7)=SHARM(DZ,ZZ(IWRK(KK7)),DIF(L,3),DIF(MAT(IWRK(KK7)),3)) + * *VOL0/DZ + ELSE IF(KK7.EQ.-1) THEN + A(7)=SHARM(DZ,DZ,DIF(L,3),DZ*QFR(7)/DENOM)*VOL0/DZ + ELSE IF(KK7.EQ.-2) THEN + A(7)=0.0D0 + ELSE IF(KK7.EQ.-3) THEN + A(7)=2.0D0*SHARM(DZ,DZ,DIF(L,3),DIF(L,3))*VOL0/DZ + ENDIF +* COTE Z POSITIF: + KK8=KN(8) + IF(KK8.GT.0) THEN + A(8)=SHARM(DZ,ZZ(IWRK(KK8)),DIF(L,3),DIF(MAT(IWRK(KK8)),3)) + * *VOL0/DZ + ELSE IF(KK8.EQ.-1) THEN + A(8)=SHARM(DZ,DZ,DIF(L,3),DZ*QFR(8)/DENOM)*VOL0/DZ + ELSE IF(KK8.EQ.-2) THEN + A(8)=0.0D0 + ELSE IF(KK8.EQ.-3) THEN + A(8)=2.0D0*SHARM(DZ,DZ,DIF(L,3),DIF(L,3))*VOL0/DZ + ENDIF + ELSE IF(IPR.EQ.1) THEN +* FORMULE DE DERIVEE. +* COTE W NEGATIF: + KK1=KN(6) + IF(KK1.GT.0) THEN + KK1=IWRK(KK1) + A(6)=DHARM(DS,DS,DIF(L,1),DIF(MAT(KK1),1),DDF(L,1), + 1 DDF(MAT(KK1),1))*DZ*SIDE + ELSE IF(KK1.EQ.-1) THEN + A(6)=DHARM(DS,DS,DIF(L,1),DS*QFR(6)/DENOM,DDF(L,1),0.0) + 1 *DZ*SIDE + ELSE IF(KK1.EQ.-2) THEN + A(6)=0.0D0 + ELSE IF(KK1.EQ.-3) THEN + A(6)=2.0D0*DDF(L,1)*DZ*SIDE/DS + ENDIF +* COTE W POSITIF: + KK2=KN(3) + IF(KK2.GT.0) THEN + KK2=IWRK(KK2) + A(3)=DHARM(DS,DS,DIF(L,1),DIF(MAT(KK2),1),DDF(L,1), + 1 DDF(MAT(KK2),1))*DZ*SIDE + ELSE IF(KK2.EQ.-1) THEN + A(3)=DHARM(DS,DS,DIF(L,1),DS*QFR(3)/DENOM,DDF(L,1),0.0) + 1 *DZ*SIDE + ELSE IF(KK2.EQ.-2) THEN + A(3)=0.0D0 + ELSE IF(KK2.EQ.-3) THEN + A(3)=2.0D0*DDF(L,1)*DZ*SIDE/DS + ENDIF +* COTE X NEGATIF: + KK3=KN(1) + IF(KK3.GT.0) THEN + KK3=IWRK(KK3) + A(1)=DHARM(DS,DS,DIF(L,1),DIF(MAT(KK3),1),DDF(L,1), + 1 DDF(MAT(KK3),1))*DZ*SIDE + ELSE IF(KK3.EQ.-1) THEN + A(1)=DHARM(DS,DS,DIF(L,1),DS*QFR(1)/DENOM,DDF(L,1),0.0) + 1 *DZ*SIDE + ELSE IF(KK3.EQ.-2) THEN + A(3)=0.0D0 + ELSE IF(KK3.EQ.-3) THEN + A(3)=2.0D0*DDF(L,1)*DZ*SIDE/DS + ENDIF +* COTE X POSITIF: + KK4=KN(4) + IF(KK4.GT.0) THEN + KK4=IWRK(KK4) + A(4)=DHARM(DS,DS,DIF(L,1),DIF(MAT(KK4),1),DDF(L,1), + 1 DDF(MAT(KK4),1))*DZ*SIDE + ELSE IF(KK4.EQ.-1) THEN + A(4)=DHARM(DS,DS,DIF(L,1),DS*QFR(4)/DENOM,DDF(L,1),0.0) + 1 *DZ*SIDE + ELSE IF(KK4.EQ.-2) THEN + A(4)=0.0D0 + ELSE IF(KK4.EQ.-3) THEN + A(4)=2.0D0*DDF(L,1)*DZ*SIDE/DS + ENDIF +* COTE Y NEGATIF: + KK5=KN(2) + IF(KK5.GT.0) THEN + KK5=IWRK(KK5) + A(2)=DHARM(DS,DS,DIF(L,1),DIF(MAT(KK5),1),DDF(L,1), + 1 DDF(MAT(KK5),1))*DZ*SIDE + ELSE IF(KK5.EQ.-1) THEN + A(2)=DHARM(DS,DS,DIF(L,1),DZ*QFR(2)/DENOM,DDF(L,1),0.0) + 1 *DZ*SIDE + ELSE IF(KK5.EQ.-2) THEN + A(2)=0.0D0 + ELSE IF(KK5.EQ.-3) THEN + A(2)=2.0D0*DDF(L,1)*DZ*SIDE/DS + ENDIF +* COTE Y POSITIF: + KK6=KN(5) + IF(KK6.GT.0) THEN + KK6=IWRK(KK6) + A(5)=DHARM(DS,DS,DIF(L,1),DIF(MAT(KK6),1),DDF(L,1), + 1 DDF(MAT(KK6),1))*DZ*SIDE + ELSE IF(KK6.EQ.-1) THEN + A(5)=DHARM(DS,DS,DIF(L,1),DS*QFR(5)/DENOM,DDF(L,1),0.0) + 1 *DZ*SIDE + ELSE IF(KK6.EQ.-2) THEN + A(5)=0.0D0 + ELSE IF(KK6.EQ.-3) THEN + A(5)=2.0D0*DDF(L,1)*DZ*SIDE/DS + ENDIF +* COTE Z NEGATIF: + KK7=KN(7) + IF(KK7.GT.0) THEN + KK7=IWRK(KK7) + A(7)=DHARM(DZ,ZZ(KK7),DIF(L,3),DIF(MAT(KK7),3),DDF(L,3), + 1 DDF(MAT(KK7),3))*VOL0/DZ + ELSE IF(KK7.EQ.-1) THEN + A(7)=DHARM(DZ,DZ,DIF(L,3),DZ*QFR(7)/DENOM,DDF(L,3),0.0) + 1 *VOL0/DZ + ELSE IF(KK7.EQ.-2) THEN + A(7)=0.0D0 + ELSE IF(KK7.EQ.-3) THEN + A(7)=2.0D0*DDF(L,3)*VOL0/(DZ*DZ) + ENDIF +* COTE Z POSITIF: + KK8=KN(8) + IF(KK8.GT.0) THEN + KK8=IWRK(KK8) + A(8)=DHARM(DZ,ZZ(KK8),DIF(L,3),DIF(MAT(KK8),3),DDF(L,3), + 1 DDF(MAT(KK8),3))*VOL0/DZ + ELSE IF(KK8.EQ.-1) THEN + A(8)=DHARM(DZ,DZ,DIF(L,3),DZ*QFR(8)/DENOM,DDF(L,3),0.0) + 1 *VOL0/DZ + ELSE IF(KK8.EQ.-2) THEN + A(8)=0.0D0 + ELSE IF(KK8.EQ.-3) THEN + A(8)=2.0D0*DDF(L,3)*VOL0/(DZ*DZ) + ENDIF + ELSE +* FORMULE DE VARIATION. +* COTE W NEGATIF: + KK1=KN(6) + IF(KK1.GT.0) THEN + KK1=IWRK(KK1) + A(6)=VHARM(DS,DS,DIF(L,1),DIF(MAT(KK1),1),DDF(L,1), + 1 DDF(MAT(KK1),1))*DZ*SIDE + ELSE IF(KK1.EQ.-1) THEN + A(6)=VHARM(DS,DS,DIF(L,1),DS*QFR(6)/DENOM,DDF(L,1),0.0) + 1 *DZ*SIDE + ELSE IF(KK1.EQ.-2) THEN + A(6)=0.0D0 + ELSE IF(KK1.EQ.-3) THEN + A(6)=2.0D0*DDF(L,1)*DZ*SIDE/DS + ENDIF +* COTE W POSITIF: + KK2=KN(3) + IF(KK2.GT.0) THEN + KK2=IWRK(KK2) + A(3)=VHARM(DS,DS,DIF(L,1),DIF(MAT(KK2),1),DDF(L,1), + 1 DDF(MAT(KK2),1))*DZ*SIDE + ELSE IF(KK2.EQ.-1) THEN + A(3)=VHARM(DS,DS,DIF(L,1),DS*QFR(3)/DENOM,DDF(L,1),0.0) + 1 *DZ*SIDE + ELSE IF(KK2.EQ.-2) THEN + A(3)=0.0D0 + ELSE IF(KK2.EQ.-3) THEN + A(3)=2.0D0*DDF(L,1)*DZ*SIDE/DS + ENDIF +* COTE X NEGATIF: + KK3=KN(1) + IF(KK3.GT.0) THEN + KK3=IWRK(KK3) + A(1)=VHARM(DS,DS,DIF(L,1),DIF(MAT(KK3),1),DDF(L,1), + 1 DDF(MAT(KK3),1))*DZ*SIDE + ELSE IF(KK3.EQ.-1) THEN + A(1)=VHARM(DS,DS,DIF(L,1),DS*QFR(1)/DENOM,DDF(L,1),0.0) + 1 *DZ*SIDE + ELSE IF(KK3.EQ.-2) THEN + A(1)=0.0D0 + ELSE IF(KK3.EQ.-3) THEN + A(1)=2.0D0*DDF(L,1)*DZ*SIDE/DS + ENDIF +* COTE X POSITIF: + KK4=KN(4) + IF(KK4.GT.0) THEN + KK4=IWRK(KK4) + A(4)=VHARM(DS,DS,DIF(L,1),DIF(MAT(KK4),1),DDF(L,1), + 1 DDF(MAT(KK4),1))*DZ*SIDE + ELSE IF(KK4.EQ.-1) THEN + A(4)=VHARM(DS,DS,DIF(L,1),DS*QFR(4)/DENOM,DDF(L,1),0.0) + 1 *DZ*SIDE + ELSE IF(KK4.EQ.-2) THEN + A(4)=0.0D0 + ELSE IF(KK4.EQ.-3) THEN + A(4)=2.0D0*DDF(L,1)*DZ*SIDE/DS + ENDIF +* COTE Y NEGATIF: + KK5=KN(2) + IF(KK5.GT.0) THEN + KK5=IWRK(KK5) + A(2)=VHARM(DS,DS,DIF(L,1),DIF(MAT(KK5),1),DDF(L,1), + 1 DDF(MAT(KK5),1))*DZ*SIDE + ELSE IF(KK5.EQ.-1) THEN + A(2)=VHARM(DS,DS,DIF(L,1),DS*QFR(2)/DENOM,DDF(L,1),0.0) + 1 *DZ*SIDE + ELSE IF(KK5.EQ.-2) THEN + A(2)=0.0D0 + ELSE IF(KK5.EQ.-3) THEN + A(2)=2.0D0*DDF(L,1)*DZ*SIDE/DS + ENDIF +* COTE Y POSITIF: + KK6=KN(5) + IF(KK6.GT.0) THEN + KK6=IWRK(KK6) + A(5)=VHARM(DS,DS,DIF(L,1),DIF(MAT(KK6),1),DDF(L,1), + 1 DDF(MAT(KK6),1))*DZ*SIDE + ELSE IF(KK6.EQ.-1) THEN + A(5)=VHARM(DS,DS,DIF(L,1),DS*QFR(5)/DENOM,DDF(L,1),0.0) + 1 *DZ*SIDE + ELSE IF(KK6.EQ.-2) THEN + A(5)=0.0D0 + ELSE IF(KK6.EQ.-3) THEN + A(5)=2.0D0*DDF(L,1)*DZ*SIDE/DS + ENDIF +* COTE Z NEGATIF: + KK7=KN(7) + IF(KK7.GT.0) THEN + KK7=IWRK(KK7) + A(7)=VHARM(DZ,ZZ(KK7),DIF(L,3),DIF(MAT(KK7),3),DDF(L,3), + 1 DDF(MAT(KK7),3))*VOL0/DZ + ELSE IF(KK7.EQ.-1) THEN + A(7)=VHARM(DZ,DZ,DIF(L,3),DZ*QFR(7)/DENOM,DDF(L,3),0.0) + 1 *VOL0/DZ + ELSE IF(KK7.EQ.-2) THEN + A(7)=0.0D0 + ELSE IF(KK7.EQ.-3) THEN + A(7)=2.0D0*DDF(L,3)*VOL0/(DZ*DZ) + ENDIF +* COTE Z POSITIF: + KK8=KN(8) + IF(KK8.GT.0) THEN + KK8=IWRK(KK8) + A(8)=VHARM(DZ,ZZ(KK8),DIF(L,3),DIF(MAT(KK8),3),DDF(L,3), + 1 DDF(MAT(KK8),3))*VOL0/DZ + ELSE IF(KK8.EQ.-1) THEN + A(8)=VHARM(DZ,DZ,DIF(L,3),DZ*QFR(8)/DENOM,DDF(L,3),0.0) + 1 *VOL0/DZ + ELSE IF(KK8.EQ.-2) THEN + A(8)=0.0D0 + ELSE IF(KK8.EQ.-3) THEN + A(8)=2.0D0*DDF(L,3)*VOL0/(DZ*DZ) + ENDIF + ENDIF + RETURN + END diff --git a/Trivac/src/TRIHEX.f b/Trivac/src/TRIHEX.f new file mode 100755 index 0000000..c976e54 --- /dev/null +++ b/Trivac/src/TRIHEX.f @@ -0,0 +1,382 @@ +*DECK TRIHEX + SUBROUTINE TRIHEX (IOPT,LX,LZ,LL4,MAT,KN,NCODE,IPTRK) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Numbering corresponding to a mesh corner finite difference or +* Lagrangian finite element discretization of hexagonal geometry. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Benaboud +* +*Parameters: input +* IOPT type of hexagonal Lagrangian finite element: +* = 1 for hexagonal element with 6 points; +* = 2 for hexagonal element with 7 points and triangular element +* (IOPT.le.2) for Bivac; +* = 3 for hexagonal element with 6 points; +* = 4 for hexagonal element with 7 points and triangular element +* (IOPT.gt.2) for Trivac. +* LX number of elements in the XY plane. +* LZ number of elements along Z axis. +* MAT mixture index assigned to each element. +* +*Parameters: output +* LL4 total number of unknown (variational coefficients) per +* energy group (order of system matrices). +* KN element-ordered unknown list. Dimensionned to LC*LX*LZ +* where LC= 7 for triangle/Bivac, 6 for hexagon/Bivac, +* 14 for triangle/Trivac and 12 for hexagon/Trivac. +* IPTRK L_TRACK pointer to the tracking information. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IOPT,LX,LZ,LL4,MAT(LX*LZ),KN(*),NCODE(6) + TYPE(C_PTR) IPTRK +*---- +* LOCAL VARIABLES +*---- + LOGICAL LC1,LMD,LMG,LED,LEG,LIV,CADI,LNC1,LNC2 + INTEGER IRO(2,7),ITAB(14),ICO(6,6) + INTEGER, DIMENSION(:), ALLOCATABLE :: IISS,IPER,NWXY,IENV,IDX,IDY + INTEGER, DIMENSION(:,:), ALLOCATABLE :: ICG + INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: NIK + DATA ITAB /0,2*1,0,2*-1,0,1,0,-1,0,1,0,-1/ + DATA IRO /2,3,3,7,7,6,4,4,1,2,5,1,6,5/ + DATA ICO /2,1,5,6,7,3,1,5,6,7,3,2,3,2,1,5,6,7,2,1,5,6,7,3,7,3,2, + > 1,5,6,3,2,1,5,6,7/ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IISS(LX),IPER(LX),NWXY(LX),IENV(LX)) + ALLOCATE(ICG(14,LX),NIK(3,7,LX)) +* + IZI = 0 + IZE = 0 + IZS = 0 + KEL = 0 + IPAR = IOPT + NC = INT((SQRT(REAL((4*LX-1)/3))+1.)/2.) + IF(IPAR.LT.1.OR.IPAR.GT.4) CALL XABORT('TRIHEX : INVALID DATA.') + M1 = 2 + 3*(NC-1)*(NC-2) + IF(NC.EQ.1) M1=1 + DO 10 KX = 1,LX + IISS(KX) = 0 + IENV(KX) = KX + IF(MAT(KX).LE.0) GO TO 10 + KEL = KEL + 1 + IISS(KEL) = KX + 10 CONTINUE + DO 20 IY = 1,14 + ICG(IY,1) = ITAB(IY) + 20 CONTINUE + DO 45 J = 1,LX + DO 40 KF = 1, 6 + N = NEIGHB(J,KF,9,LX,POIDS) + IF(N.GT.LX) GOTO 40 + DO 30 I = 1,14 + IF(I.LE.7) THEN + IF((KF.EQ.1).OR.(KF.EQ.5)) ICG(I,N)=ICG(I,J)+1 + IF((KF.EQ.2).OR.(KF.EQ.4)) ICG(I,N)=ICG(I,J)-1 + IF(KF.EQ.3) ICG(I,N)=ICG(I,J)-2 + IF(KF.EQ.6) ICG(I,N)=ICG(I,J)+2 + ELSE + IF((KF.EQ.1).OR.(KF.EQ.3)) ICG(I,N)=ICG(I,J)+1 + IF((KF.EQ.4).OR.(KF.EQ.6)) ICG(I,N)=ICG(I,J)-1 + IF(KF.EQ.5) ICG(I,N)=ICG(I,J)-2 + IF(KF.EQ.2) ICG(I,N)=ICG(I,J)+2 + ENDIF + 30 CONTINUE + 40 CONTINUE + 45 CONTINUE + ICHOIX = 1 + CADI = .FALSE. + IF(IPAR.GT.2) THEN + CADI = .TRUE. + ICHOIX = 3 + IPAR = IPAR - 2 + ENDIF + NELEMW = -1 + NELEMX = -1 + NELEMY = -1 + DO 190 IWXY = 1,ICHOIX + DO 51 IY = 1,7 + DO 50 IX = 1,LX + NIK(IWXY,IY,IX) = 0 + 50 CONTINUE + 51 CONTINUE + IF(NCODE(1).EQ.7) THEN + DO 60 J = 1,LX + IF(MAT(J).LE.0) GO TO 60 + DO 55 KF = 1,6 + N = NEIGHB(J,KF,9,LX,POIDS) + IF((N.GT.LX).OR.(MAT(N).LE.0)) THEN + NIK(IWXY,ICO(KF,2*IWXY-1),J) = -1 + NIK(IWXY,ICO(KF,2*IWXY),J) = -1 + ENDIF + 55 CONTINUE + 60 CONTINUE + ENDIF + IF(IWXY.EQ.2.OR.IWXY.EQ.3) M1 = M1 + NC - 1 + CALL BIVPER(M1,IWXY,LX,LX,IPER,IENV) + DO 65 I = 1,LX + NWXY(IPER(I)) = I + 65 CONTINUE + NELEM = 1 + DO 70 I = 1,NC + IV = NWXY(I) + IF(MAT(IV).LE.0) GO TO 70 + IF(NIK(IWXY,1,IV).EQ.-1) GO TO 70 + NIK(IWXY,1,IV) = NELEM + NELEM = NELEM + 1 + 70 CONTINUE + DO 140 I = 1,LX + LIV = (I.GT.1) + IV1 = NWXY(I) + IF(MAT(IV1).LE.0) THEN + IFACE1 = IWXY + 5 + IFACE2 = IWXY + 2 + IF(IFACE1.GT.6) IFACE1 = IFACE1 - 6 + IF(IFACE2.GT.6) IFACE2 = IFACE2 - 6 + IND = NEIGHB(IV1,IFACE1,9,LX,P) + ING = NEIGHB(IV1,IFACE2,9,LX,P) + LED = (IND.GT.LX) + LEG = (ING.GT.LX) + LMD=.FALSE. + LMG=.FALSE. + IF(.NOT.LED) LMD = (MAT(IND).LE.0) + IF(.NOT.LEG) LMG = (MAT(ING).LE.0) + IF(LED.OR.LEG.OR.LMD.OR.LMG) THEN + IVK1 = -1 + IVK2 = -1 + IF((LMD.OR.LED).AND.(LMG.OR.LEG)) THEN + IVK1 = 1 + IVK2 = 0 + ELSE IF(LMD.OR.LED) THEN + IVK1 = 1 + IVK2 = 3 + ELSE IF(LMG.OR.LEG) THEN + IVK1 = 0 + IVK2 = 0 + ENDIF + IFACE3 = IWXY+IVK1+3 + IFACE4 = IWXY+IVK2+2 + IFACE5 = IWXY-IVK1+1 + IF(IFACE3.GT.6) IFACE3 = IFACE3 - 6 + IF(IFACE4.GT.6) IFACE4 = IFACE4 - 6 + IF(IFACE5.GT.6) IFACE5 = IFACE5 - 6 + IV3 = NEIGHB(IV1,IFACE3,9,LX,P) + IF((IV3.GT.LX).OR.(MAT(IV3).LE.0)) GOTO 90 + 80 IF(NIK(IWXY,1,IV3).EQ.0) THEN + NIK(IWXY,1,IV3) = NELEM + NELEM = NELEM + 1 + ENDIF + IV3 = NEIGHB(IV3,IFACE4,9,LX,P) + IF((IV3.LE.LX).AND.(MAT(IV3).GT.0)) THEN + IV5 = NEIGHB(IV3,IFACE4-1,9,LX,P) + IF((IV5.GT.LX).OR.(MAT(IV5).GT.0)) GO TO 140 + GO TO 80 + ENDIF + 90 IV4 = NEIGHB(IV1,IFACE5,9,LX,P) + IF((IV4.GT.LX).OR.(MAT(IV4).LE.0)) GOTO 140 + 100 IF(NIK(IWXY,7,IV4).EQ.0) THEN + NIK(IWXY,7,IV4) = NELEM + NELEM = NELEM + 1 + ENDIF + IV4 = NEIGHB(IV4,IFACE4,9,LX,P) + IF((IV4.LE.LX).AND.(MAT(IV4).GT.0)) GOTO 100 + ENDIF + ELSE + IF(IWXY.EQ.1) THEN + DO 110 K = 0,4 + IF((IPAR.EQ.1).AND.(K.EQ.2)) GO TO 110 + IF(LIV) THEN + IV2 = NWXY(I-1) + IF((ICG(K+2,IV1).EQ.ICG(5,IV2)) + > .AND.(MAT(IV2).GT.0)) THEN + NIK(1,2,IV1) = NIK(1,5,IV2) + NIK(1,3,IV1) = NIK(1,6,IV2) + GO TO 110 + ENDIF + ENDIF + IF(NIK(1,K+2,IV1).EQ.-1) GO TO 110 + NIK(1,K+2,IV1) = NELEM + NELEM = NELEM + 1 + 110 CONTINUE + ELSE IF(IWXY.EQ.2) THEN + DO 120 K = 0,4 + IF((IPAR.EQ.1).AND.(K.EQ.2)) GO TO 120 + IF(LIV) THEN + IV2 = NWXY(I-1) + IF((ICG(K+1,IV1).EQ.ICG(6,IV2)) + > .AND.(ICG(K+8,IV1).EQ.ICG(13,IV2)) + > .AND.(MAT(IV2).GT.0)) THEN + NIK(2,2,IV1) = NIK(2,5,IV2) + GO TO 120 + ELSE IF((ICG(K+1,IV1).EQ.ICG(7,IV2)) + > .AND.(ICG(K+8,IV1).EQ.ICG(14,IV2)) + > .AND.(MAT(IV2).GT.0)) THEN + NIK(2,3,IV1) = NIK(2,6,IV2) + GO TO 120 + ENDIF + ENDIF + IF(NIK(2,K+2,IV1).EQ.-1) GO TO 120 + NIK(2,K+2,IV1) = NELEM + NELEM = NELEM + 1 + 120 CONTINUE + ELSE IF(IWXY.EQ.3) THEN + LK = 1 + DO 130 K = 5,1,-1 + LK = LK + 1 + IF((IPAR.EQ.1).AND.(LK.EQ.4)) GO TO 130 + IF(LIV) THEN + IV2 = NWXY(I-1) + IF((ICG(K,IV1).EQ.ICG(7,IV2)) + > .AND.(ICG(K+7,IV1).EQ.ICG(14,IV2)) + > .AND.(MAT(IV2).GT.0)) THEN + NIK(3,2,IV1) = NIK(3,5,IV2) + GO TO 130 + ELSE IF((ICG(K-3,IV1).EQ.ICG(3,IV2)) + > .AND.(ICG(K+4,IV1).EQ.ICG(10,IV2)) + > .AND.(MAT(IV2).GT.0)) THEN + NIK(3,3,IV1) = NIK(3,6,IV2) + GO TO 130 + ENDIF + ENDIF + IF(NIK(3,LK,IV1).EQ.-1) GO TO 130 + NIK(3,LK,IV1) = NELEM + NELEM = NELEM + 1 + 130 CONTINUE + ENDIF + ENDIF + 140 CONTINUE + DO 160 I = 1,LX + IV = NWXY(I) + IF(MAT(IV).LE.0) GO TO 160 + DO 150 K = 1,2 + IFACE = K+IWXY-1 + IF(IFACE.GT.6) IFACE = IFACE - 6 + INE = NEIGHB(IV,IFACE,9,LX,P) + IF((INE.GT.LX).OR.(MAT(INE).LE.0)) GO TO 150 + IF(K.EQ.1) NIK(IWXY,1,IV) = NIK(IWXY,6,INE) + IF(K.EQ.2) NIK(IWXY,1,IV) = NIK(IWXY,3,INE) + 150 CONTINUE + 160 CONTINUE + DO 180 I = 1,LX + IV = NWXY(I) + IF(MAT(IV).LE.0) GO TO 180 + LC1 = .FALSE. + LIV = .TRUE. + DO 170 K = 4,5 + IFACE = K+IWXY-1 + IF(IFACE.GT.6) IFACE = IFACE - 6 + INE = NEIGHB(IV,IFACE,9,LX,P) + IF((INE.GT.LX).OR.(MAT(INE).LE.0)) THEN + IF(K.EQ.4) LC1 = .TRUE. + IF(NIK(IWXY,7,IV).EQ.-1) GO TO 170 + IF(LC1.AND.K.EQ.5.AND.(NIK(IWXY,7,IV).EQ.0)) THEN + NIK(IWXY,7,IV) = NELEM + NELEM = NELEM + 1 + ENDIF + ELSE + IF(K.EQ.4) THEN + LIV = .FALSE. + NIK(IWXY,7,IV) = NIK(IWXY,2,INE) + ENDIF + IF(K.EQ.5.AND.LIV) NIK(IWXY,7,IV)=NIK(IWXY,5,INE) + ENDIF + 170 CONTINUE + 180 CONTINUE + IF(IWXY.EQ.1) NELEMW = NELEM - 1 + IF(IWXY.EQ.2) NELEMX = NELEM - 1 + IF(IWXY.EQ.3) NELEMY = NELEM - 1 + 190 CONTINUE + MEL = 0 + NPT = NELEM -1 + IF(ICHOIX.EQ.3) THEN + IF((NELEMW.NE.NELEMX).OR.(NELEMW.NE.NELEMY)) THEN + CALL XABORT('TRIHEX: ECHEC DE LA NUMEROTATION.') + ENDIF + ALLOCATE(IDX(NPT),IDY(NPT)) + DO 200 I = 1,LX + IF(MAT(I).LE.0) GO TO 200 + DO 195 J = 1,7 + IF((IPAR.EQ.1).AND.(J.EQ.4)) GO TO 195 + IF(NIK(1,J,I).EQ.-1) GO TO 195 + IDX(NIK(1,J,I)) = NIK(2,IRO(1,J),I) + IDY(NIK(1,J,I)) = NIK(3,IRO(2,J),I) + 195 CONTINUE + 200 CONTINUE + CALL LCMPUT(IPTRK,'ILX',NPT,1,IDX) + CALL LCMPUT(IPTRK,'ILY',NPT,1,IDY) + DEALLOCATE(IDY,IDX) + ENDIF + NINC = 6 + IF(CADI) NINC = 12 + IF(IPAR.EQ.2) NINC = 7 + IF((IPAR.EQ.2).AND.CADI) NINC = 14 + LNC1 = .FALSE. + LNC2 = .FALSE. + KNZ = 0 + IF(LZ.GT.1) KNZ = NPT + IF(CADI.AND.(LZ.GT.1)) CALL LCMPUT(IPTRK,'NCODE',6,1,NCODE) + IF((LZ.GT.1).AND.((NCODE(5).EQ.7).OR.(NCODE(6).EQ.7))) THEN + LNC1 = (NCODE(5).EQ.7) + LNC2 = (NCODE(6).EQ.7) + IF(LNC1) IZI = 1 + IF(LNC2) IZS = 1 + IF(LNC1.AND.LNC2) THEN + IZE = 1 + IZS = 1 + IZI = 0 + ENDIF + ENDIF + DO 230 MZ = 1, LZ + KEL = 0 + DO 220 MX = 1, LX + IF(MAT(MX).LE.0) GO TO 220 + KEL = KEL + 1 + ML = IISS(KEL) + IJX = 1 + DO 210 JX = 1,7 + KN(MEL+IJX) = 0 + IF(CADI) KN(MEL+IJX+NINC/2) = 0 + IF((IPAR.EQ.1).AND.(JX.EQ.4)) GO TO 210 + IF(NIK(1,JX,ML).EQ.-1) GO TO 205 + IF(MZ.EQ.1.AND.LNC1) THEN + KN(MEL+IJX+NINC/2) = NIK(1,JX,ML) + GO TO 205 + ELSE IF(MZ.EQ.LZ.AND.LNC2) THEN + KN(MEL+IJX) = NIK(1,JX,ML)+(MZ-IZS-IZE)*KNZ + GO TO 205 + ENDIF + KN(MEL+IJX) = NIK(1,JX,ML)+(MZ-1-IZE-IZI)*KNZ + IF(CADI) KN(MEL+IJX+NINC/2)=NIK(1,JX,ML)+(MZ-IZE-IZI)*KNZ + 205 IJX = IJX + 1 + 210 CONTINUE + MEL = MEL + NINC + 220 CONTINUE + 230 CONTINUE + LL4 = NPT + IF(LZ.GT.1) THEN + LL4 = NPT*(LZ+1) + IF(LNC1.OR.LNC2) LL4 = NPT*LZ + IF(LNC1.AND.LNC2) LL4 = NPT*(LZ-1) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(NIK,ICG,IENV,NWXY,IPER,IISS) + RETURN + END diff --git a/Trivac/src/TRIHWW.f b/Trivac/src/TRIHWW.f new file mode 100755 index 0000000..9f049d1 --- /dev/null +++ b/Trivac/src/TRIHWW.f @@ -0,0 +1,418 @@ +*DECK TRIHWW + SUBROUTINE TRIHWW(NBMIX,NBLOS,IELEM,LL4F,LL4W,MAT,SIDE,ZZ,FRZ, + 1 QFR,IPERT,KN,SGD,XSGD,MUW,IPBBW,LC,R,V,BBW,TTF,AW,C11W) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Assembly of system matrices for a Thomas-Raviart-Schneider (dual) +* finite element method in hexagonal 3-D diffusion approximation. +* Note: system matrices should be initialized by the calling program. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* NBMIX number of mixtures. +* NBLOS number of lozenges per direction, taking into account +* mesh-splitting. +* IELEM degree of the Lagrangian finite elements: =1 (linear); +* =2 (parabolic); =3 (cubic). +* ICOL type of quadrature: =1 (analytical integration); +* =2 (Gauss-Lobatto); =3 (Gauss-Legendre). +* ISPLH mesh-splitting index. Each hexagon is splitted into 3*ISPLH**2 +* lozenges. +* LL4F number of flux components. +* LL4W number of W-directed currents. +* LL4X number of X-directed currents. +* LL4Y number of Y-directed currents. +* LL4Z number of Z-directed currents. +* MAT mixture index assigned to each element. +* SIDE side of an hexagon. +* ZZ Z-directed mesh spacings. +* FRZ volume fractions for the axial SYME boundary condition. +* QFR element-ordered boundary conditions. +* IPERT mixture permutation index. +* KN ADI permutation indices for the volumes and currents. +* SGD nuclear properties by material mixture: +* SGD(L,1)= X-oriented diffusion coefficients; +* SGD(L,2)= Y-oriented diffusion coefficients; +* SGD(L,3)= Z-oriented diffusion coefficients; +* SGD(L,4)= removal macroscopic cross section. +* XSGD one over nuclear properties. +* MUW W-directed compressed storage mode indices. +* MUX X-directed compressed storage mode indices. +* MUY Y-directed compressed storage mode indices. +* MUZ Z-directed compressed storage mode indices. +* IPBBW W-directed perdue storage indices. +* IPBBX X-directed perdue storage indices. +* IPBBY Y-directed perdue storage indices. +* IPBBZ Z-directed perdue storage indices. +* LC order of the unit matrices. +* R unit matrix. +* V unit matrix. +* BBW W-directed flux-current matrices. +* BBX X-directed flux-current matrices. +* BBY Y-directed flux-current matrices. +* BBZ Z-directed flux-current matrices. +* +*Parameters: output +* TTF flux-flux matrices. +* AW W-directed main current-current matrices. Dimensionned to +* MUW(LL4W). +* AX X-directed main current-current matrices. Dimensionned to +* MUX(LL4X). +* AY Y-directed main current-current matrices. Dimensionned to +* MUY(LL4Y). +* AZ Z-directed main current-current matrices. Dimensionned to +* MUZ(LL4Z). +* C11W W-directed main current-current matrices to be factorized. +* Dimensionned to MUW(LL4W). +* C11X X-directed main current-current matrices to be factorized. +* Dimensionned to MUX(LL4X). +* C11Y Y-directed main current-current matrices to be factorized. +* Dimensionned to MUY(LL4Y). +* C11Z Z-directed main current-current matrices to be factorized. +* Dimensionned to MUZ(LL4Z). +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NBMIX,NBLOS,IELEM,LL4F,LL4W,MAT(3,NBLOS),IPERT(NBLOS), + 1 KN(NBLOS,3+6*(IELEM+2)*IELEM**2),MUW(LL4W),IPBBW(2*IELEM,LL4W),LC + REAL SIDE,ZZ(3,NBLOS),FRZ(NBLOS),QFR(NBLOS,8),SGD(NBMIX,4), + 1 XSGD(NBMIX,4),R(LC,LC),V(LC,LC-1),TTF(LL4F),BBW(2*IELEM,LL4W), + 2 AW(*),C11W(*) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION FFF,TTTT + REAL QQ(5,5) +*---- +* W-ORIENTED COUPLINGS +*---- + DO 25 I0=1,IELEM + DO 20 J0=1,IELEM + FFF=0.0D0 + DO 10 K0=2,IELEM + FFF=FFF+V(K0,I0)*V(K0,J0)/R(K0,K0) + 10 CONTINUE + IF(ABS(FFF).LE.1.0E-6) FFF=0.0D0 + QQ(I0,J0)=REAL(FFF) + 20 CONTINUE + 25 CONTINUE +* + NELEH=(IELEM+1)*IELEM**2 + IIMAW=MUW(LL4W) + TTTT=0.5D0*SQRT(3.D00)*SIDE*SIDE + NUM=0 + DO 50 KEL=1,NBLOS + IF(IPERT(KEL).EQ.0) GO TO 50 + NUM=NUM+1 + IBM=MAT(1,IPERT(KEL)) + IF(IBM.EQ.0) GO TO 50 + DZ=ZZ(1,IPERT(KEL)) + VOL0=REAL(TTTT*DZ*FRZ(KEL)) + DINV=XSGD(IBM,1) + SIG3=SGD(IBM,3)/(DZ*DZ) + SIG4=SGD(IBM,4) + DO 34 K5=0,1 + DO 33 K4=0,IELEM-1 + DO 32 K3=0,IELEM-1 + DO 31 K2=1,IELEM+1 + KNW1=KN(NUM,3+K5*NELEH+(K4*IELEM+K3)*(IELEM+1)+K2) + INW1=ABS(KNW1) + DO 30 K1=1,IELEM+1 + KNW2=KN(NUM,3+K5*NELEH+(K4*IELEM+K3)*(IELEM+1)+K1) + INW2=ABS(KNW2) + IF((KNW2.NE.0).AND.(KNW1.NE.0)) THEN + L=MUW(INW1)-INW1+INW2 + SG=REAL(SIGN(1,KNW1)*SIGN(1,KNW2)) + IF(K1.LE.K2) AW(L)=AW(L)-(4./3.)*SG*VOL0*DINV*R(K2,K1) + IF(K1.EQ.K2) THEN + IF((K1.EQ.1).AND.(K5.EQ.0)) AW(L)=AW(L)-QFR(NUM,1) + IF((K1.EQ.IELEM+1).AND.(K5.EQ.1)) AW(L)=AW(L)-QFR(NUM,2) + ENDIF + ENDIF + 30 CONTINUE + 31 CONTINUE + 32 CONTINUE + 33 CONTINUE + 34 CONTINUE + DO 42 K3=0,IELEM-1 + DO 41 K2=0,IELEM-1 + DO 40 K1=0,IELEM-1 + JND1=(NUM-1)*IELEM**3+K3*IELEM**2+K2*IELEM+K1+1 + JND2=(KN(NUM,1)-1)*IELEM**3+K3*IELEM**2+K2*IELEM+K1+1 + JND3=(KN(NUM,2)-1)*IELEM**3+K3*IELEM**2+K2*IELEM+K1+1 + TTF(JND1)=TTF(JND1)+VOL0*SIG4+VOL0*QQ(K3+1,K3+1)*SIG3 + TTF(JND2)=TTF(JND2)+VOL0*SIG4+VOL0*QQ(K3+1,K3+1)*SIG3 + TTF(JND3)=TTF(JND3)+VOL0*SIG4+VOL0*QQ(K3+1,K3+1)*SIG3 + 40 CONTINUE + 41 CONTINUE + 42 CONTINUE + 50 CONTINUE +*---- +* COMPUTE THE W-ORIENTED SYSTEM MATRIX AFTER FLUX ELIMINATION +*---- + DO 60 I0=1,IIMAW + C11W(I0)=-AW(I0) + 60 CONTINUE + MUIM1=0 + DO 90 I=1,LL4W + MUI=MUW(I) + DO 80 J=I-(MUI-MUIM1)+1,I + KEY=MUI-I+J + DO 75 I0=1,2*IELEM + II=IPBBW(I0,I) + IF(II.EQ.0) GO TO 80 + DO 70 J0=1,2*IELEM + JJ=IPBBW(J0,J) + IF(II.EQ.JJ) C11W(KEY)=C11W(KEY)+BBW(I0,I)*BBW(J0,J)/TTF(II) + 70 CONTINUE + 75 CONTINUE + 80 CONTINUE + MUIM1=MUI + 90 CONTINUE + RETURN + END +* + SUBROUTINE TRIHWX(NBMIX,NBLOS,IELEM,LL4F,LL4W,LL4X,MAT,SIDE,ZZ, + 1 FRZ,QFR,IPERT,KN,XSGD,MUX,IPBBX,LC,R,BBX,TTF,AX,C11X) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NBMIX,NBLOS,IELEM,LL4F,LL4W,LL4X,MAT(3,NBLOS), + 1 MUX(LL4X),IPBBX(2*IELEM,LL4X),LC,IPERT(NBLOS), + 2 KN(NBLOS,3+6*(IELEM+2)*IELEM**2) + REAL SIDE,ZZ(3,NBLOS),FRZ(NBLOS),QFR(NBLOS,8),XSGD(NBMIX,4), + 1 R(LC,LC),TTF(LL4F),BBX(2*IELEM,LL4X),AX(*),C11X(*) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION TTTT +*---- +* X-ORIENTED COUPLINGS +*---- + NELEH=(IELEM+1)*IELEM**2 + IIMAX=MUX(LL4X) + TTTT=0.5D0*SQRT(3.D00)*SIDE*SIDE + NUM=0 + DO 120 KEL=1,NBLOS + IF(IPERT(KEL).EQ.0) GO TO 120 + NUM=NUM+1 + IBM=MAT(1,IPERT(KEL)) + IF(IBM.EQ.0) GO TO 120 + VOL0=REAL(TTTT*ZZ(1,IPERT(KEL))*FRZ(KEL)) + DINV=XSGD(IBM,1) + DO 114 K5=0,1 + DO 113 K4=0,IELEM-1 + DO 112 K3=0,IELEM-1 + DO 111 K2=1,IELEM+1 + KNX1=KN(NUM,3+(K5+2)*NELEH+(K4*IELEM+K3)*(IELEM+1)+K2) + INX1=ABS(KNX1)-LL4W + DO 110 K1=1,IELEM+1 + KNX2=KN(NUM,3+(K5+2)*NELEH+(K4*IELEM+K3)*(IELEM+1)+K1) + INX2=ABS(KNX2)-LL4W + IF((KNX2.NE.0).AND.(KNX1.NE.0)) THEN + L=MUX(INX1)-INX1+INX2 + SG=REAL(SIGN(1,KNX1)*SIGN(1,KNX2)) + IF(K1.LE.K2) AX(L)=AX(L)-(4./3.)*SG*VOL0*DINV*R(K2,K1) + IF(K1.EQ.K2) THEN + IF((K1.EQ.1).AND.(K5.EQ.0)) AX(L)=AX(L)-QFR(NUM,3) + IF((K1.EQ.IELEM+1).AND.(K5.EQ.1)) AX(L)=AX(L)-QFR(NUM,4) + ENDIF + ENDIF + 110 CONTINUE + 111 CONTINUE + 112 CONTINUE + 113 CONTINUE + 114 CONTINUE + 120 CONTINUE +*---- +* COMPUTE THE X-ORIENTED SYSTEM MATRIX AFTER FLUX ELIMINATION +*---- + DO 130 I0=1,IIMAX + C11X(I0)=-AX(I0) + 130 CONTINUE + MUIM1=0 + DO 160 I=1,LL4X + MUI=MUX(I) + DO 150 J=I-(MUI-MUIM1)+1,I + KEY=MUI-I+J + DO 145 I0=1,2*IELEM + II=IPBBX(I0,I) + IF(II.EQ.0) GO TO 150 + DO 140 J0=1,2*IELEM + JJ=IPBBX(J0,J) + IF(II.EQ.JJ) C11X(KEY)=C11X(KEY)+BBX(I0,I)*BBX(J0,J)/TTF(II) + 140 CONTINUE + 145 CONTINUE + 150 CONTINUE + MUIM1=MUI + 160 CONTINUE + RETURN + END +* + SUBROUTINE TRIHWY(NBMIX,NBLOS,IELEM,LL4F,LL4W,LL4X,LL4Y,MAT, + 1 SIDE,ZZ,FRZ,QFR,IPERT,KN,XSGD,MUY,IPBBY,LC,R,BBY,TTF,AY,C11Y) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NBMIX,NBLOS,IELEM,LL4F,LL4W,LL4X,LL4Y,MAT(3,NBLOS), + 1 MUY(LL4Y),IPBBY(2*IELEM,LL4Y),LC,IPERT(NBLOS), + 2 KN(NBLOS,3+6*(IELEM+2)*IELEM**2) + REAL SIDE,ZZ(3,NBLOS),FRZ(NBLOS),QFR(NBLOS,8),XSGD(NBMIX,4), + 1 R(LC,LC),TTF(LL4F),BBY(2*IELEM,LL4Y),AY(*),C11Y(*) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION TTTT +*---- +* Y-ORIENTED COUPLINGS +*---- + NELEH=(IELEM+1)*IELEM**2 + IIMAY=MUY(LL4Y) + TTTT=0.5D0*SQRT(3.D00)*SIDE*SIDE + NUM=0 + DO 220 KEL=1,NBLOS + IF(IPERT(KEL).EQ.0) GO TO 220 + NUM=NUM+1 + IBM=MAT(1,IPERT(KEL)) + IF(IBM.EQ.0) GO TO 220 + VOL0=REAL(TTTT*ZZ(1,IPERT(KEL))*FRZ(KEL)) + DINV=XSGD(IBM,1) + DO 214 K5=0,1 + DO 213 K4=0,IELEM-1 + DO 212 K3=0,IELEM-1 + DO 211 K2=1,IELEM+1 + KNY1=KN(NUM,3+(K5+4)*NELEH+(K4*IELEM+K3)*(IELEM+1)+K2) + INY1=ABS(KNY1)-LL4W-LL4X + DO 210 K1=1,IELEM+1 + KNY2=KN(NUM,3+(K5+4)*NELEH+(K4*IELEM+K3)*(IELEM+1)+K1) + INY2=ABS(KNY2)-LL4W-LL4X + IF((KNY2.NE.0).AND.(KNY1.NE.0)) THEN + L=MUY(INY1)-INY1+INY2 + SG=REAL(SIGN(1,KNY1)*SIGN(1,KNY2)) + IF(K1.LE.K2) AY(L)=AY(L)-(4./3.)*SG*VOL0*DINV*R(K2,K1) + IF(K1.EQ.K2) THEN + IF((K1.EQ.1).AND.(K5.EQ.0)) AY(L)=AY(L)-QFR(NUM,5) + IF((K1.EQ.IELEM+1).AND.(K5.EQ.1)) AY(L)=AY(L)-QFR(NUM,6) + ENDIF + ENDIF + 210 CONTINUE + 211 CONTINUE + 212 CONTINUE + 213 CONTINUE + 214 CONTINUE + 220 CONTINUE +*---- +* COMPUTE THE Y-ORIENTED SYSTEM MATRIX AFTER FLUX ELIMINATION +*---- + DO 230 I0=1,IIMAY + C11Y(I0)=-AY(I0) + 230 CONTINUE + MUIM1=0 + DO 260 I=1,LL4Y + MUI=MUY(I) + DO 250 J=I-(MUI-MUIM1)+1,I + KEY=MUI-I+J + DO 245 I0=1,2*IELEM + II=IPBBY(I0,I) + IF(II.EQ.0) GO TO 250 + DO 240 J0=1,2*IELEM + JJ=IPBBY(J0,J) + IF(II.EQ.JJ) C11Y(KEY)=C11Y(KEY)+BBY(I0,I)*BBY(J0,J)/TTF(II) + 240 CONTINUE + 245 CONTINUE + 250 CONTINUE + MUIM1=MUI + 260 CONTINUE + RETURN + END +* + SUBROUTINE TRIHWZ(NBMIX,NBLOS,IELEM,ICOL,LL4F,LL4W,LL4X,LL4Y, + 1 LL4Z,MAT,SIDE,ZZ,FRZ,QFR,IPERT,KN,XSGD,MUZ,IPBBZ,LC,R,BBZ,TTF, + 2 AZ,C11Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NBMIX,NBLOS,IELEM,ICOL,LL4F,LL4W,LL4X,LL4Y,LL4Z, + 1 MAT(3,NBLOS),MUZ(LL4Z),IPBBZ(2*IELEM,LL4Z),LC,IPERT(NBLOS), + 2 KN(NBLOS,3+6*(IELEM+2)*IELEM**2) + REAL SIDE,ZZ(3,NBLOS),FRZ(NBLOS),QFR(NBLOS,8),XSGD(NBMIX,4), + 1 R(LC,LC),TTF(LL4F),BBZ(2*IELEM,LL4Z),AZ(*),C11Z(*) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION TTTT +*---- +* Z-ORIENTED COUPLINGS +*---- + NELEH=(IELEM+1)*IELEM**2 + IIMAZ=MUZ(LL4Z) + TTTT=0.5D0*SQRT(3.D00)*SIDE*SIDE + NUM=0 + DO 340 KEL=1,NBLOS + IF(IPERT(KEL).EQ.0) GO TO 340 + NUM=NUM+1 + IBM=MAT(1,IPERT(KEL)) + IF(IBM.EQ.0) GO TO 340 + VOL0=REAL(TTTT*ZZ(1,IPERT(KEL))*FRZ(KEL)) + DINV=XSGD(IBM,3) + DO 292 K5=0,2 ! THREE LOZENGES PER HEXAGON + DO 291 K2=0,IELEM-1 + DO 290 K1=0,IELEM-1 + KNZ1=KN(NUM,3+6*NELEH+2*K5*IELEM**2+K2*IELEM+K1+1) + KNZ2=KN(NUM,3+6*NELEH+(2*K5+1)*IELEM**2+K2*IELEM+K1+1) + INZ1=ABS(KNZ1)-LL4W-LL4X-LL4Y + INZ2=ABS(KNZ2)-LL4W-LL4X-LL4Y + IF(KNZ1.NE.0) THEN + KEY=MUZ(INZ1) + AZ(KEY)=AZ(KEY)-VOL0*R(1,1)*DINV-QFR(NUM,7) + ENDIF + IF(KNZ2.NE.0) THEN + KEY=MUZ(INZ2) + AZ(KEY)=AZ(KEY)-VOL0*R(IELEM+1,IELEM+1)*DINV-QFR(NUM,8) + ENDIF + IF((ICOL.NE.2).AND.(KNZ1.NE.0).AND.(KNZ2.NE.0)) THEN + IF(INZ2.GT.INZ1) KEY=MUZ(INZ2)-INZ2+INZ1 + IF(INZ2.LE.INZ1) KEY=MUZ(INZ1)-INZ1+INZ2 + SG=REAL(SIGN(1,KNZ1)*SIGN(1,KNZ2)) + IF(INZ1.EQ.INZ2) SG=2.0*SG + AZ(KEY)=AZ(KEY)-SG*VOL0*R(IELEM+1,1)*DINV + ENDIF + 290 CONTINUE + 291 CONTINUE + 292 CONTINUE + 340 CONTINUE +* + DO 350 I0=1,IIMAZ + C11Z(I0)=-AZ(I0) + 350 CONTINUE + MUIM1=0 + DO 380 I=1,LL4Z + MUI=MUZ(I) + DO 370 J=I-(MUI-MUIM1)+1,I + KEY=MUI-I+J + DO 365 I0=1,2*IELEM + II=IPBBZ(I0,I) + IF(II.EQ.0) GO TO 370 + DO 360 J0=1,2*IELEM + JJ=IPBBZ(J0,J) + IF(II.EQ.JJ) C11Z(KEY)=C11Z(KEY)+BBZ(I0,I)*BBZ(J0,J)/TTF(II) + 360 CONTINUE + 365 CONTINUE + 370 CONTINUE + MUIM1=MUI + 380 CONTINUE + RETURN + END diff --git a/Trivac/src/TRIKAX.f b/Trivac/src/TRIKAX.f new file mode 100755 index 0000000..cd3d63f --- /dev/null +++ b/Trivac/src/TRIKAX.f @@ -0,0 +1,180 @@ +*DECK TRIKAX + SUBROUTINE TRIKAX (IDIM,NCODE,XXX,YYY,ZZZ,LX,LY,LZ,IAXIS,CENTER) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculates the center of the external cylinder outside elements. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* IDIM number of dimensions. +* XXX Cartesian coordinates of the domain along the X-axis. +* YYY Cartesian coordinates of the domain along the Y-axis. +* ZZZ Cartesian coordinates of the domain along the Z-axis. +* LX number of parallelepipeds along the X-axis after mesh- +* splitting. +* LY number of parallelepipeds along the Y-axis. +* LZ number of parallelepipeds along the Z-axis. +* NCODE boundary condition relative to each side of the domain. +* +*Parameters: output +* CENTER coordinates for center of cylinder. +* IAXIS orientation of the cylinder axis: = 0 no cylinder at all; +* = 1,2,3 axis of the cylinder. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IDIM,NCODE(6),LX,LY,LZ,IAXIS + REAL XXX(LX+1),YYY(LY+1),ZZZ(LZ+1),CENTER(3) +*---- +* LOCAL VARIABLES +*---- + INTEGER IFC(3) +* + IAXIS = 0 + DO 10 IC= 1,3 + CENTER(IC)= 0.0 + IFC(IC)= 0 + 10 CONTINUE + IF( IDIM.GE.2 )THEN +*---- +* "X" AXIS STUDY +*---- + IF( NCODE(1).EQ.20.OR.NCODE(2).EQ.20 ) THEN +* THERE IS AT LEAST ONE "X" CIRCULAR B.C. + IFC(1)= 1 + IF( NCODE(1).EQ.20.AND.NCODE(2).EQ.20 )THEN +* THERE IS TWO "X" CIRCULAR B.C. + CENTER(1)= 0.5 * (XXX(LX+1) + XXX(1)) +* TAKE THE "X" CENTER AT THE MIDDLE OF ALL ELEMENTS + ELSEIF( NCODE(1).EQ.5.OR.NCODE(2).EQ.5 )THEN +* THERE IS ONE "X" SYMMETRIC B.C. + IF( NCODE(1).EQ.5 )THEN +* "X -" SYMMETRIC B.C. + CENTER(1)= 0.5 * (XXX(2) + XXX(1)) +* TAKE THE "X" CENTER AT THE MIDDLE OF FIRST ELEMENT + ELSE +* "X +" SYMMETRIC B.C. + CENTER(1)= 0.5 * (XXX(LX+1) + XXX(LX)) +* TAKE THE "X" CENTER AT THE MIDDLE OF LAST ELEMENT + ENDIF + ELSE +* ALL OTHER CASES + IF( NCODE(1).EQ.20 )THEN +* "X -" CIRCULAR B.C. + CENTER(1)= XXX(LX+1) +* TAKE THE "X" CENTER AT THE END OF LAST ELEMENT + ELSE +* "X +" SYMMETRIC B.C. + CENTER(1)= XXX(1) +* TAKE THE "X" CENTER AT THE BEGIN OF FIRST ELEMENT + ENDIF + ENDIF + ENDIF +*---- +* "Y" AXIS STUDY +*---- + IF( NCODE(3).EQ.20.OR.NCODE(4).EQ.20 ) THEN + IFC(2)= 1 +* THERE IS AT LEAST ONE "Y" CIRCULAR B.C. + IF( NCODE(3).EQ.20.AND.NCODE(4).EQ.20 )THEN +* THERE IS TWO "Y" CIRCULAR B.C. + CENTER(2)= 0.5 * (YYY(LY+1) + YYY(1)) +* TAKE THE "Y" CENTER AT THE MIDDLE OF ALL ELEMENTS + ELSEIF( NCODE(3).EQ.5.OR.NCODE(4).EQ.5 )THEN +* THERE IS ONE "Y" SYMMETRIC B.C. + IF( NCODE(3).EQ.5 )THEN +* "Y -" SYMMETRIC B.C. + CENTER(2)= 0.5 * (YYY(2) + YYY(1)) +* TAKE THE "Y" CENTER AT THE MIDDLE OF FIRST ELEMENT + ELSE +* "Y +" SYMMETRIC B.C. + CENTER(2)= 0.5 * (YYY(LY+1) + YYY(LY)) +* TAKE THE "Y" CENTER AT THE MIDDLE OF LAST ELEMENT + ENDIF + ELSE +* ALL OTHER CASES + IF( NCODE(3).EQ.20 )THEN +* "Y -" CIRCULAR B.C. + CENTER(2)= YYY(LY+1) +* TAKE THE "Y" CENTER AT THE END OF LAST ELEMENT + ELSE +* "Y +" SYMMETRIC B.C. + CENTER(2)= YYY(1) +* TAKE THE "Y" CENTER AT THE BEGIN OF FIRST ELEMENT + ENDIF + ENDIF + ENDIF + IF( IDIM.EQ.2 )THEN + NONC = IFC(1) + IFC(2) + IF( NONC.GT.0 )THEN + IAXIS = 3 + ENDIF + ELSE +*---- +* "Z" AXIS STUDY +*---- + IF( NCODE(5).EQ.20.OR.NCODE(6).EQ.20 ) THEN +* THERE IS AT LEAST ONE "Y" CIRCULAR B.C. + IFC(3)= 1 + IF( NCODE(5).EQ.20.AND.NCODE(6).EQ.20 )THEN +* THERE IS TWO "Z" CIRCULAR B.C. + CENTER(3)= 0.5 * (ZZZ(LZ+1) + ZZZ(1)) +* TAKE THE "Z" CENTER AT THE MIDDLE OF ALL ELEMENTS + ELSEIF( NCODE(5).EQ.5.OR.NCODE(6).EQ.5 )THEN +* THERE IS ONE "Z" SYMMETRIC B.C. + IF( NCODE(5).EQ.5 )THEN +* "Z -" SYMMETRIC B.C. + CENTER(3)= 0.5 * (ZZZ(2) + ZZZ(1)) +* TAKE THE "Z" CENTER AT THE MIDDLE OF FIRST ELEMENT + ELSE +* "Z +" SYMMETRIC B.C. + CENTER(3)= 0.5 * (ZZZ(LZ+1) + ZZZ(LZ)) +* TAKE THE "Z" CENTER AT THE MIDDLE OF LAST ELEMENT + ENDIF + ELSE +* ALL OTHER CASES + IF( NCODE(5).EQ.20 )THEN +* "Z -" CIRCULAR B.C. + CENTER(3)= ZZZ(LZ+1) +* TAKE THE "Z" CENTER AT THE END OF LAST ELEMENT + ELSE +* "Z +" SYMMETRIC B.C. + CENTER(3)= ZZZ(1) +* TAKE THE "Z" CENTER AT THE BEGIN OF FIRST ELEMENT + ENDIF + ENDIF + ENDIF +* +* DETERMINE PRINCIPAL AXIS + NONC= IFC(1) + IFC(2) + IFC(3) + IF( NONC.GT.0 )THEN + IF( NONC.EQ.2 )THEN + IF( IFC(1).EQ.0 ) IAXIS = 1 + IF( IFC(2).EQ.0 ) IAXIS = 2 + IF( IFC(3).EQ.0 ) IAXIS = 3 + ELSE + WRITE(6,1000) + CALL XABORT('TRIKAX: ALGORITHM FAILURE.') + ENDIF + ENDIF + ENDIF + ENDIF + RETURN + 1000 FORMAT(/1X,'*** NOT POSSIBLE TO DETERMINE THE PRINCIPAL AXIS' + 1 /1X,'***' + 2 /1X,'*** N O C Y L I N D R I C A L B E D O S' + 3 /1X,'***') + END diff --git a/Trivac/src/TRIMTD.f b/Trivac/src/TRIMTD.f new file mode 100755 index 0000000..5b36429 --- /dev/null +++ b/Trivac/src/TRIMTD.f @@ -0,0 +1,73 @@ +*DECK TRIMTD + SUBROUTINE TRIMTD(ISPLH,MAXMIX,NEL,LL4,VOL,MAT,SGD,KN,IPW,VEC) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Assembly of a diagonal system matrix for a mesh centered finite +* difference discretization in hexagonal geometry (triangular submeshs). +* Note: system matrix should be initialized by the calling program. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Benaboud +* +*Parameters: input +* ISPLH related to the triangular submesh. The number of triangles is +* 6*(ISPLH-1)**2. +* MAXMIX size of array SGD. +* NEL total number of finite elements. +* LL4 order of the system matrices. +* VOL volume of each element. +* MAT mixture index assigned to each hexagon. +* SGD nuclear properties per material mixtures. +* KN element-ordered unknown list. +* IPW permutation matrices. +* +*Parameters: output +* VEC diagonal system matrix. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER ISPLH,MAXMIX,NEL,LL4,MAT(NEL),KN(NEL*(18*(ISPLH-1)**2+8)), + 1 IPW(LL4) + REAL VOL(NEL),SGD(MAXMIX),VEC(LL4) +*---- +* ASSEMBLY OF DIAGONAL MATRIX VEC +*---- + NUM1 = 0 + NTPH = 6 * (ISPLH-1)**2 + NTPL = 1 + 2 * (ISPLH-1) + NVT1 = NTPL + 2 * (ISPLH-2) + NTPH / 2 + NVT2 = NTPH - NTPL - (ISPLH-4) * (NTPL+2) + NVT3 = NTPH - (ISPLH-4) * NTPL + IVAL = 3*NTPH+8 + IF(ISPLH.EQ.3) NVT2 = NTPH + IF(ISPLH.LE.3) ISAU = 2*(ISPLH-2) + IF(ISPLH.GE.4) ISAU = 6*(ISPLH-3) + ICR = ISAU*(1+2*(ISPLH-2)) + DO 40 K=1,NEL + L = MAT(K) + IF(L.EQ.0) GO TO 40 + VOL0 = VOL(K)/NTPH + IF(VOL0.EQ.0.0) GO TO 30 + DO 20 I = 1,NTPH +* + CALL TRINEI (3,1,1,ISPLH,ICR,I,KK1,KK2,KK3,KEL,IQF,NUM1, + > NTPH,NTPL,NVT1,NVT2,NVT3,IVAL,KN) +* + IND1=IPW(KEL) + VEC(IND1)=VEC(IND1)+SGD(L)*VOL0 + 20 CONTINUE + 30 NUM1=NUM1+IVAL + 40 CONTINUE + RETURN + END diff --git a/Trivac/src/TRIMTW.f b/Trivac/src/TRIMTW.f new file mode 100755 index 0000000..5fd6d9b --- /dev/null +++ b/Trivac/src/TRIMTW.f @@ -0,0 +1,383 @@ +*DECK TRIMTW + SUBROUTINE TRIMTW(ISPLH,IR,NEL,LL4,VOL,MAT,MATN,SGD,XSGD,SIDE, + 1 ZZ,KN,QFR,MUW,IPW,IPR,A11W) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Assembly of system matrices for a mesh centered finite difference +* discretization in hexagonal geometry (triangular sub meshs). +* Note: system matrices should be initialized by the calling program. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Benaboud +* +*Parameters: input +* ISPLH used to compute the number of triangles as 6*(ISPLH-1)**2. +* IR first dimension of matrix SGD. +* NEL total number of finite elements. +* LL4 order of system matrices. +* VOL volume of each element. +* MAT mixture index assigned to each hexagon. +* MATN mixture index assigned to each triangle. +* SGD nuclear properties per material mixtures: +* SGD(L,1): W-, X-, and Y-oriented diffusion coefficients; +* SGD(L,3): Z-oriented diffusion coefficients; +* SGD(L,4): removal macroscopic cross section. +* XSGD nuclear properties (IPR=0), derivatives (IPR=1) or first +* variations (IPR=2 or 3) of nuclear properties per material +* mixture. +* SIDE side of an hexagon. +* ZZ Z-directed mesh spacings. +* KN element-ordered unknown list. +* QFR element-ordered boundary conditions. +* MUW W-oriented compressed storage mode indices. +* MUX X-oriented compressed storage mode indices. +* MUY Y-oriented compressed storage mode indices. +* MUZ Z-oriented compressed storage mode indices. +* IPW W-oriented permutation matrices. +* IPX X-oriented permutation matrices. +* IPY Y-oriented permutation matrices. +* IPZ Z-oriented permutation matrices. +* IPR type of calculation: +* =0: compute the system matrices; +* =1: compute the derivative of system matrices; +* =2 or =3: compute the variation of system matrices. +* +*Parameters: output +* A11W W-oriented matrices corresponding to the divergence (i.e +* leakage) and removal terms. Dimensionned to MUW(LL4). +* A11X X-oriented matrices corresponding to the divergence (i.e +* leakage) and removal terms. Dimensionned to MUX(LL4). +* A11Y Y-oriented matrices corresponding to the divergence (i.e +* leakage) and removal terms. Dimensionned to MUY(LL4). +* A11Z Z-oriented matrices corresponding to the divergence (i.e +* leakage) and removal terms. Dimensionned to MUZ(LL4). +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER ISPLH,IR,NEL,LL4,MAT(NEL),MATN(LL4), + 1 KN((18*(ISPLH-1)**2+3)*NEL),MUW(LL4),IPW(LL4),IPR + REAL VOL(NEL),SGD(IR,4),XSGD(IR,4),SIDE,ZZ(NEL),QFR(8*NEL), + 1 A11W(*) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION A1(5),VAR1 + INTEGER, DIMENSION(:), ALLOCATABLE :: IWRK +*---- +* ASSEMBLY OF MATRIX A11W +*---- + NUM1 = 0 + NUM2 = 0 + NTPH = 6 * (ISPLH-1)**2 + NTPL = 1 + 2 * (ISPLH-1) + NVT1 = NTPL + 2 * (ISPLH-2) + NTPH / 2 + NVT2 = NTPH - NTPL - (ISPLH-4) * (NTPL+2) + NVT3 = NTPH - (ISPLH-4) * NTPL + IVAL = 3*NTPH+8 + IF(ISPLH.EQ.3) NVT2 = NTPH + IF(ISPLH.LE.3) ISAU = 2*(ISPLH-2) + IF(ISPLH.GE.4) ISAU = 6*(ISPLH-3) + ICR = ISAU*(1+2*(ISPLH-2)) + ALLOCATE(IWRK(NEL)) + MEL = 0 + DO 10 M=1,NEL + IF(MAT(M).LE.0) GO TO 10 + MEL = MEL + 1 + IWRK(MEL) = M + 10 CONTINUE + DO 40 K=1,NEL + L = MAT(K) + IF(L.EQ.0) GO TO 40 + VOL0 = VOL(K)/NTPH + IF(VOL0.EQ.0.0) GO TO 30 + KK4=KN(NUM1+3*NTPH+7) + KK5=KN(NUM1+3*NTPH+8) + IF(KK4.GT.0) KK4 = IWRK(KK4) + IF(KK5.GT.0) KK5 = IWRK(KK5) + DO 20 I = 1,NTPH +* + CALL TRINEI (3,1,1,ISPLH,ICR,I,KK1,KK2,KK3,KEL,IQF,NUM1, + > NTPH,NTPL,NVT1,NVT2,NVT3,IVAL,KN) +* + CALL TRITCO (NEL,LL4,ISPLH,IR,IQF,K,KK1,KK2,KK3,KK4,KK5, + > VOL0,MAT,MATN,SGD(1,1),XSGD(1,1),SIDE,ZZ,QFR(NUM2+1),IPR,A1) +* + INW1=IPW(KEL) + KEY0=MUW(INW1)-INW1 + IF(KK1.GT.0) THEN + INW2=IPW(KK1) + IF(INW2.LT.INW1) THEN + KEY=KEY0+INW2 + A11W(KEY)=A11W(KEY)-REAL(A1(1))/2. + ENDIF + ENDIF + IF(KK2.GT.0) THEN + INW2=IPW(KK2) + IF(INW2.LT.INW1) THEN + KEY=KEY0+INW2 + A11W(KEY)=A11W(KEY)-REAL(A1(2))/2. + ENDIF + ENDIF + KEY=KEY0+INW1 + VAR1 = A1(1)+A1(2)+A1(3)+A1(4)+A1(5) + A11W(KEY)=A11W(KEY)+REAL(VAR1)+XSGD(L,4)*VOL0 + 20 CONTINUE + 30 NUM1=NUM1+IVAL + NUM2=NUM2+8 + 40 CONTINUE + DEALLOCATE(IWRK) + RETURN + END +* + SUBROUTINE TRIMTX (ISPLH,IR,NEL,LL4,VOL,MAT,MATN,SGD,XSGD,SIDE, + 1 ZZ,KN,QFR,MUX,IPX,IPR,A11X) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER ISPLH,IR,NEL,LL4,MAT(NEL),MATN(LL4), + 1 KN((18*(ISPLH-1)**2+3)*NEL),MUX(LL4),IPX(LL4),IPR + REAL VOL(NEL),SGD(IR,4),XSGD(IR,4),SIDE,ZZ(NEL),QFR(8*NEL), + 1 A11X(*) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION A1(5),VAR1 + INTEGER, DIMENSION(:), ALLOCATABLE :: IWRK +*---- +* ASSEMBLY OF MATRIX A11X +*---- + NUM1=0 + NUM2=0 + NTPH = 6*(ISPLH-1)**2 + NTPL = 1+2*(ISPLH-1) + NVT1 = NTPL + 2 * (ISPLH-2) + NTPH / 2 + NVT2 = NTPH - NTPL - (ISPLH-4) * (NTPL+2) + NVT3 = NTPH - (ISPLH-4) * NTPL + IVAL = 3*NTPH+8 + IF(ISPLH.EQ.3) NVT2 = NTPH + IF(ISPLH.LE.3) ISAU = 2*(ISPLH-2) + IF(ISPLH.GE.4) ISAU = 6*(ISPLH-3) + ICR = ISAU*(1+2*(ISPLH-2)) + ALLOCATE(IWRK(NEL)) + MEL = 0 + DO 105 M=1,NEL + IF(MAT(M).LE.0) GO TO 105 + MEL = MEL + 1 + IWRK(MEL) = M +105 CONTINUE + DO 130 K=1,NEL + L = MAT(K) + IF(L.EQ.0) GO TO 130 + VOL0 = VOL(K)/NTPH + IF(VOL0.EQ.0.0) GO TO 120 + KK4=KN(NUM1+3*NTPH+7) + KK5=KN(NUM1+3*NTPH+8) + IF(KK4.GT.0) KK4 = IWRK(KK4) + IF(KK5.GT.0) KK5 = IWRK(KK5) + DO 110 I = 1,NTPH +* + CALL TRINEI (3,2,1,ISPLH,ICR,I,KK1,KK2,KK3,KEL,IQF,NUM1, + > NTPH,NTPL,NVT1,NVT2,NVT3,IVAL,KN) +* + CALL TRITCO (NEL,LL4,ISPLH,IR,IQF,K,KK1,KK2,KK3,KK4,KK5, + > VOL0,MAT,MATN,SGD(1,1),XSGD(1,1),SIDE,ZZ,QFR(NUM2+1),IPR,A1) +* + INX1=IPX(KEL) + KEY0=MUX(INX1)-INX1 + IF(KK1.GT.0) THEN + INX2=IPX(KK1) + IF(INX2.LT.INX1) THEN + KEY=KEY0+INX2 + A11X(KEY)=A11X(KEY)-REAL(A1(1))/2. + ENDIF + ENDIF + IF(KK2.GT.0) THEN + INX2=IPX(KK2) + IF(INX2.LT.INX1) THEN + KEY=KEY0+INX2 + A11X(KEY)=A11X(KEY)-REAL(A1(2))/2. + ENDIF + ENDIF + KEY=KEY0+INX1 + VAR1 = A1(1)+A1(2)+A1(3)+A1(4)+A1(5) + A11X(KEY)=A11X(KEY)+REAL(VAR1)+XSGD(L,4)*VOL0 + 110 CONTINUE + 120 NUM1=NUM1+IVAL + NUM2=NUM2+8 + 130 CONTINUE + DEALLOCATE(IWRK) + RETURN + END +* + SUBROUTINE TRIMTY (ISPLH,IR,NEL,LL4,VOL,MAT,MATN,SGD,XSGD,SIDE, + 1 ZZ,KN,QFR,MUY,IPY,IPR,A11Y) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER ISPLH,IR,NEL,LL4,MAT(NEL),MATN(LL4), + 1 KN((18*(ISPLH-1)**2+3)*NEL),MUY(LL4),IPY(LL4),IPR + REAL VOL(NEL),SGD(IR,4),XSGD(IR,4),SIDE,ZZ(NEL),QFR(8*NEL), + 1 A11Y(*) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION A1(5),VAR1 + INTEGER, DIMENSION(:), ALLOCATABLE :: IWRK +*---- +* ASSEMBLY OF MATRIX A11Y +*---- + NUM1=0 + NUM2=0 + NTPH = 6*(ISPLH-1)**2 + NTPL = 1+2*(ISPLH-1) + NVT1 = NTPL + 2 * (ISPLH-2) + NTPH / 2 + NVT2 = NTPH - NTPL - (ISPLH-4) * (NTPL+2) + NVT3 = NTPH - (ISPLH-4) * NTPL + IVAL = 3*NTPH+8 + IF(ISPLH.EQ.3) NVT2 = NTPH + IF(ISPLH.LE.3) ISAU = 2*(ISPLH-2) + IF(ISPLH.GE.4) ISAU = 6*(ISPLH-3) + ICR = ISAU*(1+2*(ISPLH-2)) + ALLOCATE(IWRK(NEL)) + MEL = 0 + DO 205 M=1,NEL + IF(MAT(M).LE.0) GO TO 205 + MEL = MEL + 1 + IWRK(MEL) = M +205 CONTINUE + DO 230 K=1,NEL + L = MAT(K) + IF(L.EQ.0) GO TO 230 + VOL0 = VOL(K)/NTPH + IF(VOL0.EQ.0.0) GO TO 220 + KK4=KN(NUM1+3*NTPH+7) + KK5=KN(NUM1+3*NTPH+8) + IF(KK4.GT.0) KK4 = IWRK(KK4) + IF(KK5.GT.0) KK5 = IWRK(KK5) + DO 210 I = 1,NTPH +* + CALL TRINEI (3,3,1,ISPLH,ICR,I,KK1,KK2,KK3,KEL,IQF,NUM1, + > NTPH,NTPL,NVT1,NVT2,NVT3,IVAL,KN) +* + CALL TRITCO (NEL,LL4,ISPLH,IR,IQF,K,KK1,KK2,KK3,KK4,KK5, + > VOL0,MAT,MATN,SGD(1,1),XSGD(1,1),SIDE,ZZ,QFR(NUM2+1),IPR,A1) +* + INY1=IPY(KEL) + KEY0=MUY(INY1)-INY1 + IF(KK1.GT.0) THEN + INY2=IPY(KK1) + IF(INY2.LT.INY1) THEN + KEY=KEY0+INY2 + A11Y(KEY)=A11Y(KEY)-REAL(A1(1))/2. + ENDIF + ENDIF + IF(KK2.GT.0) THEN + INY2=IPY(KK2) + IF(INY2.LT.INY1) THEN + KEY=KEY0+INY2 + A11Y(KEY)=A11Y(KEY)-REAL(A1(2))/2. + ENDIF + ENDIF + KEY=KEY0+INY1 + VAR1 = A1(1)+A1(2)+A1(3)+A1(4)+A1(5) + A11Y(KEY)=A11Y(KEY)+REAL(VAR1)+XSGD(L,4)*VOL0 + 210 CONTINUE + 220 NUM1=NUM1+IVAL + NUM2=NUM2+8 + 230 CONTINUE + DEALLOCATE(IWRK) + RETURN + END +* + SUBROUTINE TRIMTZ (ISPLH,IR,NEL,LL4,VOL,MAT,MATN,SGD,XSGD,SIDE, + 1 ZZ,KN,QFR,MUZ,IPZ,IPR,A11Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER ISPLH,IR,NEL,LL4,MAT(NEL),MATN(LL4), + 1 KN((18*(ISPLH-1)**2+3)*NEL),MUZ(LL4),IPZ(LL4),IPR + REAL VOL(NEL),SGD(IR,4),XSGD(IR,4),SIDE,ZZ(NEL),QFR(8*NEL), + 1 A11Z(*) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION A1(5),VAR1 + INTEGER, DIMENSION(:), ALLOCATABLE :: IWRK +*---- +* ASSEMBLY OF MATRIX A11Z +*---- + NUM1=0 + NUM2=0 + NTPH = 6*(ISPLH-1)**2 + NTPL = 1+2*(ISPLH-1) + NVT1 = NTPL + 2 * (ISPLH-2) + NTPH / 2 + NVT2 = NTPH - NTPL - (ISPLH-4) * (NTPL+2) + NVT3 = NTPH - (ISPLH-4) * NTPL + IVAL = 3*NTPH+8 + IF(ISPLH.EQ.3) NVT2 = NTPH + IF(ISPLH.LE.3) ISAU = 2*(ISPLH-2) + IF(ISPLH.GE.4) ISAU = 6*(ISPLH-3) + ICR = ISAU*(1+2*(ISPLH-2)) + ALLOCATE(IWRK(NEL)) + MEL = 0 + DO 305 M=1,NEL + IF(MAT(M).LE.0) GO TO 305 + MEL = MEL + 1 + IWRK(MEL) = M +305 CONTINUE + DO 330 K=1,NEL + L = MAT(K) + IF(L.EQ.0) GO TO 330 + VOL0 = VOL(K)/NTPH + IF(VOL0.EQ.0.0) GO TO 320 + DO 310 I = 1,NTPH +* + CALL TRINEI (3,1,1,ISPLH,ICR,I,KK1,KK2,KK3,KEL,IQF,NUM1, + > NTPH,NTPL,NVT1,NVT2,NVT3,IVAL,KN) + KK4 = KN(NUM1+NTPH+I) + KK5 = KN(NUM1+2*NTPH+I) + LK4 = KK4 + LK5 = KK5 + IF(LK4.GT.0) LK4 = IWRK(KN(NUM1+3*NTPH+7)) + IF(LK5.GT.0) LK5 = IWRK(KN(NUM1+3*NTPH+8)) +* + CALL TRITCO (NEL,LL4,ISPLH,IR,IQF,K,KK1,KK2,KK3,LK4,LK5, + > VOL0,MAT,MATN,SGD(1,1),XSGD(1,1),SIDE,ZZ,QFR(NUM2+1),IPR,A1) +* + INZ1=IPZ(KEL) + KEY0=MUZ(INZ1)-INZ1 + IF(KK4.GT.0) THEN + INZ2=IPZ(KK4) + IF(INZ2.LT.INZ1) THEN + KEY=KEY0+INZ2 + A11Z(KEY)=A11Z(KEY)-REAL(A1(4)) + ENDIF + ENDIF + IF(KK5.GT.0) THEN + INZ2=IPZ(KK5) + IF(INZ2.LT.INZ1) THEN + KEY=KEY0+INZ2 + A11Z(KEY)=A11Z(KEY)-REAL(A1(5)) + ENDIF + ENDIF + KEY=KEY0+INZ1 + VAR1 = A1(1)+A1(2)+A1(3)+A1(4)+A1(5) + A11Z(KEY)=A11Z(KEY)+REAL(VAR1)+XSGD(L,4)*VOL0 + 310 CONTINUE + 320 NUM1=NUM1+IVAL + NUM2=NUM2+8 + 330 CONTINUE + DEALLOCATE(IWRK) + RETURN + END diff --git a/Trivac/src/TRIMWW.f b/Trivac/src/TRIMWW.f new file mode 100755 index 0000000..2046984 --- /dev/null +++ b/Trivac/src/TRIMWW.f @@ -0,0 +1,307 @@ +*DECK TRIMWW + SUBROUTINE TRIMWW(IR,NEL,LL4,VOL,MAT,SGD,XSGD,SIDE,ZZ,KN,QFR,MUW, + 1 IPW,IPR,A11W) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Assembly of system matrices for a mesh centered finite difference +* discretization in hexagonal geometry (complete hexagons). +* Note: system matrices should be initialized by the calling program. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Benaboud +* +*Parameters: input +* IR first dimension of matrix SGD. +* NEL total number of finite elements. +* ll4 order of system matrices. +* VOL volume of each element. +* MAT mixture index assigned to each element. +* SGD nuclear properties per material mixtures: +* SGD(L,1)= W-, X-, and Y-oriented diffusion coefficients; +* SGD(L,3)= Z-oriented diffusion coefficients; +* SGD(L,4)= removal macroscopic cross section. +* XSGD nuclear properties (IPR=0), derivatives (IPR=1) or first +* variations (IPR=2 or 3) of nuclear properties per material +* mixture. +* SIDE side of an hexagon. +* ZZ Z-directed mesh spacings. +* KN element-ordered unknown list. +* QFR element-ordered boundary conditions. +* MUW W-oriented compressed storage mode indices. +* MUX X-oriented compressed storage mode indices. +* MUY Y-oriented compressed storage mode indices. +* MUZ Z-oriented compressed storage mode indices. +* IPW W-oriented permutation matrices. +* IPX X-oriented permutation matrices. +* IPY Y-oriented permutation matrices. +* IPZ Z-oriented permutation matrices. +* IPR type of assembly: +* =0: compute the system matrices; +* =1: compute the derivative of system matrices; +* =2 or =3: compute the variation of system matrices. +* +*Parameters: output +* A11W W-oriented matrices corresponding to the divergence (i.e +* leakage) and removal terms. Dimensionned to MUW(LL4). +* A11X X-oriented matrices corresponding to the divergence (i.e +* leakage) and removal terms. Dimensionned to MUX(LL4). +* A11Y Y-oriented matrices corresponding to the divergence (i.e +* leakage) and removal terms. Dimensionned to MUY(LL4). +* A11Z Z-oriented matrices corresponding to the divergence (i.e +* leakage) and removal terms. Dimensionned to MUZ(LL4). +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IR,NEL,LL4,MAT(NEL),KN(8*NEL),MUW(LL4),IPW(LL4),IPR + REAL VOL(NEL),SGD(IR,4),XSGD(IR,4),SIDE,ZZ(NEL),QFR(8*NEL), + 1 A11W(*) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION A1(8),VAR1 + INTEGER, DIMENSION(:), ALLOCATABLE :: IGAR +*---- +* ASSEMBLY OF MATRIX A11W +*---- + ALLOCATE(IGAR(LL4)) + LL=0 + DO 10 K=1,NEL + IF(MAT(K).LE.0) GO TO 10 + LL=LL+1 + IGAR(LL)=K + 10 CONTINUE + NUM1=0 + KEL=0 + DO 70 K=1,NEL + L=MAT(K) + IF(L.EQ.0) GO TO 70 + VOL0=VOL(K) + IF(VOL0.EQ.0.0) GO TO 60 + KEL=KEL+1 +* + CALL TRIHCO (IR,K,NEL,VOL0,MAT,SGD(1,1),XSGD(1,1),SIDE,ZZ, + 1 KN(NUM1+1),QFR(NUM1+1),IGAR,IPR,A1) + KK1=KN(NUM1+6) + KK2=KN(NUM1+3) +* + INW1=IPW(KEL) + KEY0=MUW(INW1)-INW1 + IF(KK1.GT.0) THEN + INW2=IPW(KK1) + IF(INW2.LT.INW1) THEN + KEY=KEY0+INW2 + A11W(KEY)=A11W(KEY)-REAL(A1(6)) + ENDIF + ENDIF + IF(KK2.GT.0) THEN + INW2=IPW(KK2) + IF(INW2.LT.INW1) THEN + KEY=KEY0+INW2 + A11W(KEY)=A11W(KEY)-REAL(A1(3)) + ENDIF + ENDIF + KEY=KEY0+INW1 + VAR1=A1(1)+A1(2)+A1(3)+A1(4)+A1(5)+A1(6)+A1(7)+A1(8) + A11W(KEY)=A11W(KEY)+REAL(VAR1)+XSGD(L,4)*VOL0 + 60 NUM1=NUM1+8 + 70 CONTINUE + DEALLOCATE(IGAR) + RETURN + END +* + SUBROUTINE TRIMWX (IR,NEL,LL4,VOL,MAT,SGD,XSGD,SIDE,ZZ,KN,QFR,MUX, + 1 IPX,IPR,A11X) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IR,NEL,LL4,MAT(NEL),KN(8*NEL),MUX(LL4),IPX(LL4),IPR + REAL VOL(NEL),SGD(IR,4),XSGD(IR,4),SIDE,ZZ(NEL),QFR(8*NEL), + 1 A11X(*) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION A1(8),VAR1 + INTEGER, DIMENSION(:), ALLOCATABLE :: IGAR +*---- +* ASSEMBLY OF MATRIX A11X +*---- + ALLOCATE(IGAR(LL4)) + LL=0 + DO 80 K=1,NEL + IF(MAT(K).LE.0) GO TO 80 + LL=LL+1 + IGAR(LL)=K + 80 CONTINUE + NUM1=0 + KEL=0 + DO 140 K=1,NEL + L=MAT(K) + IF(L.EQ.0) GO TO 140 + VOL0=VOL(K) + IF(VOL0.EQ.0.0) GO TO 130 + KEL=KEL+1 +* + CALL TRIHCO (IR,K,NEL,VOL0,MAT,SGD(1,1),XSGD(1,1),SIDE,ZZ, + 1 KN(NUM1+1),QFR(NUM1+1),IGAR,IPR,A1) + KK3=KN(NUM1+1) + KK4=KN(NUM1+4) +* + INX1=IPX(KEL) + KEY0=MUX(INX1)-INX1 + IF(KK3.GT.0) THEN + INX2=IPX(KK3) + IF(INX2.LT.INX1) THEN + KEY=KEY0+INX2 + A11X(KEY)=A11X(KEY)-REAL(A1(1)) + ENDIF + ENDIF + IF(KK4.GT.0) THEN + INX2=IPX(KK4) + IF(INX2.LT.INX1) THEN + KEY=KEY0+INX2 + A11X(KEY)=A11X(KEY)-REAL(A1(4)) + ENDIF + ENDIF + KEY=KEY0+INX1 + VAR1=A1(1)+A1(2)+A1(3)+A1(4)+A1(5)+A1(6)+A1(7)+A1(8) + A11X(KEY)=A11X(KEY)+REAL(VAR1)+XSGD(L,4)*VOL0 + 130 NUM1=NUM1+8 + 140 CONTINUE + DEALLOCATE(IGAR) + RETURN + END +* + SUBROUTINE TRIMWY (IR,NEL,LL4,VOL,MAT,SGD,XSGD,SIDE,ZZ,KN,QFR, + 1 MUY,IPY,IPR,A11Y) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IR,NEL,LL4,MAT(NEL),KN(8*NEL),MUY(LL4),IPY(LL4),IPR + REAL VOL(NEL),SGD(IR,4),XSGD(IR,4),SIDE,ZZ(NEL),QFR(8*NEL), + 1 A11Y(*) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION A1(8),VAR1 + INTEGER, DIMENSION(:), ALLOCATABLE :: IGAR +*---- +* ASSEMBLY OF MATRIX A11Y +*---- + ALLOCATE(IGAR(LL4)) + LL=0 + DO 85 K=1,NEL + IF(MAT(K).LE.0) GO TO 85 + LL=LL+1 + IGAR(LL)=K + 85 CONTINUE + NUM1=0 + KEL=0 + DO 145 K=1,NEL + L=MAT(K) + IF(L.EQ.0) GO TO 145 + VOL0=VOL(K) + IF(VOL0.EQ.0.0) GO TO 135 + KEL=KEL+1 +* + CALL TRIHCO (IR,K,NEL,VOL0,MAT,SGD(1,1),XSGD(1,1),SIDE,ZZ, + 1 KN(NUM1+1),QFR(NUM1+1),IGAR,IPR,A1) + KK5=KN(NUM1+2) + KK6=KN(NUM1+5) +* + INY1=IPY(KEL) + KEY0=MUY(INY1)-INY1 + IF(KK5.GT.0) THEN + INY2=IPY(KK5) + IF(INY2.LT.INY1) THEN + KEY=KEY0+INY2 + A11Y(KEY)=A11Y(KEY)-REAL(A1(2)) + ENDIF + ENDIF + IF(KK6.GT.0) THEN + INY2=IPY(KK6) + IF(INY2.LT.INY1) THEN + KEY=KEY0+INY2 + A11Y(KEY)=A11Y(KEY)-REAL(A1(5)) + ENDIF + ENDIF + KEY=KEY0+INY1 + VAR1=A1(1)+A1(2)+A1(3)+A1(4)+A1(5)+A1(6)+A1(7)+A1(8) + A11Y(KEY)=A11Y(KEY)+REAL(VAR1)+XSGD(L,4)*VOL0 + 135 NUM1=NUM1+8 + 145 CONTINUE + DEALLOCATE(IGAR) + RETURN + END +* + SUBROUTINE TRIMWZ (IR,NEL,LL4,VOL,MAT,SGD,XSGD,SIDE,ZZ,KN,QFR, + 1 MUZ,IPZ,IPR,A11Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IR,NEL,LL4,MAT(NEL),KN(8*NEL),MUZ(LL4),IPZ(LL4),IPR + REAL VOL(NEL),SGD(IR,4),XSGD(IR,4),SIDE,ZZ(NEL),QFR(8*NEL), + 1 A11Z(*) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION A1(8),VAR1 + INTEGER, DIMENSION(:), ALLOCATABLE :: IGAR +*---- +* ASSEMBLY OF MATRIX A11Z +*---- + ALLOCATE(IGAR(LL4)) + LL=0 + DO 150 K=1,NEL + IF(MAT(K).LE.0) GO TO 150 + LL=LL+1 + IGAR(LL)=K + 150 CONTINUE + NUM1=0 + KEL=0 + DO 210 K=1,NEL + L=MAT(K) + IF(L.EQ.0) GO TO 210 + VOL0=VOL(K) + IF(VOL0.EQ.0.0) GO TO 200 + KEL=KEL+1 +* + CALL TRIHCO (IR,K,NEL,VOL0,MAT,SGD(1,1),XSGD(1,1),SIDE,ZZ, + 1 KN(NUM1+1),QFR(NUM1+1),IGAR,IPR,A1) + KK7=KN(NUM1+7) + KK8=KN(NUM1+8) +* + INZ1=IPZ(KEL) + KEY0=MUZ(INZ1)-INZ1 + IF(KK7.GT.0) THEN + INZ2=IPZ(KK7) + IF(INZ2.LT.INZ1) THEN + KEY=KEY0+INZ2 + A11Z(KEY)=A11Z(KEY)-REAL(A1(7)) + ENDIF + ENDIF + IF(KK8.GT.0) THEN + INZ2=IPZ(KK8) + IF(INZ2.LT.INZ1) THEN + KEY=KEY0+INZ2 + A11Z(KEY)=A11Z(KEY)-REAL(A1(8)) + ENDIF + ENDIF + KEY=KEY0+INZ1 + VAR1=A1(1)+A1(2)+A1(3)+A1(4)+A1(5)+A1(6)+A1(7)+A1(8) + A11Z(KEY)=A11Z(KEY)+REAL(VAR1)+XSGD(L,4)*VOL0 + 200 NUM1=NUM1+8 + 210 CONTINUE + DEALLOCATE(IGAR) + RETURN + END diff --git a/Trivac/src/TRIMXX.f b/Trivac/src/TRIMXX.f new file mode 100755 index 0000000..0d333aa --- /dev/null +++ b/Trivac/src/TRIMXX.f @@ -0,0 +1,494 @@ +*DECK TRIMXX + SUBROUTINE TRIMXX(IR,CYLIND,IELEM,IDIM,NEL,LL4,VOL,MAT,SGD,XSGD, + 1 XX,YY,ZZ,DD,KN,QFR,MUX,IPX,IPR,A11X) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Assembly of system matrices for mesh centered finite differences or +* nodal collocation method. Note: system matrices should be initialized +* by the calling program. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IR first dimension of matrices SGD and XSGD. +* CYLIND cylindrical geometry flag (set with CYLIND =.true.). +* IELEM degree of the polynomial basis: =1 (linear/finite +* differences); =2 (parabolic); =3 (cubic); =4 (quartic). +* IDIM number of dimensions (1, 2 or 3). +* NEL total number of finite elements. +* ll4 order of system matrices. +* VOL volume of each element. +* MAT mixture index assigned to each element. +* SGD nuclear properties by material mixture: +* SGD(L,1) X-oriented diffusion coefficients; +* SGD(L,2) Y-oriented diffusion coefficients; +* SGD(L,3) Z-oriented diffusion coefficients; +* SGD(L,4) removal macroscopic cross section. +* XSGD derivative of nuclear properties if IPR=1; +* variation of nuclear properties if IPR=2 or IPR=3. +* Note that XSGD=SGD if IPR=0. +* XX X-directed mesh spacings. +* YY Y-directed mesh spacings. +* ZZ Z-directed mesh spacings. +* DD used with cylindrical geometry. +* KN element-ordered unknown list: +* .GT.0: neighbour index; +* =-1: void/albedo boundary condition; +* =-2: reflection boundary condition; +* =-3: ZERO flux boundary condition; +* =-4: SYME boundary condition (axial symmetry). +* QFR element-ordered boundary conditions. +* MUX X-directed compressed storage mode indices. +* MUY Y-directed compressed storage mode indices. +* MUZ Z-directed compressed storage mode indices. +* IPX permutation matrices. +* IPY Y-directed permutation matrices. +* IPZ Z-directed permutation matrices. +* IPR type of assembly matrix calculation: +* =0: compute the system matrices; +* =1: compute the derivative of system matrices; +* =2 or =3: compute the variation of system matrices. +* +*Parameters: output +* A11X X-directed matrices corresponding to the divergence (i.e +* leakage) and removal terms. Dimensionned to MUX(LL4). +* A11Y Y-directed matrices corresponding to the divergence (i.e +* leakage) and removal terms. Dimensionned to MUY(LL4). +* A11Z Z-directed matrices corresponding to the divergence (i.e +* leakage) and removal terms. Dimensionned to MUZ(LL4). +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IR,IELEM,IDIM,NEL,LL4,MAT(NEL),KN(6*NEL),MUX(LL4), + 1 IPX(LL4),IPR + REAL VOL(NEL),SGD(IR,4),XSGD(IR,4),XX(NEL),YY(NEL),ZZ(NEL), + 1 DD(NEL),QFR(6*NEL),A11X(*) + LOGICAL CYLIND +*---- +* LOCAL VARIABLES +*---- + LOGICAL LOGIC + DOUBLE PRECISION RLL,R,S,QQ,PAIR,A1(6),VAR1 + INTEGER, DIMENSION(:), ALLOCATABLE :: IGAR +*---- +* STATEMENT FUNCTION +*---- + IORD(J,K,L,LL,IEL,IW)=(IEL*L+K)*LL*IEL+(1+IEL*(IW-1))+J +*---- +* X-ORIENTED COUPLINGS. ASSEMBLY OF MATRIX A11X +*---- + ALLOCATE(IGAR(NEL)) + LL=0 + DO 10 K=1,NEL + IF(MAT(K).EQ.0) GO TO 10 + LL=LL+1 + IGAR(K)=LL + 10 CONTINUE + RLL=REAL(IELEM*(IELEM+1)) + NUM1=0 + DO 70 K=1,NEL + L=MAT(K) + IF(L.EQ.0) GO TO 70 + VOL0=VOL(K) + IF(VOL0.EQ.0.0) GO TO 60 + DX=XX(K) + DY=YY(K) + DZ=ZZ(K) +* + IF(IPR.EQ.0) THEN + CALL TRICO (IELEM,IR,NEL,K,VOL0,MAT,XSGD(1,1),XX,YY,ZZ,DD, + 1 KN(NUM1+1),QFR(NUM1+1),CYLIND,A1) + ELSE IF(IPR.GE.1) THEN + CALL TRIDCO (IELEM,IR,NEL,K,VOL0,MAT,SGD(1,1),XSGD(1,1),XX,YY, + 1 ZZ,DD,KN(NUM1+1),QFR(NUM1+1),CYLIND,IPR,A1) + ENDIF + KK1=KN(NUM1+1) + KK2=KN(NUM1+2) + IF(KK1.EQ.-4) KK1=KK2 + IF(KK2.EQ.-4) KK2=KK1 +* + IF(IELEM.EQ.1) THEN + IND1=IGAR(K) + INX1=IPX(IND1) + KEY0=MUX(INX1)-INX1 + IF(KK1.GT.0) THEN + INX2=IPX(IGAR(KK1)) + IF(INX2.LT.INX1) THEN + KEY=KEY0+INX2 + A11X(KEY)=A11X(KEY)-REAL(A1(1)) + ENDIF + ENDIF + IF(KK2.GT.0) THEN + INX2=IPX(IGAR(KK2)) + IF(INX2.LT.INX1) THEN + KEY=KEY0+INX2 + A11X(KEY)=A11X(KEY)-REAL(A1(2)) + ENDIF + ENDIF + KEY=KEY0+INX1 + VAR1=A1(1)+A1(2)+A1(3)+A1(4)+A1(5)+A1(6) + A11X(KEY)=A11X(KEY)+REAL(VAR1)+XSGD(L,4)*VOL0 + ELSE + DO 55 I3=0,IELEM-1 + DO 50 I2=0,IELEM-1 + DO 40 I1=0,IELEM-1 + IND1=IORD(I1,I2,I3,LL,IELEM,IGAR(K)) + INX1=IPX(IND1) + KEY0=MUX(INX1)-INX1 + QQ=SQRT(REAL(2*I1+1))*(RLL-REAL(I1*(I1+1)))/RLL + IF(KK1.GT.0) THEN + PAIR=(-1.0D0)**I1 + DO 20 I0=0,IELEM-1 + LOGIC=(KN((IGAR(KK1)-1)*6+1).NE.-4).OR.(MOD(I0+1,2).NE.0) + INX2=IPX(IORD(I0,I2,I3,LL,IELEM,IGAR(KK1))) + IF((INX2.LT.INX1).AND.LOGIC) THEN + KEY=KEY0+INX2 + R=REAL(I0*(I0+1)) + S=SQRT(REAL(2*I0+1)) + VAR1=0.5D0*QQ*PAIR*S*(RLL-R)*A1(1) + A11X(KEY)=A11X(KEY)-REAL(VAR1) + ENDIF + 20 CONTINUE + ENDIF + IF(KK2.GT.0) THEN + DO 25 I0=0,IELEM-1 + INX2=IPX(IORD(I0,I2,I3,LL,IELEM,IGAR(KK2))) + IF(INX2.LT.INX1) THEN + PAIR=(-1.0D0)**I0 + IF(KN(NUM1+2).EQ.-4) PAIR=1.0D0 + KEY=KEY0+INX2 + R=REAL(I0*(I0+1)) + S=SQRT(REAL(2*I0+1)) + VAR1=0.5D0*QQ*PAIR*S*(RLL-R)*A1(2) + A11X(KEY)=A11X(KEY)-REAL(VAR1) + ENDIF + 25 CONTINUE + ENDIF + KEY=KEY0+INX1-I1 + DO 30 I0=0,I1 + R=REAL(I0*(I0+1)) + S=SQRT(REAL(2*I0+1)) + PAIR=1.0D0+(-1.0D0)**(I0+I1) + VAR1=QQ*(PAIR*S*R*XSGD(L,1)*VOL0/(DX*DX)+0.5D0*S*(RLL-R)* + 1 ((-1.0D0)**(I0+I1)*A1(1)+A1(2))) + A11X(KEY+I0)=A11X(KEY+I0)+REAL(VAR1) + 30 CONTINUE +* + KEY=KEY0+INX1 + R=REAL(I2*(I2+1)) + QQ=REAL(2*I2+1)*(RLL-R)/RLL + VAR1=QQ*(2.0D0*R*XSGD(L,2)*VOL0/(DY*DY)+0.5D0*(RLL-R)* + 1 (A1(3)+A1(4))) + A11X(KEY)=A11X(KEY)+REAL(VAR1) +* + R=REAL(I3*(I3+1)) + QQ=REAL(2*I3+1)*(RLL-R)/RLL + VAR1=QQ*(2.0D0*R*XSGD(L,3)*VOL0/(DZ*DZ)+0.5D0*(RLL-R)* + 1 (A1(5)+A1(6)))+XSGD(L,4)*VOL0 + A11X(KEY)=A11X(KEY)+REAL(VAR1) +* + 40 CONTINUE + IF((IDIM.EQ.1).AND.(I2.EQ.0)) GO TO 60 + IF((IDIM.EQ.2).AND.(I2.EQ.IELEM-1)) GO TO 60 + 50 CONTINUE + 55 CONTINUE + ENDIF + 60 NUM1=NUM1+6 + 70 CONTINUE + DEALLOCATE(IGAR) + RETURN + END +* + SUBROUTINE TRIMXY(IR,CYLIND,IELEM,IDIM,NEL,LL4,VOL,MAT,SGD,XSGD, + 1 XX,YY,ZZ,DD,KN,QFR,MUY,IPY,IPR,A11Y) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IR,IELEM,IDIM,NEL,LL4,MAT(NEL),KN(6*NEL),MUY(LL4), + 1 IPY(LL4),IPR + REAL VOL(NEL),SGD(IR,4),XSGD(IR,4),XX(NEL),YY(NEL),ZZ(NEL), + 1 DD(NEL),QFR(6*NEL),A11Y(*) + LOGICAL CYLIND +*---- +* LOCAL VARIABLES +*---- + LOGICAL LOGIC + DOUBLE PRECISION RLL,R,S,QQ,PAIR,A1(6),VAR1 + INTEGER, DIMENSION(:), ALLOCATABLE :: IGAR +*---- +* STATEMENT FUNCTION +*---- + IORD(J,K,L,LL,IEL,IW)=(IEL*L+K)*LL*IEL+(1+IEL*(IW-1))+J +*---- +* Y-ORIENTED COUPLINGS. ASSEMBLY OF MATRIX A11Y +*---- + ALLOCATE(IGAR(NEL)) + LL=0 + DO 80 K=1,NEL + IF(MAT(K).EQ.0) GO TO 80 + LL=LL+1 + IGAR(K)=LL + 80 CONTINUE + RLL=REAL(IELEM*(IELEM+1)) + NUM1=0 + DO 140 K=1,NEL + L=MAT(K) + IF(L.EQ.0) GO TO 140 + VOL0=VOL(K) + IF(VOL0.EQ.0.0) GO TO 130 + DX=XX(K) + DY=YY(K) + DZ=ZZ(K) +* + IF(IPR.EQ.0) THEN + CALL TRICO (IELEM,IR,NEL,K,VOL0,MAT,XSGD(1,1),XX,YY,ZZ,DD, + 1 KN(NUM1+1),QFR(NUM1+1),CYLIND,A1) + ELSE IF(IPR.GE.1) THEN + CALL TRIDCO (IELEM,IR,NEL,K,VOL0,MAT,SGD(1,1),XSGD(1,1),XX,YY, + 1 ZZ,DD,KN(NUM1+1),QFR(NUM1+1),CYLIND,IPR,A1) + ENDIF + KK3=KN(NUM1+3) + KK4=KN(NUM1+4) + IF(KK3.EQ.-4) KK3=KK4 + IF(KK4.EQ.-4) KK4=KK3 +* + IF(IELEM.EQ.1) THEN + INY1=IPY(IGAR(K)) + KEY0=MUY(INY1)-INY1 + IF(KK3.GT.0) THEN + INY2=IPY(IGAR(KK3)) + IF(INY2.LT.INY1) THEN + KEY=KEY0+INY2 + A11Y(KEY)=A11Y(KEY)-REAL(A1(3)) + ENDIF + ENDIF + IF(KK4.GT.0) THEN + INY2=IPY(IGAR(KK4)) + IF(INY2.LT.INY1) THEN + KEY=KEY0+INY2 + A11Y(KEY)=A11Y(KEY)-REAL(A1(4)) + ENDIF + ENDIF + KEY=KEY0+INY1 + VAR1=A1(1)+A1(2)+A1(3)+A1(4)+A1(5)+A1(6) + A11Y(KEY)=A11Y(KEY)+REAL(VAR1)+XSGD(L,4)*VOL0 + ELSE + DO 125 I3=0,IELEM-1 + DO 120 I2=0,IELEM-1 + DO 110 I1=0,IELEM-1 + INY1=IPY(IORD(I2,I1,I3,LL,IELEM,IGAR(K))) + KEY0=MUY(INY1)-INY1 + QQ=SQRT(REAL(2*I1+1))*(RLL-REAL(I1*(I1+1)))/RLL + IF(KK3.GT.0) THEN + PAIR=(-1.0D0)**I1 + DO 90 I0=0,IELEM-1 + LOGIC=(KN((IGAR(KK3)-1)*6+3).NE.-4).OR.(MOD(I0+1,2).NE.0) + INY2=IPY(IORD(I2,I0,I3,LL,IELEM,IGAR(KK3))) + IF((INY2.LT.INY1).AND.LOGIC) THEN + KEY=KEY0+INY2 + R=REAL(I0*(I0+1)) + S=SQRT(REAL(2*I0+1)) + VAR1=0.5D0*QQ*PAIR*S*(RLL-R)*A1(3) + A11Y(KEY)=A11Y(KEY)-REAL(VAR1) + ENDIF + 90 CONTINUE + ENDIF + IF(KK4.GT.0) THEN + DO 95 I0=0,IELEM-1 + INY2=IPY(IORD(I2,I0,I3,LL,IELEM,IGAR(KK4))) + IF(INY2.LT.INY1) THEN + PAIR=(-1.0D0)**I0 + IF(KN(NUM1+4).EQ.-4) PAIR=1.0D0 + KEY=KEY0+INY2 + R=REAL(I0*(I0+1)) + S=SQRT(REAL(2*I0+1)) + VAR1=0.5D0*QQ*PAIR*S*(RLL-R)*A1(4) + A11Y(KEY)=A11Y(KEY)-REAL(VAR1) + ENDIF + 95 CONTINUE + ENDIF + KEY=KEY0+INY1-I1 + DO 100 I0=0,I1 + R=REAL(I0*(I0+1)) + S=SQRT(REAL(2*I0+1)) + PAIR=1.0D0+(-1.0D0)**(I0+I1) + VAR1=QQ*(PAIR*S*R*XSGD(L,2)*VOL0/(DY*DY)+0.5D0*S*(RLL-R)* + 1 ((-1.0D0)**(I0+I1)*A1(3)+A1(4))) + A11Y(KEY+I0)=A11Y(KEY+I0)+REAL(VAR1) + 100 CONTINUE +* + KEY=KEY0+INY1 + R=REAL(I2*(I2+1)) + QQ=REAL(2*I2+1)*(RLL-R)/RLL + VAR1=QQ*(2.0D0*R*XSGD(L,1)*VOL0/(DX*DX)+0.5D0*(RLL-R)* + 1 (A1(1)+A1(2))) + A11Y(KEY)=A11Y(KEY)+REAL(VAR1) +* + R=REAL(I3*(I3+1)) + QQ=REAL(2*I3+1)*(RLL-R)/RLL + VAR1=QQ*(2.0D0*R*XSGD(L,3)*VOL0/(DZ*DZ)+0.5D0*(RLL-R)* + 1 (A1(5)+A1(6)))+XSGD(L,4)*VOL0 + A11Y(KEY)=A11Y(KEY)+REAL(VAR1) +* + 110 CONTINUE + IF((IDIM.EQ.2).AND.(I2.EQ.IELEM-1)) GO TO 130 + 120 CONTINUE + 125 CONTINUE + ENDIF + 130 NUM1=NUM1+6 + 140 CONTINUE + DEALLOCATE(IGAR) + RETURN + END +* + SUBROUTINE TRIMXZ(IR,CYLIND,IELEM,NEL,LL4,VOL,MAT,SGD,XSGD,XX,YY, + 1 ZZ,DD,KN,QFR,MUZ,IPZ,IPR,A11Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IR,IELEM,NEL,LL4,MAT(NEL),KN(6*NEL),MUZ(LL4),IPZ(LL4),IPR + REAL VOL(NEL),SGD(IR,4),XSGD(IR,4),XX(NEL),YY(NEL),ZZ(NEL), + 1 DD(NEL),QFR(6*NEL),A11Z(*) + LOGICAL CYLIND +*---- +* LOCAL VARIABLES +*---- + LOGICAL LOGIC + DOUBLE PRECISION RLL,R,S,QQ,PAIR,A1(6),VAR1 + INTEGER, DIMENSION(:), ALLOCATABLE :: IGAR +*---- +* STATEMENT FUNCTION +*---- + IORD(J,K,L,LL,IEL,IW)=(IEL*L+K)*LL*IEL+(1+IEL*(IW-1))+J +*---- +* Z-ORIENTED COUPLINGS. ASSEMBLY OF MATRIX A11Z +*---- + ALLOCATE(IGAR(NEL)) + LL=0 + DO 150 K=1,NEL + IF(MAT(K).EQ.0) GO TO 150 + LL=LL+1 + IGAR(K)=LL + 150 CONTINUE + RLL=REAL(IELEM*(IELEM+1)) + NUM1=0 + DO 210 K=1,NEL + L=MAT(K) + IF(L.EQ.0) GO TO 210 + VOL0=VOL(K) + IF(VOL0.EQ.0.0) GO TO 200 + DX=XX(K) + DY=YY(K) + DZ=ZZ(K) +* + IF(IPR.EQ.0) THEN + CALL TRICO (IELEM,IR,NEL,K,VOL0,MAT,XSGD(1,1),XX,YY,ZZ,DD, + 1 KN(NUM1+1),QFR(NUM1+1),CYLIND,A1) + ELSE IF(IPR.GE.1) THEN + CALL TRIDCO (IELEM,IR,NEL,K,VOL0,MAT,SGD(1,1),XSGD(1,1),XX,YY, + 1 ZZ,DD,KN(NUM1+1),QFR(NUM1+1),CYLIND,IPR,A1) + ENDIF + KK5=KN(NUM1+5) + KK6=KN(NUM1+6) + IF(KK5.EQ.-4) KK5=KK6 + IF(KK6.EQ.-4) KK6=KK5 +* + IF(IELEM.EQ.1) THEN + INZ1=IPZ(IGAR(K)) + KEY0=MUZ(INZ1)-INZ1 + IF(KK5.GT.0) THEN + INZ2=IPZ(IGAR(KK5)) + IF(INZ2.LT.INZ1) THEN + KEY=KEY0+INZ2 + A11Z(KEY)=A11Z(KEY)-REAL(A1(5)) + ENDIF + ENDIF + IF(KK6.GT.0) THEN + INZ2=IPZ(IGAR(KK6)) + IF(INZ2.LT.INZ1) THEN + KEY=KEY0+INZ2 + A11Z(KEY)=A11Z(KEY)-REAL(A1(6)) + ENDIF + ENDIF + KEY=KEY0+INZ1 + VAR1=A1(1)+A1(2)+A1(3)+A1(4)+A1(5)+A1(6) + A11Z(KEY)=A11Z(KEY)+REAL(VAR1)+XSGD(L,4)*VOL0 + ELSE + DO 192 I3=0,IELEM-1 + DO 191 I2=0,IELEM-1 + DO 190 I1=0,IELEM-1 + INZ1=IPZ(IORD(I2,I3,I1,LL,IELEM,IGAR(K))) + KEY0=MUZ(INZ1)-INZ1 + QQ=SQRT(REAL(2*I1+1))*(RLL-REAL(I1*(I1+1)))/RLL + IF(KK5.GT.0) THEN + PAIR=(-1.0D0)**I1 + DO 160 I0=0,IELEM-1 + LOGIC=(KN((IGAR(KK5)-1)*6+5).NE.-4).OR.(MOD(I0+1,2).NE.0) + INZ2=IPZ(IORD(I2,I3,I0,LL,IELEM,IGAR(KK5))) + IF((INZ2.LT.INZ1).AND.LOGIC) THEN + KEY=KEY0+INZ2 + R=REAL(I0*(I0+1)) + S=SQRT(REAL(2*I0+1)) + VAR1=0.5D0*QQ*PAIR*S*(RLL-R)*A1(5) + A11Z(KEY)=A11Z(KEY)-REAL(VAR1) + ENDIF + 160 CONTINUE + ENDIF + IF(KK6.GT.0) THEN + DO 165 I0=0,IELEM-1 + INZ2=IPZ(IORD(I2,I3,I0,LL,IELEM,IGAR(KK6))) + IF(INZ2.LT.INZ1) THEN + PAIR=(-1.0D0)**I0 + IF(KN(NUM1+6).EQ.-4) PAIR=1.0D0 + KEY=KEY0+INZ2 + R=REAL(I0*(I0+1)) + S=SQRT(REAL(2*I0+1)) + VAR1=0.5D0*QQ*PAIR*S*(RLL-R)*A1(6) + A11Z(KEY)=A11Z(KEY)-REAL(VAR1) + ENDIF + 165 CONTINUE + ENDIF + KEY=KEY0+INZ1-I1 + DO 170 I0=0,I1 + R=REAL(I0*(I0+1)) + S=SQRT(REAL(2*I0+1)) + PAIR=1.0D0+(-1.0D0)**(I0+I1) + VAR1=QQ*(PAIR*S*R*XSGD(L,3)*VOL0/(DZ*DZ)+0.5D0*S*(RLL-R)* + 1 ((-1.0D0)**(I0+I1)*A1(5)+A1(6))) + A11Z(KEY+I0)=A11Z(KEY+I0)+REAL(VAR1) + 170 CONTINUE +* + KEY=KEY0+INZ1 + R=REAL(I2*(I2+1)) + QQ=REAL(2*I2+1)*(RLL-R)/RLL + VAR1=QQ*(2.0D0*R*XSGD(L,1)*VOL0/(DX*DX)+0.5D0*(RLL-R)* + 1 (A1(1)+A1(2))) + A11Z(KEY)=A11Z(KEY)+REAL(VAR1) +* + R=REAL(I3*(I3+1)) + QQ=REAL(2*I3+1)*(RLL-R)/RLL + VAR1=QQ*(2.0D0*R*XSGD(L,2)*VOL0/(DY*DY)+0.5D0*(RLL-R)* + 1 (A1(3)+A1(4)))+XSGD(L,4)*VOL0 + A11Z(KEY)=A11Z(KEY)+REAL(VAR1) +* + 190 CONTINUE + 191 CONTINUE + 192 CONTINUE + ENDIF + 200 NUM1=NUM1+6 + 210 CONTINUE + DEALLOCATE(IGAR) + RETURN + END diff --git a/Trivac/src/TRINDX.f b/Trivac/src/TRINDX.f new file mode 100755 index 0000000..da5ec16 --- /dev/null +++ b/Trivac/src/TRINDX.f @@ -0,0 +1,43 @@ +*DECK TRINDX + SUBROUTINE TRINDX(I,IP,MAX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Set the perdue storage indices. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* I index of the new information element. +* IP array of perdue storage indices. +* MAX size of array IP. +* +*Parameters: output +* IP array of perdue storage indices. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER I,MAX,IP(MAX) +* + DO 10 I0=1,MAX + IF(IP(I0).EQ.I) THEN + RETURN + ELSE IF(IP(I0).EQ.0) THEN + IP(I0)=I + RETURN + ENDIF + 10 CONTINUE + CALL XABORT('TRINDX: INDEX SEARCH FAILURE.') + RETURN + END diff --git a/Trivac/src/TRINEI.f b/Trivac/src/TRINEI.f new file mode 100755 index 0000000..3a0214a --- /dev/null +++ b/Trivac/src/TRINEI.f @@ -0,0 +1,349 @@ +*DECK TRINEI + SUBROUTINE TRINEI(IOPT,IDIR,ICAS,ISPLH,ICR,I,KK1,KK2,KK3,KEL, + > IQF,NUM1,NTPH,NTPL,NVT1,NVT2,NVT3,IVAL,KN) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Find the three neighbours of triangle I. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Benaboud +* +*Parameters: input +* IDIR axis index: W: 1 ; X: 2 ; Y: 3 ; Z: 1. +* ISPLH used to compute the numbrt of triangles per hexagon using +* (6*(ISPLH-1)**2). +* ICAS type of calculation: = 1 (with KK3); = 2 (without KK3). +* I number of triangles. +* KN element-ordered unknown list. +* +*Parameters: output +* KK1 first neighbours of triangle I. +* KK2 second neighbours of triangle I. +* KK3 third neighbours of triangle I. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IOPT,IDIR,ICAS,ISPLH,ICR,I,KK1,KK2,KK3,KEL,IQF,NUM1,NTPH, + > NTPL,NVT1,NVT2,NVT3,IVAL,KN(*) +*---- +* LOCAL VARIABLES +*---- + LOGICAL LPAIR + INTEGER IPER(180,3),ICF(6,3) + DATA IPER /1,2,3,4,5,6, 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15, + > 16,17,18,19,20,21,22,23,24, 1,2,3,4,5,6,7,8,9,10,11,12,13, + > 14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33, + > 34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53, + > 54, 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21, + > 22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41, + > 42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61, + > 62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81, + > 82,83,84,85,86,87,88,89,90,91,92,93,94,95,96, + > 2,3,6,1,4,5, 4,5,11,12,19,2,3,9,10,17,18,24,1,7,8, + > 15,16,22,23,6,13,14,20,21, 6,7,15,16,26,27,38,4,5,13,14,24, + > 25,36,37,47,2,3,11,12,22,23,34,35,45,46,54,1,9,10,20,21,32, + > 33,43,44,52,53,8,18,19,30,31,41,42,50,51,17,28,29,39,40,48, + > 49, 8,9,19,20,32,33,47,48,63,6,7,17,18,30,31,45,46,61,62,76, + > 4,5,15,16,28,29,43,44,59,60,74,75,87,2,3,13,14,26,27,41,42, + > 57,58,72,73,85,86,96,1,11,12,24,25,39,40,55,56,70,71,83,84, + > 94,95,10,22,23,37,38,53,54,68,69,81,82,92,93,21,35,36,51,52, + > 66,67,79,80,90,91,34,49,50,64,65,77,78,88,89, + > 3,6,5,2,1,4, 12,19,18,24,23,5,11,10,17,16,22,21,4,3,9,8,15, + > 14,20,2,1,7,6,13, 27,38,37,47,46,54,53,16,26,25,36,35,45,44, + > 52,51,7,15,14,24,23,34,33,43,42,50,49,6,5,13,12,22,21,32,31, + > 41,40,48,4,3,11,10,20,19,30,29,39,2,1,9,8,18,17,28, + > 48,63,62,76,75,87,86,96,95,33,47,46,61,60,74,73,85,84,94,93, + > 20,32,31,45,44,59,58,72,71,83,82,92,91,9,19,18,30,29,43,42, + > 57,56,70,69,81,80,90,89,8,7,17,16,28,27,41,40,55,54, 68,67,79, + > 78,88,6,5,15,14,26,25,39,38,53,52,66,65,77,4,3,13,12,24,23, + > 37,36,51,50,64,2,1,11,10,22,21,35,34,49/ + DATA ICF /6,2,1,5,3,4,1,3,2,6,4,5,2,4,3,1,5,6/ +* + PATRI = REAL(I)/2. + LPAIR = (AINT(PATRI).EQ.PATRI) +* + IF(I.LE.NTPL) THEN + IF(I.EQ.1) THEN + IQF = ICF(1,IDIR) + KK1 = KN(NUM1+IPER(ICR+I+1,IDIR)) + KK2 = KN(NUM1+IOPT*NTPH+IQF) + IF(KK2.GT.0) KK2 = KN((KK2-1)* + > IVAL+IPER(ICR+NVT1,IDIR)) + IF(ICAS.EQ.1) THEN + IF(ISPLH.EQ.2) KK3 = KN(NUM1+IPER(ICR+I+NTPL,IDIR)) + IF(ISPLH.GT.2) KK3 = KN(NUM1+IPER(ICR+I+NTPL+1,IDIR)) + ENDIF + ELSE IF(I.EQ.NTPL) THEN + IQF = ICF(2,IDIR) + KK1 = KN(NUM1+IOPT*NTPH+IQF) + KK2 = KN(NUM1+IPER(ICR+I-1,IDIR)) + IF(KK1.GT.0) KK1 = KN((KK1-1)* + > IVAL+IPER(ICR+1+NTPH/2,IDIR)) + IF(ICAS.EQ.1) THEN + IF(ISPLH.EQ.2) KK3 = KN(NUM1+IPER(ICR+I+NTPL,IDIR)) + IF(ISPLH.GT.2) KK3 = KN(NUM1+IPER(ICR+I+NTPL+1,IDIR)) + ENDIF + ELSE + IQF = ICF(3,IDIR) + KK1 = KN(NUM1+IPER(ICR+I+1,IDIR)) + KK2 = KN(NUM1+IPER(ICR+I-1,IDIR)) + IF(ICAS.EQ.1) THEN + IF(ISPLH.EQ.2) THEN + KK3 = KN(NUM1+IOPT*NTPH+IQF) + IF(KK3.GT.0) KK3 = KN((KK3-1)* + > IVAL+IPER(ICR+I+NTPL,IDIR)) + ELSE + IF(.NOT.LPAIR) KK3 =KN(NUM1+IPER(ICR+I+NTPL+1,IDIR)) + IF(LPAIR) THEN + KK3 = KN(NUM1+IOPT*NTPH+IQF) + IF(KK3.GT.0) KK3 = KN((KK3-1)* + > IVAL+IPER(ICR+I+NTPH-NTPL,IDIR)) + ENDIF + ENDIF + ENDIF + ENDIF + ELSE IF(((I.GT.NTPL).AND.(I.LE.(2*NTPL+2))) + > .AND.ISPLH.GE.3) THEN + IF(I.EQ.(NTPL+1)) THEN + IQF = ICF(1,IDIR) + KK1 = KN(NUM1+IPER(ICR+I+1,IDIR)) + KK2 = KN(NUM1+IOPT*NTPH+IQF) + IF(KK2.GT.0) KK2 = KN((KK2-1)* + > IVAL+IPER(ICR+NVT2,IDIR)) + IF(ICAS.EQ.1) THEN + IF(ISPLH.EQ.3) KK3 = KN(NUM1+IPER(ICR+I+NTPL+2,IDIR)) + IF(ISPLH.GT.3) KK3 = KN(NUM1+IPER(ICR+I+NTPL+3,IDIR)) + ENDIF + ELSE IF(I.EQ.(2*NTPL+2)) THEN + IQF = ICF(2,IDIR) + KK1 = KN(NUM1+IOPT*NTPH+IQF) + KK2 = KN(NUM1+IPER(ICR+I-1,IDIR)) + IF(KK1.GT.0) KK1 = KN((KK1-1)* + > IVAL+IPER(ICR+NVT1+1,IDIR)) + IF(ICAS.EQ.1) THEN + IF(ISPLH.EQ.3) KK3 = KN(NUM1+IPER(ICR+I+NTPL+2,IDIR)) + IF(ISPLH.GT.3) KK3 = KN(NUM1+IPER(ICR+I+NTPL+3,IDIR)) + ENDIF + ELSE + KK1 = KN(NUM1+IPER(ICR+I+1,IDIR)) + KK2 = KN(NUM1+IPER(ICR+I-1,IDIR)) + IF(ICAS.EQ.1) THEN + IF(.NOT.LPAIR) KK3 = KN(NUM1+ + > IPER(ICR+I-NTPL-1,IDIR)) + IF(LPAIR.AND.ISPLH.EQ.3) KK3 = KN(NUM1+ + > IPER(ICR+I+NTPL+2,IDIR)) + IF(LPAIR.AND.ISPLH.GT.3) KK3 = KN(NUM1+ + > IPER(ICR+I+NTPL+3,IDIR)) + ENDIF + ENDIF + ELSE IF(((I.GT.(2*NTPL+2)).AND.(I.LE.(3*NTPL+6))) + > .AND.ISPLH.GE.4) THEN + IF(I.EQ.(2*NTPL+3)) THEN + IQF = ICF(1,IDIR) + KK1 = KN(NUM1+IPER(ICR+I+1,IDIR)) + KK2 = KN(NUM1+IOPT*NTPH+IQF) + IF(KK2.GT.0) KK2 = KN((KK2-1)* + > IVAL+IPER(ICR+NVT3,IDIR)) + IF(ICAS.EQ.1) THEN + IF(ISPLH.EQ.4) KK3 = KN(NUM1+IPER(ICR+I+NTPL+4,IDIR)) + IF(ISPLH.EQ.5) KK3 = KN(NUM1+IPER(ICR+I+NTPL+5,IDIR)) + ENDIF + ELSE IF(I.EQ.(3*NTPL+6)) THEN + IQF = ICF(2,IDIR) + KK1 = KN(NUM1+IOPT*NTPH+IQF) + KK2 = KN(NUM1+IPER(ICR+I-1,IDIR)) + IF(KK1.GT.0) KK1 = KN((KK1-1)* + > IVAL+IPER(ICR+NVT2+1,IDIR)) + IF(ICAS.EQ.1) THEN + IF(ISPLH.EQ.4) KK3 = KN(NUM1+IPER(ICR+I+NTPL+4,IDIR)) + IF(ISPLH.EQ.5) KK3 = KN(NUM1+IPER(ICR+I+NTPL+5,IDIR)) + ENDIF + ELSE + KK1 = KN(NUM1+IPER(ICR+I+1,IDIR)) + KK2 = KN(NUM1+IPER(ICR+I-1,IDIR)) + IF(ICAS.EQ.1) THEN + IF(LPAIR) KK3 = KN(NUM1+ + > IPER(ICR+I-NTPL-3,IDIR)) + IF(.NOT.LPAIR.AND.ISPLH.EQ.4) KK3 = KN(NUM1+ + > IPER(ICR+I+NTPL+4,IDIR)) + IF(.NOT.LPAIR.AND.ISPLH.EQ.5) KK3 = KN(NUM1+ + > IPER(ICR+I+NTPL+5,IDIR)) + ENDIF + ENDIF + ELSE IF(((I.GT.(3*NTPL+6)).AND.(I.LE.(4*NTPL+12))) + > .AND.ISPLH.EQ.5) THEN + IF(I.EQ.(3*NTPL+7)) THEN + IQF = ICF(1,IDIR) + KK1 = KN(NUM1+IPER(ICR+I+1,IDIR)) + KK2 = KN(NUM1+IOPT*NTPH+IQF) + IF(ICAS.EQ.1) KK3 = KN(NUM1+IPER(ICR+I+NTPL+6,IDIR)) + IF(KK2.GT.0) KK2 = KN((KK2-1)* + > IVAL+IPER(ICR+NTPH,IDIR)) + ELSE IF(I.EQ.(4*NTPL+12)) THEN + IQF = ICF(2,IDIR) + KK1 = KN(NUM1+IOPT*NTPH+IQF) + KK2 = KN(NUM1+IPER(ICR+I-1,IDIR)) + IF(ICAS.EQ.1) KK3 = KN(NUM1+IPER(ICR+I+NTPL+6,IDIR)) + IF(KK1.GT.0) KK1 = KN((KK1-1)* + > IVAL+IPER(ICR+NTPH-NTPL+1,IDIR)) + ELSE + KK1 = KN(NUM1+IPER(ICR+I+1,IDIR)) + KK2 = KN(NUM1+IPER(ICR+I-1,IDIR)) + IF(ICAS.EQ.1) THEN + IF(LPAIR) KK3 = KN(NUM1+IPER(ICR+I+NTPL+6,IDIR)) + IF(.NOT.LPAIR) KK3 = KN(NUM1+IPER(ICR+I-NTPL-5,IDIR)) + ENDIF + ENDIF + ELSE IF(((I.GT.(NTPH-4*NTPL-12)).AND.(I.LE.(NTPH-3*NTPL-6))) + > .AND.ISPLH.EQ.5) THEN + IF(I.EQ.(NTPH-4*NTPL-11)) THEN + IQF = ICF(4,IDIR) + KK1 = KN(NUM1+IPER(ICR+I+1,IDIR)) + KK2 = KN(NUM1+IOPT*NTPH+IQF) + IF(ICAS.EQ.1) KK3 = KN(NUM1+IPER(ICR+I-NTPL-6,IDIR)) + IF(KK2.GT.0) KK2 = KN((KK2-1)* + > IVAL+IPER(ICR+NTPL,IDIR)) + ELSE IF(I.EQ.(NTPH-3*NTPL-6)) THEN + IQF = ICF(5,IDIR) + KK1 = KN(NUM1+IOPT*NTPH+IQF) + KK2 = KN(NUM1+IPER(ICR+I-1,IDIR)) + IF(ICAS.EQ.1) KK3 = KN(NUM1+IPER(ICR+I-NTPL-6,IDIR)) + IF(KK1.GT.0) KK1 = KN((KK1-1)* + > IVAL+IPER(ICR+1,IDIR)) + ELSE + KK1 = KN(NUM1+IPER(ICR+I+1,IDIR)) + KK2 = KN(NUM1+IPER(ICR+I-1,IDIR)) + IF(ICAS.EQ.1) THEN + IF(LPAIR) KK3 = KN(NUM1+IPER(ICR+I+NTPL+5,IDIR)) + IF(.NOT.LPAIR) KK3 = KN(NUM1+IPER(ICR+I-NTPL-6,IDIR)) + ENDIF + ENDIF + ELSE IF(((I.GT.(NTPH-3*NTPL-6)).AND.(I.LE.(NTPH-2*NTPL-2))) + > .AND.ISPLH.GE.4) THEN + IF(I.EQ.(NTPH-3*NTPL-5)) THEN + IQF = ICF(4,IDIR) + KK1 = KN(NUM1+IPER(ICR+I+1,IDIR)) + KK2 = KN(NUM1+IOPT*NTPH+IQF) + IF(KK2.GT.0) KK2 = KN((KK2-1)* + > IVAL+IPER(ICR+NTPH-NVT2,IDIR)) + IF(ICAS.EQ.1) THEN + IF(ISPLH.EQ.4) KK3 = KN(NUM1+IPER(ICR+I-NTPL-4,IDIR)) + IF(ISPLH.EQ.5) KK3 = KN(NUM1+IPER(ICR+I-NTPL-5,IDIR)) + ENDIF + ELSE IF(I.EQ.(NTPH-2*NTPL-2)) THEN + IQF = ICF(5,IDIR) + KK1 = KN(NUM1+IOPT*NTPH+IQF) + KK2 = KN(NUM1+IPER(ICR+I-1,IDIR)) + IF(ISPLH.EQ.4) THEN + IF(KK1.GT.0) KK1 = KN((KK1-1)* + > IVAL+IPER(ICR+1,IDIR)) + IF(ICAS.EQ.1) KK3 = KN(NUM1+IPER(ICR+I-NTPL-4,IDIR)) + ELSE + IF(KK1.GT.0) KK1 = KN((KK1-1)* + > IVAL+IPER(ICR+NTPL+1,IDIR)) + IF(ICAS.EQ.1) KK3 = KN(NUM1+IPER(ICR+I-NTPL-5,IDIR)) + ENDIF + ELSE + KK1 = KN(NUM1+IPER(ICR+I+1,IDIR)) + KK2 = KN(NUM1+IPER(ICR+I-1,IDIR)) + IF(ICAS.EQ.1) THEN + IF(.NOT.LPAIR) KK3 = KN(NUM1+ + > IPER(ICR+I+NTPL+3,IDIR)) + IF(LPAIR.AND.ISPLH.EQ.4) KK3 = KN(NUM1+ + > IPER(ICR+I-NTPL-4,IDIR)) + IF(LPAIR.AND.ISPLH.EQ.5) KK3 = KN(NUM1+ + > IPER(ICR+I-NTPL-5,IDIR)) + ENDIF + ENDIF + ELSE IF(((I.GT.(NTPH-2*NTPL-2)).AND.(I.LE.(NTPH-NTPL))) + > .AND.ISPLH.GE.3) THEN + IF(I.EQ.(NTPH-2*NTPL-1)) THEN + IQF = ICF(4,IDIR) + KK1 = KN(NUM1+IPER(ICR+I+1,IDIR)) + KK2 = KN(NUM1+IOPT*NTPH+IQF) + IF(KK2.GT.0) KK2 = KN((KK2-1)* + > IVAL+IPER(ICR+NTPH-NVT1,IDIR)) + IF(ICAS.EQ.1) THEN + IF(ISPLH.EQ.3) KK3 = KN(NUM1+IPER(ICR+I-NTPL-2,IDIR)) + IF(ISPLH.GT.3) KK3 = KN(NUM1+IPER(ICR+I-NTPL-3,IDIR)) + ENDIF + ELSE IF(I.EQ.(NTPH-NTPL)) THEN + IQF = ICF(5,IDIR) + KK1 = KN(NUM1+IOPT*NTPH+IQF) + KK2 = KN(NUM1+IPER(ICR+I-1,IDIR)) + IF(ISPLH.EQ.3) THEN + IF(KK1.GT.0) KK1 = KN((KK1-1)* + > IVAL+IPER(ICR+1,IDIR)) + IF(ICAS.EQ.1) KK3 = KN(NUM1+IPER(ICR+I-NTPL-2,IDIR)) + ELSE + IF(KK1.GT.0) KK1 = KN((KK1-1)* + > IVAL+IPER(ICR+NTPH-NVT2+1,IDIR)) + IF(ICAS.EQ.1) KK3 = KN(NUM1+IPER(ICR+I-NTPL-3,IDIR)) + ENDIF + ELSE + KK1 = KN(NUM1+IPER(ICR+I+1,IDIR)) + KK2 = KN(NUM1+IPER(ICR+I-1,IDIR)) + IF(ICAS.EQ.1) THEN + IF(LPAIR) KK3 = KN(NUM1+ + > IPER(ICR+I+NTPL+1,IDIR)) + IF(.NOT.LPAIR.AND.ISPLH.EQ.3) KK3 = KN(NUM1+ + > IPER(ICR+I-NTPL-2,IDIR)) + IF(.NOT.LPAIR.AND.ISPLH.GT.3) KK3 = KN(NUM1+ + > IPER(ICR+I-NTPL-3,IDIR)) + ENDIF + ENDIF + ELSE IF(((I.GT.(NTPH-NTPL)).AND.(I.LE.NTPH))) THEN + IF(I.EQ.(NTPH-NTPL+1)) THEN + IQF = ICF(4,IDIR) + KK1 = KN(NUM1+IPER(ICR+I+1,IDIR)) + KK2 = KN(NUM1+IOPT*NTPH+IQF) + IF(KK2.GT.0) KK2 = KN((KK2-1)* + > IVAL+IPER(ICR+NTPH/2,IDIR)) + IF(ICAS.EQ.1) THEN + IF(ISPLH.EQ.2) KK3 = KN(NUM1+IPER(ICR+I-NTPL,IDIR)) + IF(ISPLH.GT.2) KK3 = KN(NUM1+IPER(ICR+I-NTPL-1,IDIR)) + ENDIF + ELSE IF(I.EQ.NTPH) THEN + IQF = ICF(5,IDIR) + KK1 = KN(NUM1+IOPT*NTPH+IQF) + KK2 = KN(NUM1+IPER(ICR+I-1,IDIR)) + IF(KK1.GT.0) KK1 = KN((KK1-1)* + > IVAL+IPER(ICR+NTPH-NVT1+1,IDIR)) + IF(ICAS.EQ.1) THEN + IF(ISPLH.EQ.2) KK3 = KN(NUM1+IPER(ICR+I-NTPL,IDIR)) + IF(ISPLH.GT.2) KK3 = KN(NUM1+IPER(ICR+I-NTPL-1,IDIR)) + ENDIF + ELSE + IQF = ICF(6,IDIR) + KK1 = KN(NUM1+IPER(ICR+I+1,IDIR)) + KK2 = KN(NUM1+IPER(ICR+I-1,IDIR)) + IF(ICAS.EQ.1) THEN + IF(ISPLH.EQ.2) THEN + KK3 = KN(NUM1+IOPT*NTPH+IQF) + IF(KK3.GT.0) KK3 = KN((KK3-1)* + > IVAL+IPER(ICR+I-NTPL,IDIR)) + ELSE + IF(LPAIR) KK3 = KN(NUM1+IPER(ICR+I-NTPL-1,IDIR)) + IF(.NOT.LPAIR) THEN + KK3 = KN(NUM1+IOPT*NTPH+IQF) + IF(KK3.GT.0) KK3 = KN((KK3-1)* + > IVAL+IPER(ICR+I+NTPL-NTPH,IDIR)) + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + KEL = KN(NUM1+IPER(ICR+I,IDIR)) + RETURN + END diff --git a/Trivac/src/TRINTR.f b/Trivac/src/TRINTR.f new file mode 100755 index 0000000..78ceaff --- /dev/null +++ b/Trivac/src/TRINTR.f @@ -0,0 +1,241 @@ +*DECK TRINTR + SUBROUTINE TRINTR (ISPLH,IPTRK,LX,LI4,IHEX,MAT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Numbering corresponding to a mesh centred finite difference for +* hexagonal geometry (each hexagon represented by 6 triangles). +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Benaboud +* +*Parameters: input +* ISPLH used to compute the number of triangles per hexagon +* (6*(ISPLH-1)**2). +* IPTRK L_TRACK pointer to the tracking information. +* LX number of elements. +* IHEX type of hexagonal boundary condition. +* MAT mixture index assigned to each element. +* +*Parameters: output +* LI4 total number of unknown (variational coefficients) per +* energy group per plan. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK + INTEGER ISPLH,LX,LI4,IHEX,MAT(LX) +*---- +* LOCAL VARIABLES +*---- + LOGICAL LPAIR + INTEGER IRO(180,2),NBL(20,2) + INTEGER, DIMENSION(:), ALLOCATABLE :: IW,IY,IPO,IXN,IDX,IDY + INTEGER, DIMENSION(:,:), ALLOCATABLE :: IC1,IC2 + INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: NIK + DATA NBL /3,3,5,7,7,5,7,9,11,11,9,7,9,11,13,15,15,13,11,9, + > 3,3,7,5,5,7,11,9,7,7,9,11,15,13,11,9,9,11,13,15/ + DATA IRO /4,1,2,5,6,3, 13,6,7,1,2,20,14,15,8,9,3,4,21,22,16, + > 17,10,11,5,23,24,18,19,12, 28,17,18,8,9,1,2,39,29,30,19,20, + > 10,11,3,4,48,40,41,31,32,21,22,12,13,5,6,49,50,42,43,33,34, + > 23,24,14,15,7,51,52,44,45,35,36,25,26,16,53,54,46,47,37,38, + > 27, 49,34,35,21,22,10,11,1,2,64,50,51,36,37,23,24,12,13,3, + > 4,77,65,66,52,53,38,39,25,26,14,15,5,6,88,78,79,67,68,54,55, + > 40,41,27,28,16,17,7,8,89,90,80,81,69,70,56,57,42,43,29,30,18, + > 19,9,91,92,82,83,71,72,58,59,44,45,31,32,20,93,94,84,85,73, + > 74,60,61,46,47,33,95,96,86,87,75,76,62,63,48, + > 5,4,1,6,3,2, 21,20,14,13,6,23,22,16,15,8,7,1,24,18,17,10,9, + > 3,2,19,12,11,5,4, 49,48,40,39,29,28,17,51,50,42,41,31,30,19, + > 18,8,53,52,44,43,33,32,21,20,10,9,1,54,46,45,35,34,23,22,12, + > 11,3,2,47,37,36,25,24,14,13,5,4,38,27,26,16,15,7,6, + > 89,88,78,77,65,64,50,49,34,91,90,80,79,67,66,52,51,36,35,21, + > 93,92,82,81,69,68,54,53,38,37,23,22,10,95,94,84,83,71,70,56, + > 55,40,39,25,24,12,11,1,96,86,85,73,72,58,57,42,41,27,26,14, + > 13,3,2,87,75,74,60,59,44,43,29,28,16,15,5,4,76,62,61,46,45, + > 31,30,18,17,7,6,63,48,47,33,32,20,19,9,8/ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IC1(3,2*LX),IC2(3,2*LX*(ISPLH-1))) + ALLOCATE(NIK(3,6*(ISPLH-1)**2,LX)) +* + NBE = 0 + NC = INT((SQRT(REAL((4*LX-1)/3))+1.)/2.) + L1 = 3*NC - 2 + COURS2 = REAL(L1)/2. + LPAIR = (AINT(COURS2).EQ.COURS2) + IF(ISPLH.LE.3) ISAU = 2*(ISPLH-2) + IF(ISPLH.GE.4) ISAU = 6*(ISPLH-3) + ALLOCATE(IW(3*L1),IY(L1)) + IW(1) = 2+3*(NC-1)*(NC-2) + DO 10 I = 1,L1 + IF(I.LT.L1) IW(I+1) = 2+3*NC*(NC-1)-I + IF(I.LE.NC) IW(I+L1) = 3+(3*NC-5)*(NC-1)-I + IF(I.GT.NC) IW(I+L1) = 2+3*NC*(NC-1)-I+NC + IF(I.LE.2*NC-1) IW(I+2*L1) = 3+(3*NC-4)*(NC-1)-I + IF(I.GT.2*NC-1) IW(I+2*L1) = 2+3*NC*(NC-1)-I+2*NC-1 + 10 CONTINUE + IF(LPAIR) THEN + DO 20 I = 1,L1/2 + IF(I.LE.NC) IY(I) = 1+2*(I-1) + IF(I.GT.NC) IY(I) = IY(NC) + 20 CONTINUE + KEL = 1 + DO 30 I = L1,L1/2,-1 + IF(I.GE.(L1-NC-1)) IY(I) = IY(KEL) + IF(I.LT.(L1-NC-1)) IY(I) = IY(NC) + KEL = KEL + 1 + 30 CONTINUE + ELSE + DO 40 I = 1,(L1+1)/2 + IF(I.LE.NC) IY(I) = 1+2*(I-1) + IF(I.GT.NC) IY(I) = IY(NC) + 40 CONTINUE + KEL = 1 + DO 50 I = L1,(L1-1)/2,-1 + IF(I.GE.(L1-NC-1)) IY(I) = IY(KEL) + IF(I.LT.(L1-NC-1)) IY(I) = IY(NC) + KEL = KEL + 1 + 50 CONTINUE + ENDIF + ICAS = 3 + DO 90 K = 1,ICAS + KEL = 1 + DO 80 I = 1,L1 + IPAR = IW(I+(K-1)*L1) + NPAR = IPAR + IC1(K,KEL) = NPAR + KEL = KEL + 1 + IF(I.GT.(2*NC-1)) GO TO 70 + 60 NPAR = ABS(NEIGHB(NPAR,K+1,IHEX,LX,P)) + IF(NPAR.GT.LX) THEN + IF(I.LT.NC.OR.I.GT.(2*NC-1)) GO TO 80 + IF(I.GE.NC.AND.I.LE.(2*NC-1)) NPAR = IPAR + ENDIF + IC1(K,KEL) = NPAR + KEL = KEL + 1 + 70 NPAR = ABS(NEIGHB(NPAR,K+2,IHEX,LX,P)) + IF(NPAR.GT.LX) GO TO 80 + IC1(K,KEL) = NPAR + KEL = KEL + 1 + GO TO 60 + 80 CONTINUE + 90 CONTINUE + DO 140 K=1,ICAS + IF(ISPLH.EQ.2) THEN + DO 100 JX = 1,2*LX + IC2(K,JX) = IC1(K,JX) + 100 CONTINUE + ELSE + JEL = 1 + IEL = 1 + KEL = 1 + MEL = 0 + 110 IF(IEL.LE.2*LX) THEN + IF(IC1(K,IEL).EQ.MEL) NBE = IY(KEL-1) + IF(IC1(K,IEL).EQ.IW(KEL+(K-1)*L1)) THEN + NBE = IY(KEL) + KEL = KEL + 1 + ENDIF + MEL = IC1(K,IEL) + IFOIS = 0 + ISAUV = IEL + 120 DO 130 LDB = 1,NBE + IC2(K,JEL) = IC1(K,IEL) + JEL = JEL + 1 + IEL = IEL + 1 + 130 CONTINUE + IFOIS = IFOIS + 1 + IF(IFOIS.LT.(ISPLH-1)) THEN + IEL = ISAUV + GO TO 120 + ENDIF + GO TO 110 + ENDIF + ENDIF + 140 CONTINUE + DO 152 K=1,ICAS + DO 151 I=1,LX + DO 150 J=1,6*(ISPLH-1)**2 + NIK(K,J,I) = 0 + 150 CONTINUE + 151 CONTINUE + 152 CONTINUE + ALLOCATE(IPO(LX)) + DO 200 K=1,ICAS + DO 160 KK=1,LX + IPO(KK) = 1 + 160 CONTINUE + IA = 1 + IX = 1 + ILI = 1 + ICOMPT = 1 + 170 IEL = 1 + JCL = 1 + IVAL = IC2(K,IX) + 180 IF(MAT(IC2(K,IX)).EQ.0) THEN + IX = IX + 1 + IEL = IEL + 1 + JCL = JCL + 1 + IF(JCL.GT.2) JCL = 1 + ELSE + IF(ILI+ISAU.GT.20) CALL XABORT('TRINTR: NBL OVERFLOW.') + IDEB = IPO(IC2(K,IX)) + IFIN = IPO(IC2(K,IX)) + NBL(ILI+ISAU,JCL) - 1 + DO 190 J=IDEB,IFIN + NIK(K,J,IC2(K,IX)) = ICOMPT + ICOMPT = ICOMPT + 1 + 190 CONTINUE + IPO(IC2(K,IX)) = J + IX = IX + 1 + IEL = IEL + 1 + JCL = JCL + 1 + IF(JCL.GT.2) JCL = 1 + ENDIF + IF(IEL.LE.IY(IA)) GO TO 180 + IF(IX.GT.2*LX*(ISPLH-1)) GO TO 200 + IF(IC2(K,IX).NE.IVAL) IA = IA + 1 + ILI = ILI + 1 + IF(ILI.LE.(ISPLH-1)) GO TO 170 + IF((ILI.GT.(ISPLH-1).AND.ILI.LE.2*(ISPLH-1)).AND. + > (IVAL.EQ.IC2(K,IX))) GO TO 170 + ILI = 1 + IF(IA.GT.(1+2*(NC-1))) ILI = ISPLH + IF(IX.LE.2*LX*(ISPLH-1)) GO TO 170 + 200 CONTINUE + LI4 = ICOMPT - 1 + DEALLOCATE(IPO,IY,IW) + ALLOCATE(IXN(LI4),IDX(LI4),IDY(LI4)) + KEL = 0 + ICR = ISAU*(1+2*(ISPLH-2)) + DO 220 I = 1, LX + IF(MAT(I).EQ.0) GO TO 220 + DO 210 J=1,6*(ISPLH-1)**2 + KEL = KEL + 1 + IXN(KEL) = NIK(1,J,I) + IDX(NIK(1,J,I))=NIK(2,IRO(J+ICR,1),I) + IDY(NIK(1,J,I))=NIK(3,IRO(J+ICR,2),I) + 210 CONTINUE + 220 CONTINUE +* + CALL LCMPUT(IPTRK,'IKN',LI4,1,IXN) + CALL LCMPUT(IPTRK,'ILX',LI4,1,IDX) + CALL LCMPUT(IPTRK,'ILY',LI4,1,IDY) + DEALLOCATE(IDY,IDX,IXN) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(NIK,IC2,IC1) + RETURN + END diff --git a/Trivac/src/TRIPKN.f b/Trivac/src/TRIPKN.f new file mode 100755 index 0000000..8ed0d4b --- /dev/null +++ b/Trivac/src/TRIPKN.f @@ -0,0 +1,592 @@ +*DECK TRIPKN + SUBROUTINE TRIPKN (IELEM,LX,LY,LZ,L4,CYLIND,XXX,YYY,ZZZ,XX,YY,ZZ, + 1 DD,KN,QFR,IQFR,VOL,MAT,NCODE,ICODE,ZCODE,IMPX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Numbering corresponding to a primal formulation of the finite element +* discretization in a 3-D geometry. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IMPX print parameter. +* LX number of elements along the X axis. +* LY number of elements along the Y axis. +* LZ number of elements along the Z axis. +* CYLIND cylindrical geometry flag (set with CYLIND=.true.). +* IELEM degree of the Lagrangian finite elements: =1 (linear); +* =2 (parabolic); =3 (cubic); =4 (quartic). +* NCODE type of boundary condition applied on each side: +* I=1: X-; I=2: X+; I=3: Y-; I=4: Y+; I=5: Z-; I=6: Z+; +* NCODE(I)=1: VOID; NCODE(I)=2: REFL; NCODE(I)=4: TRAN; +* NCODE(I)=5: SYME; NCODE(I)=7: ZERO; NCODE(I)=20: CYLI. +* ICODE physical albedo index on each side of the domain. +* ZCODE albedo corresponding to boundary condition 'VOID' on each +* side (ZCODE(i)=0.0 by default). +* MAT mixture index assigned to each element. +* XXX Cartesian coordinates along the X axis. +* YYY Cartesian coordinates along the Y axis. +* ZZZ Cartesian coordinates along the Z axis. +* +*Parameters: output +* L4 total number of unknown (variational coefficients) per +* energy group (order of system matrices). +* VOL volume of each element. +* XX X-directed mesh spacings. +* YY Y-directed mesh spacings. +* ZZ Z-directed mesh spacings. +* DD used with cylindrical geometry. +* KN element-ordered unknown list. +* QFR element-ordered boundary conditions. +* IQFR element-ordered physical albedo indices. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IELEM,LX,LY,LZ,L4,KN(LX*LY*LZ*(IELEM+1)**3),MAT(LX*LY*LZ), + 1 IQFR(6*LX*LY*LZ),NCODE(6),ICODE(6),IMPX + REAL XXX(LX+1),YYY(LY+1),ZZZ(LZ+1),XX(LX*LY*LZ),YY(LX*LY*LZ), + 1 ZZ(LX*LY*LZ),DD(LX*LY*LZ),QFR(6*LX*LY*LZ),VOL(LX*LY*LZ),ZCODE(6) + LOGICAL CYLIND +*---- +* LOCAL VARIABLES +*---- + LOGICAL LL1,LL2 + INTEGER, DIMENSION(:), ALLOCATABLE :: IP,IWRK +* + ALB(X)=0.5*(1.0-X)/(1.0+X) +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IP((1+IELEM*LX)*(1+IELEM*LY)*(1+IELEM*LZ)), + 1 IWRK((1+IELEM*LX)*(1+IELEM*LY)*(1+IELEM*LZ))) +* + IF(IMPX.GT.0) WRITE(6,500) LX,LY,LZ + MAXIP=(1+IELEM*LX)*(1+IELEM*LY)*(1+IELEM*LZ) + LC=1+IELEM + LL=LC*LC*LC +*---- +* IDENTIFICATION OF THE GEOMETRY. MAIN LOOP OVER THE ELEMENTS +*---- + IX=LX*(LC-1)+1 + IXY=(LY*(LC-1)+1)*IX + IXYZ=(LZ*(LC-1)+1)*IXY + NUM1=0 + NUM2=0 + KEL=0 + DO 182 K0=1,LZ + DO 181 K1=1,LY + DO 180 K2=1,LX + KEL=KEL+1 + XX(KEL)=0.0 + YY(KEL)=0.0 + ZZ(KEL)=0.0 + VOL(KEL)=0.0 + IF(MAT(KEL).LE.0) GO TO 180 + XX(KEL)=XXX(K2+1)-XXX(K2) + YY(KEL)=YYY(K1+1)-YYY(K1) + ZZ(KEL)=ZZZ(K0+1)-ZZZ(K0) + IF(CYLIND) DD(KEL)=0.5*(XXX(K2)+XXX(K2+1)) + IND1=(LC-1)*((K0-1)*IXY+(K1-1)*IX+(K2-1)) + L=0 + DO 12 I=1,LC + DO 11 J=1,LC + DO 10 K=1,LC + L=L+1 + KN(NUM1+L)=IND1+(I-1)*IXY+(J-1)*IX+K + 10 CONTINUE + 11 CONTINUE + 12 CONTINUE + DO 20 IC=1,6 + QFR(NUM2+IC)=0.0 + IQFR(NUM2+IC)=0 + 20 CONTINUE + KK1=KEL-1 + KK2=KEL+1 + KK3=KEL-LX + KK4=KEL+LX + KK5=KEL-LX*LY + KK6=KEL+LX*LY + FRX=1.0 + FRY=1.0 + FRZ=1.0 +*---- +* VOID, REFL OR ZERO BOUNDARY CONTITION +*---- + IF(K2.EQ.1) THEN + LL1=.TRUE. + ELSE + LL1=(MAT(KK1).EQ.0) + ENDIF + IF(LL1) THEN + IF((NCODE(1).EQ.1).AND.(ICODE(1).EQ.0)) THEN + QFR(NUM2+1)=ALB(ZCODE(1)) + ELSE IF(NCODE(1).EQ.1) THEN + QFR(NUM2+1)=1.0 + IQFR(NUM2+1)=ICODE(1) + ELSE IF(NCODE(1).EQ.7) THEN + L=0 + DO 32 I=1,LC + DO 31 J=1,LC + DO 30 K=1,LC + L=L+1 + IF(K.EQ.1) KN(NUM1+L)=0 + 30 CONTINUE + 31 CONTINUE + 32 CONTINUE + ENDIF + ENDIF +* + IF(K2.EQ.LX) THEN + LL1=.TRUE. + ELSE + LL1=(MAT(KK2).EQ.0) + ENDIF + IF(LL1) THEN + IF((NCODE(2).EQ.1).AND.(ICODE(2).EQ.0)) THEN + QFR(NUM2+2)=ALB(ZCODE(2)) + ELSE IF(NCODE(2).EQ.1) THEN + QFR(NUM2+2)=1.0 + IQFR(NUM2+2)=ICODE(2) + ELSE IF(NCODE(2).EQ.7) THEN + L=0 + DO 42 I=1,LC + DO 41 J=1,LC + DO 40 K=1,LC + L=L+1 + IF(K.EQ.LC) KN(NUM1+L)=0 + 40 CONTINUE + 41 CONTINUE + 42 CONTINUE + ENDIF + ENDIF +* + IF(K1.EQ.1) THEN + LL1=.TRUE. + ELSE + LL1=(MAT(KK3).EQ.0) + ENDIF + IF(LL1) THEN + IF((NCODE(3).EQ.1).AND.(ICODE(3).EQ.0)) THEN + QFR(NUM2+3)=ALB(ZCODE(3)) + ELSE IF(NCODE(3).EQ.1) THEN + QFR(NUM2+3)=1.0 + IQFR(NUM2+3)=ICODE(3) + ELSE IF(NCODE(3).EQ.7) THEN + L=0 + DO 52 I=1,LC + DO 51 J=1,LC + DO 50 K=1,LC + L=L+1 + IF(J.EQ.1) KN(NUM1+L)=0 + 50 CONTINUE + 51 CONTINUE + 52 CONTINUE + ENDIF + ENDIF +* + IF(K1.EQ.LY) THEN + LL1=.TRUE. + ELSE + LL1=(MAT(KK4).EQ.0) + ENDIF + IF(LL1) THEN + IF((NCODE(4).EQ.1).AND.(ICODE(4).EQ.0)) THEN + QFR(NUM2+4)=ALB(ZCODE(4)) + ELSE IF(NCODE(4).EQ.1) THEN + QFR(NUM2+4)=1.0 + IQFR(NUM2+4)=ICODE(4) + ELSE IF(NCODE(4).EQ.7) THEN + L=0 + DO 62 I=1,LC + DO 61 J=1,LC + DO 60 K=1,LC + L=L+1 + IF(J.EQ.LC) KN(NUM1+L)=0 + 60 CONTINUE + 61 CONTINUE + 62 CONTINUE + ENDIF + ENDIF +* + IF(K0.EQ.1) THEN + LL1=.TRUE. + ELSE + LL1=(MAT(KK5).EQ.0) + ENDIF + IF(LL1) THEN + IF((NCODE(5).EQ.1).AND.(ICODE(5).EQ.0)) THEN + QFR(NUM2+5)=ALB(ZCODE(5)) + ELSE IF(NCODE(5).EQ.1) THEN + QFR(NUM2+5)=1.0 + IQFR(NUM2+5)=ICODE(5) + ELSE IF(NCODE(5).EQ.7) THEN + L=0 + DO 72 I=1,LC + DO 71 J=1,LC + DO 70 K=1,LC + L=L+1 + IF(I.EQ.1) KN(NUM1+L)=0 + 70 CONTINUE + 71 CONTINUE + 72 CONTINUE + ENDIF + ENDIF +* + IF(K0.EQ.LZ) THEN + LL1=.TRUE. + ELSE + LL1=(MAT(KK6).EQ.0) + ENDIF + IF(LL1) THEN + IF((NCODE(6).EQ.1).AND.(ICODE(6).EQ.0)) THEN + QFR(NUM2+6)=ALB(ZCODE(6)) + ELSE IF(NCODE(6).EQ.1) THEN + QFR(NUM2+6)=1.0 + IQFR(NUM2+6)=ICODE(6) + ELSE IF(NCODE(6).EQ.7) THEN + L=0 + DO 82 I=1,LC + DO 81 J=1,LC + DO 80 K=1,LC + L=L+1 + IF(I.EQ.LC) KN(NUM1+L)=0 + 80 CONTINUE + 81 CONTINUE + 82 CONTINUE + ENDIF + ENDIF +*---- +* TRAN BOUNDARY CONDITION +*---- + IF((K2.EQ.LX).AND.(NCODE(2).EQ.4)) THEN + DO 91 I=1,LC + DO 90 J=1,LC + M=(I-1)*LC*LC+(J-1)*LC+LC + KN(NUM1+M)=KN(NUM1+M)-IX+1 + 90 CONTINUE + 91 CONTINUE + ENDIF + IF((K1.EQ.LY).AND.(NCODE(4).EQ.4)) THEN + DO 101 I=1,LC + DO 100 K=1,LC + M=(I-1)*LC*LC+(LC-1)*LC+K + KN(NUM1+M)=KN(NUM1+M)-IXY+IX + 100 CONTINUE + 101 CONTINUE + ENDIF + IF((K0.EQ.LZ).AND.(NCODE(6).EQ.4)) THEN + DO 111 J=1,LC + DO 110 K=1,LC + M=(LC-1)*LC*LC+(J-1)*LC+K + KN(NUM1+M)=KN(NUM1+M)-IXYZ+IXY + 110 CONTINUE + 111 CONTINUE + ENDIF +*---- +* SYME BOUNDARY CONDITION +*---- + IF((NCODE(1).EQ.5).AND.(K2.EQ.1)) THEN + QFR(NUM2+1)=QFR(NUM2+2) + IQFR(NUM2+1)=IQFR(NUM2+2) + FRX=0.5 + DO 122 I=1,LC + DO 121 J=1,LC + DO 120 K=1,(LC+1)/2 + L=(I-1)*LC*LC+(J-1)*LC+K + M=(I-1)*LC*LC+(J-1)*LC+(LC-K+1) + KN(NUM1+L)=KN(NUM1+M) + 120 CONTINUE + 121 CONTINUE + 122 CONTINUE + ELSE IF((NCODE(2).EQ.5).AND.(K2.EQ.LX)) THEN + QFR(NUM2+2)=QFR(NUM2+1) + IQFR(NUM2+2)=IQFR(NUM2+1) + FRX=0.5 + DO 132 I=1,LC + DO 131 J=1,LC + DO 130 K=(LC+2)/2,LC + L=(I-1)*LC*LC+(J-1)*LC+K + M=(I-1)*LC*LC+(J-1)*LC+(LC-K+1) + KN(NUM1+L)=KN(NUM1+M) + 130 CONTINUE + 131 CONTINUE + 132 CONTINUE + ENDIF + IF((NCODE(3).EQ.5).AND.(K1.EQ.1)) THEN + QFR(NUM2+3)=QFR(NUM2+4) + IQFR(NUM2+3)=IQFR(NUM2+4) + FRY=0.5 + DO 142 I=1,LC + DO 141 J=1,(LC+1)/2 + DO 140 K=1,LC + L=(I-1)*LC*LC+(J-1)*LC+K + M=(I-1)*LC*LC+(LC-J)*LC+K + KN(NUM1+L)=KN(NUM1+M) + 140 CONTINUE + 141 CONTINUE + 142 CONTINUE + ELSE IF((NCODE(4).EQ.5).AND.(K1.EQ.LY)) THEN + QFR(NUM2+4)=QFR(NUM2+3) + IQFR(NUM2+4)=IQFR(NUM2+3) + FRY=0.5 + DO 152 I=1,LC + DO 151 J=(LC+2)/2,LC + DO 150 K=1,LC + L=(I-1)*LC*LC+(J-1)*LC+K + M=(I-1)*LC*LC+(LC-J)*LC+K + KN(NUM1+L)=KN(NUM1+M) + 150 CONTINUE + 151 CONTINUE + 152 CONTINUE + ENDIF + IF((NCODE(5).EQ.5).AND.(K0.EQ.1)) THEN + QFR(NUM2+5)=QFR(NUM2+6) + IQFR(NUM2+5)=IQFR(NUM2+6) + FRZ=0.5 + DO 162 I=1,(LC+1)/2 + DO 161 J=1,LC + DO 160 K=1,LC + L=(I-1)*LC*LC+(J-1)*LC+K + M=(LC-I)*LC*LC+(J-1)*LC+K + KN(NUM1+L)=KN(NUM1+M) + 160 CONTINUE + 161 CONTINUE + 162 CONTINUE + ELSE IF((NCODE(6).EQ.5).AND.(K0.EQ.LZ)) THEN + QFR(NUM2+6)=QFR(NUM2+5) + IQFR(NUM2+6)=IQFR(NUM2+5) + FRZ=0.5 + DO 172 I=(LC+2)/2,LC + DO 171 J=1,LC + DO 170 K=1,LC + L=(I-1)*LC*LC+(J-1)*LC+K + M=(LC-I)*LC*LC+(J-1)*LC+K + KN(NUM1+L)=KN(NUM1+M) + 170 CONTINUE + 171 CONTINUE + 172 CONTINUE + ENDIF +* + VOL0=XX(KEL)*YY(KEL)*ZZ(KEL)*FRX*FRY*FRZ + IF(CYLIND) VOL0=6.2831853072*DD(KEL)*VOL0 + VOL(KEL)=VOL0 + QFR(NUM2+1)=QFR(NUM2+1)*VOL0/XX(KEL) + QFR(NUM2+2)=QFR(NUM2+2)*VOL0/XX(KEL) + QFR(NUM2+3)=QFR(NUM2+3)*VOL0/YY(KEL) + QFR(NUM2+4)=QFR(NUM2+4)*VOL0/YY(KEL) + QFR(NUM2+5)=QFR(NUM2+5)*VOL0/ZZ(KEL) + QFR(NUM2+6)=QFR(NUM2+6)*VOL0/ZZ(KEL) + NUM1=NUM1+LL + NUM2=NUM2+6 + 180 CONTINUE + 181 CONTINUE + 182 CONTINUE +* END OF THE MAIN LOOP OVER ELEMENTS. +* +*---- +* PROCESSING OF 1-D AND 2-D CASES +*---- + LL1=(LX.EQ.1).AND.(NCODE(1).EQ.2).AND.(NCODE(2).EQ.5) + 1 .AND.(IELEM.GT.1) + LL2=(LX.EQ.1).AND.(NCODE(1).EQ.5).AND.(NCODE(2).EQ.2) + 1 .AND.(IELEM.GT.1) + IF(LL1.OR.LL2) THEN + NUM1=0 + DO 200 KEL=1,LX*LY*LZ + IF(MAT(KEL).EQ.0) GO TO 200 + DO 192 I=1,LC + DO 191 J=1,LC + DO 190 K=2,LC + L=(I-1)*LC*LC+(J-1)*LC+K + M=(I-1)*LC*LC+(J-1)*LC+1 + KN(NUM1+L)=KN(NUM1+M) + 190 CONTINUE + 191 CONTINUE + 192 CONTINUE + NUM1=NUM1+LL + 200 CONTINUE + ENDIF + LL1=(LY.EQ.1).AND.(NCODE(3).EQ.2).AND.(NCODE(4).EQ.5) + 1 .AND.(IELEM.GT.1) + LL2=(LY.EQ.1).AND.(NCODE(3).EQ.5).AND.(NCODE(4).EQ.2) + 1 .AND.(IELEM.GT.1) + IF(LL1.OR.LL2) THEN + NUM1=0 + DO 220 KEL=1,LX*LY*LZ + IF(MAT(KEL).EQ.0) GO TO 220 + DO 212 I=1,LC + DO 211 J=2,LC + DO 210 K=1,LC + L=(I-1)*LC*LC+(J-1)*LC+K + M=(I-1)*LC*LC+K + KN(NUM1+L)=KN(NUM1+M) + 210 CONTINUE + 211 CONTINUE + 212 CONTINUE + NUM1=NUM1+LL + 220 CONTINUE + ENDIF + LL1=(LZ.EQ.1).AND.(NCODE(5).EQ.2).AND.(NCODE(6).EQ.5) + 1 .AND.(IELEM.GT.1) + LL2=(LZ.EQ.1).AND.(NCODE(5).EQ.5).AND.(NCODE(6).EQ.2) + 1 .AND.(IELEM.GT.1) + IF(LL1.OR.LL2) THEN + NUM1=0 + DO 240 KEL=1,LX*LY*LZ + IF(MAT(KEL).EQ.0) GO TO 240 + DO 232 I=2,LC + DO 231 J=1,LC + DO 230 K=1,LC + L=(I-1)*LC*LC+(J-1)*LC+K + M=(J-1)*LC+K + KN(NUM1+L)=KN(NUM1+M) + 230 CONTINUE + 231 CONTINUE + 232 CONTINUE + NUM1=NUM1+LL + 240 CONTINUE + ENDIF +*---- +* JUXTAPOSITION OF A CHECKERBOARD OVER THE REACTOR DOMAIN +*---- + LZTOT=LZ*(LC-1)+1 + LYTOT=LY*(LC-1)+1 + LXTOT=LX*(LC-1)+1 + DO 250 I=1,LXTOT*LYTOT*LZTOT + IWRK(I)=-1 + 250 CONTINUE + NUM1=0 + KEL=0 + DO 272 K0=1,LZ + LK0=(K0-1)*(LC-1) + DO 271 K1=1,LY + LK1=(K1-1)*(LC-1) + DO 270 K2=1,LX + KEL=KEL+1 + IF(MAT(KEL).EQ.0) GO TO 270 + LK2=(K2-1)*(LC-1) + L=0 + DO 262 IK0=LK0+1,LK0+LC + I0=(IK0-1)*LXTOT*LYTOT + DO 261 IK1=LK1+1,LK1+LC + I1=I0+(IK1-1)*LXTOT + DO 260 IK2=LK2+1,LK2+LC + I2=I1+IK2 + L=L+1 + IND1=KN(NUM1+L) + IF(IND1.EQ.0) THEN + IWRK(I2)=0 + GO TO 260 + ENDIF + IF(IWRK(I2).EQ.-1) THEN + IWRK(I2)=IND1 + ELSE IF(IWRK(I2).EQ.0) THEN + KN(NUM1+L)=0 + ELSE IF(IWRK(I2).NE.IND1) THEN + CALL XABORT('TRIPKN: FAILURE OF THE RENUMBERING ALGORITHM(1).') + ENDIF + 260 CONTINUE + 261 CONTINUE + 262 CONTINUE + NUM1=NUM1+LL + 270 CONTINUE + 271 CONTINUE + 272 CONTINUE +*---- +* CALCULATION OF PERMUTATION VECTOR IP AND RENUMBERING OF UNKNOWNS +*---- + DO 280 I=1,MAXIP + IP(I)=0 + 280 CONTINUE + L4=0 + IF(NCODE(1).EQ.5) THEN + K2MIN=1+LC/2 + ELSE + K2MIN=1 + ENDIF + DO 292 K0=1,LZTOT + IK0=(K0-1)*LXTOT*LYTOT + DO 291 K1=1,LYTOT + IK1=IK0+(K1-1)*LXTOT + DO 290 K2=K2MIN,LXTOT + I=IWRK(IK1+K2) + IF(I.LE.0) GO TO 290 + IF(I.GT.MAXIP) THEN + CALL XABORT('TRIPKN: FAILURE OF THE RENUMBERING ALGORITHM(2).') + ENDIF + IF(IP(I).EQ.0) THEN + L4=L4+1 + IP(I)=L4 + ENDIF + 290 CONTINUE + 291 CONTINUE + 292 CONTINUE + DO 300 K=1,NUM1 + KNK=KN(K) + IF(KNK.NE.0) KN(K)=IP(KNK) + 300 CONTINUE + IF(IMPX.GT.0) WRITE (6,510) L4 + IF(IMPX.GT.2) WRITE (6,520) (VOL(I),I=1,LX*LY*LZ) + IF(L4.EQ.0) THEN + CALL XABORT('TRIPKN: FAILURE OF THE RENUMBERING ALGORITHM(3).') + ENDIF +* + IF(IMPX.LT.2) RETURN + IF(IELEM.EQ.1) THEN + WRITE (6,530) + NUM1=0 + NUM2=0 + DO 310 KEL=1,LX*LY*LZ + IF(MAT(KEL).LE.0) GO TO 310 + WRITE (6,540) KEL,(KN(NUM1+I),I=1,LL),(QFR(NUM2+I),I=1,6) + NUM1=NUM1+LL + NUM2=NUM2+6 + 310 CONTINUE + ELSE + WRITE (6,590) + NUM1=0 + DO 320 KEL=1,LX*LY*LZ + IF(MAT(KEL).LE.0) GO TO 320 + WRITE (6,600) KEL,(KN(NUM1+I),I=1,LL) + NUM1=NUM1+LL + 320 CONTINUE + WRITE (6,610) + NUM2=0 + DO 330 KEL=1,LX*LY*LZ + IF(MAT(KEL).LE.0) GO TO 330 + WRITE (6,620) KEL,(QFR(NUM2+I),I=1,6) + NUM2=NUM2+6 + 330 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IP,IWRK) + RETURN +* + 500 FORMAT(/38H TRIPKN: PRIMAL FINITE ELEMENT METHOD.//7H NUMBER, + 1 27H OF ELEMENTS ALONG X AXIS =,I3/20X,14HALONG Y AXIS =,I3/ + 2 20X,14HALONG Z AXIS =,I3) + 510 FORMAT(31H NUMBER OF UNKNOWNS PER GROUP =,I8) + 520 FORMAT(/20H VOLUMES PER ELEMENT/(1X,1P,10E13.4)) + 530 FORMAT(/22H NUMBERING OF UNKNOWNS//8H ELEMENT,5X,7HNUMBERS, + 1 41X,23HVOID BOUNDARY CONDITION) + 540 FORMAT(1X,I6,2X,8I6,2X,1P,6E11.2) + 590 FORMAT(/22H NUMBERING OF UNKNOWNS//5H ELE-/5H MENT,3X, + 1 7HNUMBERS) + 600 FORMAT(1X,I6,2X,20I6/(9X,20I6)) + 610 FORMAT(///24H VOID BOUNDARY CONDITION//8H ELEMENT,5X,3HQFR) + 620 FORMAT(1X,I6,4X,1P,6E11.2) + END diff --git a/Trivac/src/TRIPMA.f b/Trivac/src/TRIPMA.f new file mode 100755 index 0000000..de33a05 --- /dev/null +++ b/Trivac/src/TRIPMA.f @@ -0,0 +1,139 @@ +*DECK TRIPMA + SUBROUTINE TRIPMA(LC,T,TS,Q,QS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the unit matrices for a primal finite element method in 3-D. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* LC order of the unit matrices. +* T cartesian linear product vector. +* TS cylindrical linear product vector. +* Q cartesian stiffness matrix. +* QS cylindrical stiffness matrix. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE PARAMETERS +*---- + INTEGER LC,IJ1,IJ2,IJ3,ISR + REAL T(LC),TS(LC),Q(LC,LC),QS(LC,LC) +*---- +* LOCAL VARIABLES +*---- + COMMON /ELEM2/LL,LCC,IJ1(125),IJ2(125),IJ3(125),ISR(6,25), + 1 Q3DP1(125,125),Q3DP2(125,125),Q3DP3(125,125),R3DP(125), + 2 Q3DC1(125,125),Q3DC2(125,125),Q3DC3(125,125),R3DC(125), + 3 R2DP(25),R2DC(25) + SAVE /ELEM2/ +*---- +* CALCULATION OF COMMON /ELEM2/ +*---- + LCC=LC*LC + LL=LC*LC*LC + DO 5 L=1,LL + L1=1+MOD(L-1,LC) + L2=1+(L-L1)/LC + L3=1+MOD(L2-1,LC) + IJ1(L)=L1 + IJ2(L)=L3 + IJ3(L)=1+(L2-L3)/LC + 5 CONTINUE +*---- +* CALCULATION OF MATRIX ISR. +*---- + K1=0 + K2=0 + J1=0 + J2=0 + I1=0 + I2=0 + L=0 + DO 8 I=1,LC + DO 7 J=1,LC + DO 6 K=1,LC + L=L+1 + IF(K.EQ.1) THEN + K1=K1+1 + ISR(1,K1)=L + ELSE IF(K.EQ.LC) THEN + K2=K2+1 + ISR(2,K2)=L + ENDIF + IF(J.EQ.1) THEN + J1=J1+1 + ISR(3,J1)=L + ELSE IF(J.EQ.LC) THEN + J2=J2+1 + ISR(4,J2)=L + ENDIF + IF(I.EQ.1) THEN + I1=I1+1 + ISR(5,I1)=L + ELSE IF(I.EQ.LC) THEN + I2=I2+1 + ISR(6,I2)=L + ENDIF + 6 CONTINUE + 7 CONTINUE + 8 CONTINUE +*---- +* CALCULATION OF 3-D MASS AND STIFFNESS MATRICES FROM TENSORIAL PRODUCT +* OF 1-D MATRICES. +*---- + DO 20 I=1,LL + I1=IJ1(I) + I2=IJ2(I) + I3=IJ3(I) + DO 10 J=1,LL + J1=IJ1(J) + J2=IJ2(J) + J3=IJ3(J) + IF((I2.EQ.J2).AND.(I3.EQ.J3)) THEN + Q3DP1(I,J)=Q(I1,J1)*T(I2)*T(I3) + Q3DC1(I,J)=QS(I1,J1)*T(I2)*T(I3) + ELSE + Q3DP1(I,J)=0.0 + Q3DC1(I,J)=0.0 + ENDIF + IF((I1.EQ.J1).AND.(I3.EQ.J3)) THEN + Q3DP2(I,J)=T(I1)*Q(I2,J2)*T(I3) + Q3DC2(I,J)=TS(I1)*Q(I2,J2)*T(I3) + ELSE + Q3DP2(I,J)=0.0 + Q3DC2(I,J)=0.0 + ENDIF + IF((I1.EQ.J1).AND.(I2.EQ.J2)) THEN + Q3DP3(I,J)=T(I1)*T(I2)*Q(I3,J3) + Q3DC3(I,J)=TS(I1)*T(I2)*Q(I3,J3) + ELSE + Q3DP3(I,J)=0.0 + Q3DC3(I,J)=0.0 + ENDIF + 10 CONTINUE + R3DP(I)=T(I1)*T(I2)*T(I3) + R3DC(I)=TS(I1)*T(I2)*T(I3) + 20 CONTINUE +*---- +* CALCULATION OF 2-D MASS MATRICES FROM TENSORIAL PRODUCT OF 1-D +* MATRICES. +*---- + DO 30 I=1,LC*LC + I1=IJ1(I) + I2=IJ2(I) + R2DP(I)=T(I1)*T(I2) + R2DC(I)=TS(I1)*T(I2) + 30 CONTINUE + RETURN + END diff --git a/Trivac/src/TRIPRH.f b/Trivac/src/TRIPRH.f new file mode 100755 index 0000000..f11b5bf --- /dev/null +++ b/Trivac/src/TRIPRH.f @@ -0,0 +1,170 @@ +*DECK TRIPRH + SUBROUTINE TRIPRH(ISPLH,IPTRK,LX,LZ,LL4,SIDE,ZZZ,ZZ,KN,QFR,IQFR, + 1 VOL,MAT,NCODE,ICODE,ZCODE,IMPX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Numbering corresponding to a mesh corner finite difference or +* Lagrangian finite element discretization of a 3-D hexagonal geometry. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Benaboud +* +*Parameters: input +* ISPLH type of hexagonal finite element: +* =1 for hexagonal element with 6 points; +* =2 for hexagonal element with 7 points; +* =3 for triangular element. +* IPTRK L_TRACK pointer to the tracking information. +* IMPX print parameter. +* LX number of elements. +* LZ number of axial planes. +* NCODE type of boundary condition applied on each side (I=1: hbc): +* NCODE(I)=1: VOID; =2: REFL; =5: SYME; +* =7: ZERO. +* ICODE physical albedo index on each side of the domain. +* ZCODE albedo corresponding to boundary condition 'VOID' on each +* side (ZCODE(I)=0.0 by default). +* MAT mixture index assigned to each element. +* SIDE side of the hexagon. +* ZZZ Z-coordinates of the axial planes. +* +*Parameters: output +* LL4 order of system matrices. +* ZZ axial width of each element. +* VOL volume of each element. +* KN element-ordered unknown list. Dimensionned to LC*LX*LZ +* where LC= 14 for triangle and 12 for hexagon. +* QFR element-ordered boundary conditions. +* IQFR element-ordered physical albedo indices. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK + INTEGER ISPLH,LX,LZ,LL4,KN(*),IQFR(8*LX*LZ),MAT(LX*LZ),NCODE(6), + 1 ICODE(6),IMPX + REAL SIDE,ZZZ(LZ+1),ZZ(LX*LZ),QFR(8*LX*LZ),VOL(LX*LZ),ZCODE(6) +* + ALB(X)=0.5*(1.0-X)/(1.0+X) +* + IPAR=ISPLH + IK=0 + IF(ISPLH.EQ.1) THEN + IK=12 + ELSE IF(ISPLH.EQ.2) THEN + IK=14 + ELSE + CALL XABORT('TRIPRH: DISCRETIZATION NOT AVAILABLE.') + ENDIF + CALL TRIHEX(IPAR+2,LX,LZ,LL4,MAT,KN,NCODE,IPTRK) +*---- +* COMPUTE BOUNDARY CONDITIONS +*---- + FRZ=1. + KEL=0 + NUM1=0 + DO 15 KZ=1,LZ + DO 10 KX=1,LX + KEL=KEL + 1 + ZZ(KEL)=0.0 + VOL(KEL)=0.0 + IF(MAT(KEL).LE.0) GO TO 10 + ZZ(KEL)=ZZZ(KZ+1) - ZZZ(KZ) + DO 20 IC=1,6 + QFR(NUM1+IC)=0.0 + IQFR(NUM1+IC)=0 + NV=NEIGHB (KX,IC,9,LX,POIDS) + IF(NV.GT.LX) THEN + IF((NCODE(1).EQ.1).AND.(ICODE(1).EQ.0)) THEN + QFR(NUM1+IC)=ALB(ZCODE(1)) + ELSE IF(NCODE(1).EQ.1) THEN + QFR(NUM1+IC)=1.0 + IQFR(NUM1+IC)=ICODE(1) + ENDIF + ELSE IF(MAT(NV).LE.0) THEN + IF((NCODE(1).EQ.1).AND.(ICODE(1).EQ.0)) THEN + QFR(NUM1+IC)=ALB(ZCODE(1)) + ELSE IF(NCODE(1).EQ.1) THEN + QFR(NUM1+IC)=1.0 + IQFR(NUM1+IC)=ICODE(1) + ENDIF + ENDIF + 20 CONTINUE + QFR(NUM1+7)=0.0 + QFR(NUM1+8)=0.0 + IF((NCODE(5).EQ.1).AND.(KZ.EQ.1).AND.(ICODE(5).EQ.0)) THEN + QFR(NUM1+7)=ALB(ZCODE(5)) + ELSE IF((NCODE(5).EQ.1).AND.(KZ.EQ.1)) THEN + QFR(NUM1+7)=1.0 + IQFR(NUM1+7)=ICODE(5) + ENDIF + IF((NCODE(6).EQ.1).AND.(KZ.EQ.LZ).AND.(ICODE(6).EQ.0)) THEN + QFR(NUM1+8)=ALB(ZCODE(6)) + ELSE IF((NCODE(6).EQ.1).AND.(KZ.EQ.LZ)) THEN + QFR(NUM1+8)=1.0 + IQFR(NUM1+8)=ICODE(6) + ENDIF + IF((NCODE(5).EQ.5).AND.(KZ.EQ.1)) THEN + QFR(NUM1+7)=QFR(NUM1+8) + IQFR(NUM1+7)=IQFR(NUM1+8) + FRZ=0.5 + ELSE IF((NCODE(6).EQ.5).AND.(KZ.EQ.LZ)) THEN + QFR(NUM1+7)=QFR(NUM1+8) + IQFR(NUM1+7)=IQFR(NUM1+8) + FRZ=0.5 + ENDIF + ZZ(KEL)=ZZ(KEL)*FRZ +* +* COMPUTE VOLUMES. + VOL(KEL)=2.59807587*SIDE*SIDE*ZZ(KEL) +* + DO 30 IC=1,6 + QFR(NUM1+IC)=QFR(NUM1+IC)*SIDE*ZZ(KEL) + 30 CONTINUE + QFR(NUM1+7)=QFR(NUM1+7)*SIDE*SIDE + QFR(NUM1+8)=QFR(NUM1+8)*SIDE*SIDE + NUM1=NUM1+8 + 10 CONTINUE + 15 CONTINUE + IF(IMPX.GT.2) WRITE(6,720) (VOL(I),I=1,LX*LZ) +* + IF(IMPX.GT.2) THEN + NUM1=0 + NUM2=0 + WRITE(6,730) + DO 510 KZ=1,LZ + WRITE(6,'(/13H PLANE NUMBER,I6)') KZ + IF(IK.EQ.12) WRITE(6,740) + IF(IK.EQ.14) WRITE(6,745) + DO 500 KX=1,LX + IF(MAT(KX+(KZ-1)*LX).LE.0) GO TO 500 + K=KX+(KZ-1)*LX + IF(IK.EQ.12) + > WRITE(6,750) K,(KN(NUM1+I),I=1,12),(QFR(NUM2+I),I=1,8) + IF(IK.EQ.14) + > WRITE(6,760) K,(KN(NUM1+I),I=1,14),(QFR(NUM2+I),I=1,8) + NUM1=NUM1+IK + NUM2=NUM2+8 + 500 CONTINUE + 510 CONTINUE + ENDIF + RETURN +* +720 FORMAT(/20H VOLUMES PER ELEMENT/(1X,10(1X,E12.5))) +730 FORMAT(/22H NUMBERING OF UNKNOWNS/1X,21(1H-)) +740 FORMAT(/8H ELEMENT,3X,7HNUMBERS,58X,23HVOID BOUNDARY CONDITION) +745 FORMAT(/8H ELEMENT,3X,7HNUMBERS,68X,23HVOID BOUNDARY CONDITION) +750 FORMAT (3X,I4,4X,12I5,3X,8F6.2) +760 FORMAT (3X,I4,4X,14I5,3X,8F6.2) + END diff --git a/Trivac/src/TRIPXX.f b/Trivac/src/TRIPXX.f new file mode 100755 index 0000000..d801d3a --- /dev/null +++ b/Trivac/src/TRIPXX.f @@ -0,0 +1,381 @@ +*DECK TRIPXX + SUBROUTINE TRIPXX (IR,MAXKN,NEL,LL4,VOL,MAT,XSGD,XX,YY,ZZ,DD,KN, + 1 QFR,MUX,IPX,CYLIND,LC,T,TS,Q,QS,A11X) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Assembly of system matrices for a primal finite element method in 3-D. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IR first dimension for matrix SGD. +* MAXKN first dimension for matrix KN. +* NEL total number of finite elements. +* LL4 order of system matrices. +* MAT mixture index assigned to each element. +* VOL volume of each element. +* XX X-directed mesh spacings. +* YY Y-directed mesh spacings. +* ZZ Z-directed mesh spacings. +* DD values used with a cylindrical geometry. +* KN element-ordered unknown list. +* QFR element-ordered boundary conditions. +* XSGD nuclear properties, derivatives or first variations of +* nuclear properties per material mixture: +* XSGD(L,1): X-oriented diffusion coefficients; +* XSGD(L,2): Y-oriented diffusion coefficients; +* XSGD(L,3): Z-oriented diffusion coefficients; +* XSGD(L,4): removal macroscopic cross section. +* MUX X-oriented compressed storage mode indices. +* MUY Y-oriented compressed storage mode indices. +* MUZ Z-oriented compressed storage mode indices. +* IPX X-oriented permutation matrices. +* IPY Y-oriented permutation matrices. +* IPZ Z-oriented permutation matrices. +* CYLIND cylinderization flag (=.true. for cylindrical geometry). +* LC order of the unit matrices. +* T cartesian linear product vector. +* TS cylindrical linear product vector. +* Q cartesian stiffness matrix. +* QS cylindrical stiffness matrix. +* +*Parameters: output +* A11X X-oriented matrix corresponding to the divergence (i.e +* leakage) and removal terms (should be initialized by the +* calling program). +* A11Y Y-oriented matrix corresponding to the divergence (i.e +* leakage) and removal terms (should be initialized by the +* calling program). +* A11Z Z-oriented matrix corresponding to the divergence (i.e +* leakage) and removal terms (should be initialized by the +* calling program). +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IR,MAXKN,NEL,LL4,MAT(NEL),KN(MAXKN),MUX(LL4),IPX(LL4),LC + REAL VOL(NEL),XSGD(IR,4),XX(NEL),YY(NEL),ZZ(NEL),DD(NEL), + 1 QFR(6*NEL),T(LC),TS(LC),Q(LC,LC),QS(LC,LC),A11X(*) + LOGICAL CYLIND +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION VAR1,VOL1,VOL2,VOL3,QQX,QQY,QQZ + COMMON /ELEM2/LL,LCC,IJ1(125),IJ2(125),IJ3(125),ISR(6,25), + 1 Q3DP1(125,125),Q3DP2(125,125),Q3DP3(125,125),R3DP(125), + 2 Q3DC1(125,125),Q3DC2(125,125),Q3DC3(125,125),R3DC(125), + 3 R2DP(25),R2DC(25) +*---- +* X-DIRECTED COUPLINGS. +* +* ASSEMBLY OF MATRIX A11X. +*---- + CALL TRIPMA(LC,T,TS,Q,QS) + NUM1=0 + NUM2=0 + DO 90 K=1,NEL + L=MAT(K) + IF(L.EQ.0) GO TO 90 + VOL0=VOL(K) + IF(VOL0.EQ.0.0) GO TO 80 + DX=XX(K) + DY=YY(K) + DZ=ZZ(K) + VOL1=VOL0/(DX*DX) + VOL2=VOL0/(DY*DY) + VOL3=VOL0/(DZ*DZ) + DO 50 I=1,LL + IND1=KN(NUM1+I) + IF(IND1.EQ.0) GO TO 50 + INX1=IPX(IND1) + KEY0=MUX(INX1) + IF(CYLIND) THEN + RR=(R3DP(I)+R3DC(I)*DX/DD(K))*VOL0 + ELSE + RR=R3DP(I)*VOL0 + ENDIF + A11X(KEY0)=A11X(KEY0)+RR*XSGD(L,4) + KEY0=KEY0-INX1 + DO 40 J=1,LL + IND2=KN(NUM1+J) + IF(IND2.EQ.0) GO TO 40 + INX2=IPX(IND2) + IF(INX2.EQ.INX1) THEN + IF(CYLIND) THEN + QQX=(Q3DP1(I,J)+Q3DC1(I,J)*DX/DD(K))*VOL1 + QQY=(Q3DP2(I,J)+Q3DC2(I,J)*DX/DD(K))*VOL2 + QQZ=(Q3DP3(I,J)+Q3DC3(I,J)*DX/DD(K))*VOL3 + ELSE + QQX=Q3DP1(I,J)*VOL1 + QQY=Q3DP2(I,J)*VOL2 + QQZ=Q3DP3(I,J)*VOL3 + ENDIF + KEY=KEY0+INX2 + VAR1=QQX*XSGD(L,1)+QQY*XSGD(L,2)+QQZ*XSGD(L,3) + A11X(KEY)=REAL(A11X(KEY)+VAR1) + ELSE IF((INX2.LT.INX1).AND.(IJ2(I).EQ.IJ2(J)).AND. + 1 (IJ3(I).EQ.IJ3(J))) THEN + IF(CYLIND) THEN + QQX=(Q3DP1(I,J)+Q3DC1(I,J)*DX/DD(K))*VOL1 + ELSE + QQX=Q3DP1(I,J)*VOL1 + ENDIF + KEY=KEY0+INX2 + A11X(KEY)=REAL(A11X(KEY)+QQX*XSGD(L,1)) + ENDIF + 40 CONTINUE + 50 CONTINUE + DO 70 IC=1,6 + QFR1=QFR(NUM2+IC) + IF(QFR1.EQ.0.0) GO TO 70 + DO 60 I1=1,LCC + I=ISR(IC,I1) + IND1=KN(NUM1+I) + IF(IND1.EQ.0) GO TO 60 + INX1=IPX(IND1) + KEY=MUX(INX1) + IF(CYLIND) THEN + IF(IC.EQ.1) THEN + CRZ=-0.5*R2DP(I1) + ELSE IF(IC.EQ.2) THEN + CRZ=0.5*R2DP(I1) + ELSE + CRZ=R2DC(I1) + ENDIF + RR=(R2DP(I1)+CRZ*DX/DD(K)) + ELSE + RR=R2DP(I1) + ENDIF + A11X(KEY)=A11X(KEY)+RR*QFR1 + 60 CONTINUE + 70 CONTINUE + 80 NUM1=NUM1+LL + NUM2=NUM2+6 + 90 CONTINUE + RETURN + END +* + SUBROUTINE TRIPXY (IR,MAXKN,NEL,LL4,VOL,MAT,XSGD,XX,YY,ZZ,DD,KN, + 1 QFR,MUY,IPY,CYLIND,LC,T,TS,Q,QS,A11Y) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IR,MAXKN,NEL,LL4,MAT(NEL),KN(MAXKN),MUY(LL4),IPY(LL4),LC + REAL VOL(NEL),XSGD(IR,4),XX(NEL),YY(NEL),ZZ(NEL),DD(NEL), + 1 QFR(6*NEL),T(LC),TS(LC),Q(LC,LC),QS(LC,LC),A11Y(*) + LOGICAL CYLIND +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION VAR1,VOL1,VOL2,VOL3,QQX,QQY,QQZ + COMMON /ELEM2/LL,LCC,IJ1(125),IJ2(125),IJ3(125),ISR(6,25), + 1 Q3DP1(125,125),Q3DP2(125,125),Q3DP3(125,125),R3DP(125), + 2 Q3DC1(125,125),Q3DC2(125,125),Q3DC3(125,125),R3DC(125), + 3 R2DP(25),R2DC(25) +*---- +* Y-DIRECTED COUPLINGS. +* +* ASSEMBLY OF MATRIX A11Y. +*---- + CALL TRIPMA(LC,T,TS,Q,QS) + NUM1=0 + NUM2=0 + DO 180 K=1,NEL + L=MAT(K) + IF(L.EQ.0) GO TO 180 + VOL0=VOL(K) + IF(VOL0.EQ.0.0) GO TO 170 + DX=XX(K) + DY=YY(K) + DZ=ZZ(K) + VOL1=VOL0/(DX*DX) + VOL2=VOL0/(DY*DY) + VOL3=VOL0/(DZ*DZ) + DO 140 I=1,LL + IND1=KN(NUM1+I) + IF(IND1.EQ.0) GO TO 140 + INY1=IPY(IND1) + KEY0=MUY(INY1) + IF(CYLIND) THEN + RR=(R3DP(I)+R3DC(I)*DX/DD(K))*VOL0 + ELSE + RR=R3DP(I)*VOL0 + ENDIF + A11Y(KEY0)=A11Y(KEY0)+RR*XSGD(L,4) + KEY0=KEY0-INY1 + DO 130 J=1,LL + IND2=KN(NUM1+J) + IF(IND2.EQ.0) GO TO 130 + INY2=IPY(IND2) + IF(INY2.EQ.INY1) THEN + IF(CYLIND) THEN + QQX=(Q3DP1(I,J)+Q3DC1(I,J)*DX/DD(K))*VOL1 + QQY=(Q3DP2(I,J)+Q3DC2(I,J)*DX/DD(K))*VOL2 + QQZ=(Q3DP3(I,J)+Q3DC3(I,J)*DX/DD(K))*VOL3 + ELSE + QQX=Q3DP1(I,J)*VOL1 + QQY=Q3DP2(I,J)*VOL2 + QQZ=Q3DP3(I,J)*VOL3 + ENDIF + KEY=KEY0+INY2 + VAR1=QQX*XSGD(L,1)+QQY*XSGD(L,2)+QQZ*XSGD(L,3) + A11Y(KEY)=REAL(A11Y(KEY)+VAR1) + ELSE IF((INY2.LT.INY1).AND.(IJ1(I).EQ.IJ1(J)).AND. + 1 (IJ3(I).EQ.IJ3(J))) THEN + IF(CYLIND) THEN + QQY=(Q3DP2(I,J)+Q3DC2(I,J)*DX/DD(K))*VOL2 + ELSE + QQY=Q3DP2(I,J)*VOL2 + ENDIF + KEY=KEY0+INY2 + A11Y(KEY)=REAL(A11Y(KEY)+QQY*XSGD(L,2)) + ENDIF + 130 CONTINUE + 140 CONTINUE + DO 160 IC=1,6 + QFR1=QFR(NUM2+IC) + IF(QFR1.EQ.0.0) GO TO 160 + DO 150 I1=1,LCC + I=ISR(IC,I1) + IND1=KN(NUM1+I) + IF(IND1.EQ.0) GO TO 150 + INY1=IPY(IND1) + KEY=MUY(INY1) + IF(CYLIND) THEN + IF(IC.EQ.1) THEN + CRZ=-0.5*R2DP(I1) + ELSE IF(IC.EQ.2) THEN + CRZ=0.5*R2DP(I1) + ELSE + CRZ=R2DC(I1) + ENDIF + RR=(R2DP(I1)+DX*CRZ/DD(K)) + ELSE + RR=R2DP(I1) + ENDIF + A11Y(KEY)=A11Y(KEY)+RR*QFR1 + 150 CONTINUE + 160 CONTINUE + 170 NUM1=NUM1+LL + NUM2=NUM2+6 + 180 CONTINUE + RETURN + END +* + SUBROUTINE TRIPXZ (IR,MAXKN,NEL,LL4,VOL,MAT,XSGD,XX,YY,ZZ,DD,KN, + 1 QFR,MUZ,IPZ,CYLIND,LC,T,TS,Q,QS,A11Z) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IR,MAXKN,NEL,LL4,MAT(NEL),KN(MAXKN),MUZ(LL4),IPZ(LL4),LC + REAL VOL(NEL),XSGD(IR,4),XX(NEL),YY(NEL),ZZ(NEL),DD(NEL), + 1 QFR(6*NEL),T(LC),TS(LC),Q(LC,LC),QS(LC,LC),A11Z(*) + LOGICAL CYLIND +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION VAR1,VOL1,VOL2,VOL3,QQX,QQY,QQZ + COMMON /ELEM2/LL,LCC,IJ1(125),IJ2(125),IJ3(125),ISR(6,25), + 1 Q3DP1(125,125),Q3DP2(125,125),Q3DP3(125,125),R3DP(125), + 2 Q3DC1(125,125),Q3DC2(125,125),Q3DC3(125,125),R3DC(125), + 3 R2DP(25),R2DC(25) +*---- +* Z-DIRECTED COUPLINGS. +* +* ASSEMBLY OF MATRIX A11Z. +*---- + CALL TRIPMA(LC,T,TS,Q,QS) + NUM1=0 + NUM2=0 + DO 270 K=1,NEL + L=MAT(K) + IF(L.EQ.0) GO TO 270 + VOL0=VOL(K) + IF(VOL0.EQ.0.0) GO TO 260 + DX=XX(K) + DY=YY(K) + DZ=ZZ(K) + VOL1=VOL0/(DX*DX) + VOL2=VOL0/(DY*DY) + VOL3=VOL0/(DZ*DZ) + DO 230 I=1,LL + IND1=KN(NUM1+I) + IF(IND1.EQ.0) GO TO 230 + INZ1=IPZ(IND1) + KEY0=MUZ(INZ1) + IF(CYLIND) THEN + RR=(R3DP(I)+R3DC(I)*DX/DD(K))*VOL0 + ELSE + RR=R3DP(I)*VOL0 + ENDIF + A11Z(KEY0)=A11Z(KEY0)+RR*XSGD(L,4) + KEY0=KEY0-INZ1 + DO 220 J=1,LL + IND2=KN(NUM1+J) + IF(IND2.EQ.0) GO TO 220 + INZ2=IPZ(IND2) + IF(INZ2.EQ.INZ1) THEN + IF(CYLIND) THEN + QQX=(Q3DP1(I,J)+Q3DC1(I,J)*DX/DD(K))*VOL1 + QQY=(Q3DP2(I,J)+Q3DC2(I,J)*DX/DD(K))*VOL2 + QQZ=(Q3DP3(I,J)+Q3DC3(I,J)*DX/DD(K))*VOL3 + ELSE + QQX=Q3DP1(I,J)*VOL1 + QQY=Q3DP2(I,J)*VOL2 + QQZ=Q3DP3(I,J)*VOL3 + ENDIF + KEY=KEY0+INZ2 + VAR1=QQX*XSGD(L,1)+QQY*XSGD(L,2)+QQZ*XSGD(L,3) + A11Z(KEY)=REAL(A11Z(KEY)+VAR1) + ELSE IF((INZ2.LT.INZ1).AND.(IJ1(I).EQ.IJ1(J)).AND. + 1 (IJ2(I).EQ.IJ2(J))) THEN + IF(CYLIND) THEN + QQZ=(Q3DP3(I,J)+Q3DC3(I,J)*DX/DD(K))*VOL3 + ELSE + QQZ=Q3DP3(I,J)*VOL3 + ENDIF + KEY=KEY0+INZ2 + A11Z(KEY)=REAL(A11Z(KEY)+QQZ*XSGD(L,3)) + ENDIF + 220 CONTINUE + 230 CONTINUE + DO 250 IC=1,6 + QFR1=QFR(NUM2+IC) + IF(QFR1.EQ.0.0) GO TO 250 + DO 240 I1=1,LCC + I=ISR(IC,I1) + IND1=KN(NUM1+I) + IF(IND1.EQ.0) GO TO 240 + INZ1=IPZ(IND1) + KEY=MUZ(INZ1) + IF(CYLIND) THEN + IF(IC.EQ.1) THEN + CRZ=-0.5*R2DP(I1) + ELSE IF(IC.EQ.2) THEN + CRZ=0.5*R2DP(I1) + ELSE + CRZ=R2DC(I1) + ENDIF + RR=(R2DP(I1)+DX*CRZ/DD(K)) + ELSE + RR=R2DP(I1) + ENDIF + A11Z(KEY)=A11Z(KEY)+RR*QFR1 + 240 CONTINUE + 250 CONTINUE + 260 NUM1=NUM1+LL + NUM2=NUM2+6 + 270 CONTINUE + RETURN + END diff --git a/Trivac/src/TRIRCA.f b/Trivac/src/TRIRCA.f new file mode 100755 index 0000000..34cf544 --- /dev/null +++ b/Trivac/src/TRIRCA.f @@ -0,0 +1,182 @@ +*DECK TRIRCA + SUBROUTINE TRIRCA(IPMACR,IPMACP,NGRP,NBMIX,NANI,LDIFF,IL,IPR,RCAT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the RCAT removal matrix in SPN cases. +* +*Copyright: +* Copyright (C) 2012 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPMACR L_MACROLIB pointer to the unperturbed cross sections. +* IPMACP L_MACROLIB pointer to the perturbed cross sections if +* IPR.gt.0. Equal to IPMACR if IPR=0. +* NGRP number of energy groups. +* NBMIX total number of material mixtures in the macrolib. +* NANI maximum scattering order recovered from tracking and macrolib. +* LDIFF flag set to .true. to use 1/3D as 'NTOT1' cross sections. +* IL scattering Legendre order. +* IPR type of assembly: +* =0: calculation of the system matrices; +* =1: calculation of the derivative of these matrices; +* =2: calculation of the first variation of these matrices; +* =3: identical to IPR=2, but these variation are added to +* unperturbed system matrices. +* +*Parameters: output +* RCAT removal matrix. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMACR,IPMACP + INTEGER NGRP,NBMIX,NANI,IL,IPR + LOGICAL LDIFF + DOUBLE PRECISION RCAT(NGRP,NGRP,NBMIX) +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPMACR,JPMACP,KPMACR,KPMACP + CHARACTER TEXT12*12,CM*2,HSMG*131 + DOUBLE PRECISION OTH + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS + REAL, ALLOCATABLE, DIMENSION(:) :: WORK + REAL, ALLOCATABLE, DIMENSION(:,:) :: SGD + PARAMETER(OTH=1.0D0/3.0D0) +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IJJ(NBMIX),NJJ(NBMIX),IPOS(NBMIX)) + ALLOCATE(SGD(NBMIX,3),WORK(NBMIX*NGRP)) +* + JPMACR=LCMGID(IPMACR,'GROUP') + JPMACP=LCMGID(IPMACP,'GROUP') + WRITE(CM,'(I2.2)') IL-1 + RCAT(:NGRP,:NGRP,:NBMIX)=0.0D0 + DO 100 IGR=1,NGRP +* PROCESS SECONDARY GROUP IGR. + KPMACP=LCMGIL(JPMACP,IGR) + SGD(:NBMIX,1)=0.0 + CALL LCMLEN(KPMACP,'SIGW'//CM,LENGT,ITYLCM) + IF((LENGT.GT.0).AND.(IL.LE.NANI)) THEN + IF(LENGT.GT.NBMIX) CALL XABORT('TRIRCA: INVALID LENGTH FOR' + 1 //' SIGW'//CM//' CROSS SECTIONS.') + CALL LCMGET(KPMACP,'SIGW'//CM,SGD(1,1)) + ENDIF + WRITE(TEXT12,'(4HNTOT,I1)') MIN(IL-1,9) + CALL LCMLEN(KPMACP,TEXT12,LENGT,ITYLCM) + CALL LCMLEN(KPMACP,'NTOT1',LENGT1,ITYLCM) + IF((IL.EQ.1).AND.(LENGT.NE.NBMIX)) CALL XABORT('TRIRCA: NO NTOT0' + 1 //' CROSS SECTIONS.') + IF(MOD(IL-1,2).EQ.0) THEN +* macroscopic total cross section in even-parity equations. + IF(LENGT.EQ.NBMIX) THEN + CALL LCMGET(KPMACP,TEXT12,SGD(1,2)) + ELSE + CALL LCMGET(KPMACP,'NTOT0',SGD(1,2)) + ENDIF + DO 10 IBM=1,NBMIX + IF((SGD(IBM,2)-SGD(IBM,1).LT.0.0).AND.(IPR.EQ.0)) THEN + WRITE(HSMG,'(28HTRIRCA: NEGATIVE XS IN GROUP,I5)') IGR + CALL XABORT(HSMG) + ENDIF + RCAT(IGR,IGR,IBM)=SGD(IBM,2)-SGD(IBM,1) + 10 CONTINUE + ELSE +* macroscopic total cross section in odd-parity equations. + IF(LDIFF) THEN + CALL LCMLEN(KPMACP,'DIFF',LENGT,ITYLCM) + IF(LENGT.EQ.0) CALL XABORT('TRIRCA: DIFFUSION COEFFICIENTS' + 1 //' EXPECTED IN THE MACROLIB.') + IF(LENGT.GT.NBMIX) CALL XABORT('TRIRCA: INVALID LENGTH FOR' + 1 //' DIFFUSION COEFFICIENTS.') + CALL LCMGET(KPMACP,'DIFF',SGD(1,2)) + IF(IPR.EQ.0) THEN + DO 20 IBM=1,NBMIX + RCAT(IGR,IGR,IBM)=OTH/SGD(IBM,2) + 20 CONTINUE + ELSE IF(IPR.EQ.1) THEN + KPMACR=LCMGIL(JPMACR,IGR) + CALL LCMGET(KPMACR,'DIFF',SGD(1,3)) + DO 30 IBM=1,NBMIX + RCAT(IGR,IGR,IBM)=-OTH*SGD(IBM,2)/SGD(IBM,3)**2 + 30 CONTINUE + ELSE IF(IPR.EQ.2) THEN + KPMACR=LCMGIL(JPMACR,IGR) + CALL LCMGET(KPMACR,'DIFF',SGD(1,3)) + DO 40 IBM=1,NBMIX + RCAT(IGR,IGR,IBM)=OTH/(SGD(IBM,2)+SGD(IBM,3)) + 1 -OTH/SGD(IBM,3) + 40 CONTINUE + ELSE IF(IPR.EQ.3) THEN + KPMACR=LCMGIL(JPMACR,IGR) + CALL LCMGET(KPMACR,'DIFF',SGD(1,3)) + DO 50 IBM=1,NBMIX + RCAT(IGR,IGR,IBM)=OTH/(SGD(IBM,2)+SGD(IBM,3)) + 50 CONTINUE + ENDIF + GO TO 100 + ELSE + IF(LENGT.EQ.NBMIX) THEN + CALL LCMGET(KPMACP,TEXT12,SGD(1,2)) + ELSE IF(LENGT1.EQ.NBMIX) THEN + CALL LCMGET(KPMACP,'NTOT1',SGD(1,2)) + ELSE + CALL LCMGET(KPMACP,'NTOT0',SGD(1,2)) + ENDIF + DO 60 IBM=1,NBMIX + RCAT(IGR,IGR,IBM)=SGD(IBM,2)-SGD(IBM,1) + 60 CONTINUE + ENDIF + IF(IPR.EQ.0) THEN + DO 65 IBM=1,NBMIX + IF(RCAT(IGR,IGR,IBM).LT.0.0) THEN + WRITE(HSMG,'(39HTRIRCA: INVALID CROSS-SECTION DATA (IL=, + 1 I3,2H).)') IL + CALL XABORT(HSMG) + ENDIF + 65 CONTINUE + ENDIF + ENDIF + CALL LCMLEN(KPMACP,'NJJS'//CM,LENGT,ITYLCM) + IF(LENGT.GT.NBMIX) CALL XABORT('TRIRCA: INVALID LENGTH FOR NJJS' + 1 //CM//' INFORMATION.') + IF((LENGT.GT.0).AND.(IL.LE.NANI)) THEN + CALL LCMGET(KPMACP,'NJJS'//CM,NJJ) + CALL LCMGET(KPMACP,'IJJS'//CM,IJJ) + IGMIN=IGR + IGMAX=IGR + DO 70 IBM=1,NBMIX + IGMIN=MIN(IGMIN,IJJ(IBM)-NJJ(IBM)+1) + IGMAX=MAX(IGMAX,IJJ(IBM)) + 70 CONTINUE + CALL LCMGET(KPMACP,'IPOS'//CM,IPOS) + CALL LCMGET(KPMACP,'SCAT'//CM,WORK) + DO 90 JGR=IGMAX,IGMIN,-1 + IF(JGR.EQ.IGR) GO TO 90 + DO 80 IBM=1,NBMIX + IF((JGR.GT.IJJ(IBM)-NJJ(IBM)).AND.(JGR.LE.IJJ(IBM))) THEN + RCAT(IGR,JGR,IBM)=-WORK(IPOS(IBM)+IJJ(IBM)-JGR) + ENDIF + 80 CONTINUE + 90 CONTINUE + ENDIF + 100 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(WORK,SGD) + DEALLOCATE(IPOS,NJJ,IJJ) + RETURN + END diff --git a/Trivac/src/TRIRMA.f b/Trivac/src/TRIRMA.f new file mode 100755 index 0000000..6f001a2 --- /dev/null +++ b/Trivac/src/TRIRMA.f @@ -0,0 +1,156 @@ +*DECK TRIRMA + SUBROUTINE TRIRMA(ISPLH,R,Q,RH,QH,RT,QT,LL,LC,ISR,QTHP,QTHZ,RTHG, + > HW,HX,HY,HZ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the unit matrices for a mesh corner finite difference +* discretization in hexagonal geometry. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Benaboud +* +*Parameters: input +* ISPLH hexagonal mesh-splitting flag: +* =1 for complete hexagons; >1 for triangular elements. +* R unit matrix. +* Q unit matrix. +* RH unit matrix. +* QH unit matrix. +* RT unit matrix. +* QT unit matrix. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE PARAMETERS +*---- + INTEGER ISPLH + REAL R(2,2),Q(2,2),RH(6,6),QH(6,6),RT(3,3),QT(3,3) + DOUBLE PRECISION QTHP(14,14),QTHZ(14,14),RTHG(14,14), + > HW(14,14),HX(14,14),HY(14,14),HZ(14,14) +*---- +* LOCAL VARIABLES +*---- + INTEGER IJ1(14),IJ2(14),ISR(8,25),ILIEN(6,3),IJ27(14),ISRH(8,6), + > ISRT(8,7),IJ16(12),IJ26(12),IJ17(14) + REAL HL(2,2),RFAC(28,7),RH2(7,7),QH2(7,7),RF6(24,6),RF7(28,7) + DATA HL / 1.0,2*0.0,1.0/ + DATA ILIEN/6*4,2,1,5,6,7,3,1,5,6,7,3,2/ + DATA IJ16,IJ26 /1,2,3,4,5,6,1,2,3,4,5,6,6*1,6*2/ + DATA IJ17,IJ27 /1,2,3,4,5,6,7,1,2,3,4,5,6,7,7*1,7*2/ + DATA ISRT/2,1,5,6,7,3,1,8,1,5,6,7,3,2,2,9,9,8,12,13,14,10,3,10, + > 8,12,13,14,10,9,4,11,6*0,5,12,6*0,6,13,6*0,7,14/ + DATA ISRH/2,1,4,5,6,3,1,7,1,4,5,6,3,2,2,8,8,7,10,11,12,9,3,9, + > 7,10,11,12,9,8,4,10,6*0,5,11,6*0,6,12/ + DATA RF6/ + >1.0,0.0,0.0,0.0,0.0,0.0,1.0,1.0,0.0,0.0,1.0,0.5, + >1.0,0.0,1.0,1.0,0.0,0.5,1.0,0.0,0.0,0.0,0.0,0.0, + >0.0,1.0,1.0,1.0,0.5,0.0,1.0,1.0,0.0,0.0,0.5,1.0, + >0.0,1.0,0.0,0.0,0.0,0.0,0.0,1.0,0.0,0.0,0.0,0.0, + >0.0,1.0,1.0,0.5,1.0,0.0,0.0,0.0,1.0,0.0,0.0,0.0, + >1.0,0.0,1.0,0.5,0.0,1.0,0.0,0.0,1.0,0.0,0.0,0.0, + >0.0,1.0,0.5,1.0,1.0,0.0,0.0,0.0,0.0,1.0,0.0,0.0, + >1.0,0.0,0.5,1.0,0.0,1.0,0.0,0.0,0.0,1.0,0.0,0.0, + >0.0,0.5,1.0,1.0,1.0,0.0,1.0,0.5,0.0,0.0,1.0,1.0, + >0.0,0.0,0.0,0.0,1.0,0.0,0.0,0.0,0.0,0.0,1.0,0.0, + >0.0,0.0,0.0,0.0,0.0,1.0,0.5,1.0,0.0,0.0,1.0,1.0, + >0.5,0.0,1.0,1.0,0.0,1.0,0.0,0.0,0.0,0.0,0.0,1.0/ + DATA RF7/ + >1.0,0.0,0.0,0.0,0.0,0.0,0.0,1.0,1.0,0.0,0.5,0.0,1.0,0.5, + >1.0,0.0,1.0,0.5,1.0,0.0,0.5,1.0,0.0,0.0,0.0,0.0,0.0,0.0, + >0.0,1.0,1.0,0.5,1.0,0.5,0.0,1.0,1.0,0.0,0.5,0.0,0.5,1.0, + >0.0,1.0,0.0,0.0,0.0,0.0,0.0,0.0,1.0,0.0,0.0,0.0,0.0,0.0, + >0.0,1.0,1.0,0.5,0.5,1.0,0.0,0.0,0.0,1.0,0.0,0.0,0.0,0.0, + >1.0,0.0,1.0,0.5,0.5,0.0,1.0,0.0,0.0,1.0,0.0,0.0,0.0,0.0, + >0.0,0.5,0.5,1.0,0.5,0.5,0.0,0.5,0.5,0.0,1.0,0.0,0.5,0.5, + >0.5,0.0,0.5,1.0,0.5,0.0,0.5,0.0,0.0,0.0,1.0,0.0,0.0,0.0, + >0.0,1.0,0.5,0.5,1.0,1.0,0.0,0.0,0.0,0.0,0.0,1.0,0.0,0.0, + >1.0,0.0,0.5,0.5,1.0,0.0,1.0,0.0,0.0,0.0,0.0,1.0,0.0,0.0, + >0.0,0.5,1.0,0.5,1.0,1.0,0.0,1.0,0.5,0.0,0.5,0.0,1.0,1.0, + >0.0,0.0,0.0,0.0,0.0,1.0,0.0,0.0,0.0,0.0,0.0,0.0,1.0,0.0, + >0.0,0.0,0.0,0.0,0.0,0.0,1.0,0.5,1.0,0.0,0.5,0.0,1.0,1.0, + >0.5,0.0,1.0,0.5,1.0,0.0,1.0,0.0,0.0,0.0,0.0,0.0,0.0,1.0/ +*---- +* COMPUTE THE HEXAGONAL MASS (RH2) AND STIFFNESS (QH2) MATRICES +*---- + IF(ISPLH.EQ.1) THEN + LC=6 + DO 11 I=1,8 + DO 10 J=1,6 + ISR(I,J)=ISRH(I,J) + 10 CONTINUE + 11 CONTINUE + DO 20 I=1,2*LC + IJ1(I)=IJ16(I) + IJ2(I)=IJ26(I) + 20 CONTINUE + DO 31 I=1,4*LC + DO 30 J=1,LC + RFAC(I,J)=RF6(I,J) + 30 CONTINUE + 31 CONTINUE + DO 41 I=1,LC + DO 40 J=1,LC + RH2(I,J)=RH(I,J) + QH2(I,J)=QH(I,J) + 40 CONTINUE + 41 CONTINUE + ELSE + LC=7 + DO 51 I=1,8 + DO 50 J=1,7 + ISR(I,J)=ISRT(I,J) + 50 CONTINUE + 51 CONTINUE + DO 60 I=1,2*LC + IJ1(I)=IJ17(I) + IJ2(I)=IJ27(I) + 60 CONTINUE + DO 71 I=1,4*LC + DO 70 J=1,LC + RFAC(I,J)=RF7(I,J) + 70 CONTINUE + 71 CONTINUE + DO 76 I=1,LC + DO 75 J=1,LC + RH2(I,J)=0.0 + QH2(I,J)=0.0 + 75 CONTINUE + 76 CONTINUE + DO 82 K=1,6 + DO 81 I=1,3 + NUMI=ILIEN(K,I) + DO 80 J=1,3 + NUMJ=ILIEN(K,J) + RH2(NUMI,NUMJ)=RH2(NUMI,NUMJ)+RT(I,J) + QH2(NUMI,NUMJ)=QH2(NUMI,NUMJ)+QT(I,J) + 80 CONTINUE + 81 CONTINUE + 82 CONTINUE + ENDIF + LL=2*LC + DO 91 I=1,LL + I1=IJ1(I) + I2=IJ2(I) + DO 90 J=1,LL + J1=IJ1(J) + J2=IJ2(J) + HW(I,J) =RFAC(I1 ,J1) * HL(I2,J2) + HX(I,J) =RFAC(I1+LC ,J1) * HL(I2,J2) + HY(I,J) =RFAC(I1+2*LC,J1) * HL(I2,J2) + HZ(I,J) =RFAC(I1+3*LC,J1) + RTHG(I,J)=RH2(I1,J1) * R(I2,J2) + QTHP(I,J)=QH2(I1,J1) * R(I2,J2) + QTHZ(I,J)=RH2(I1,J1) * Q(I2,J2) + 90 CONTINUE + 91 CONTINUE + RETURN + END diff --git a/Trivac/src/TRIRWW.f b/Trivac/src/TRIRWW.f new file mode 100755 index 0000000..d103747 --- /dev/null +++ b/Trivac/src/TRIRWW.f @@ -0,0 +1,408 @@ +*DECK TRIRWW + SUBROUTINE TRIRWW (IR,NEL,LL4,VOL,MAT,XSGD,SIDE,ZZ,KN,QFR,MUW, + 1 A11W,ISPLH,R,Q,RH,QH,RT,QT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Assembly of system matrices for a mesh corner finite difference +* discretization in hexagonal geometry. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Benaboud +* +*Parameters: input +* IR first dimension of matrix SGD. +* NEL total number of finite elements. +* ll4 order of system matrices. +* VOL volume of each element. +* MAT mixture index assigned to each element. +* XSGD nuclear properties, derivatives or first variations of +* nuclear properties per material mixture: +* XSGD(L,1): W-, X-, and Y-oriented diffusion coefficients; +* XSGD(L,3): Z-oriented diffusion coefficients; +* XSGD(L,4): removal macroscopic cross section. +* SIDE side of an hexagon. +* ZZ Z-directed mesh spacings. +* KN element-ordered unknown list (dimensionned to KN(ICOF*NEL) +* where ICOF=12 or 14). +* QFR element-ordered boundary conditions. +* MUW W-oriented compressed storage mode indices. +* MUX X-oriented compressed storage mode indices. +* MUY Y-oriented compressed storage mode indices. +* MUZ Z-oriented compressed storage mode indices. +* IPX X-oriented permutation matrices. +* IPY Y-oriented permutation matrices. +* IPZ Z-oriented permutation matrices. +* ISPLH hexagonal mesh-splitting flag: +* =1 for complete hexagons; >1 for triangular elements. +* R unit matrix. +* Q unit matrix. +* RH unit matrix. +* QH unit matrix. +* RT unit matrix. +* QT unit matrix. +* +*Parameters: output +* A11W W-oriented matrix corresponding to the divergence (i.e +* leakage) and removal terms (should be initialized by the +* calling program). +* A11X X-oriented matrix corresponding to the divergence (i.e +* leakage) and removal terms (should be initialized by the +* calling program). +* A11Y Y-oriented matrix corresponding to the divergence (i.e +* leakage) and removal terms (should be initialized by the +* calling program). +* A11Z Z-oriented matrix corresponding to the divergence (i.e +* leakage) and removal terms (should be initialized by the +* calling program). +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IR,NEL,LL4,MAT(NEL),KN(*),MUW(LL4),ISPLH + REAL VOL(NEL),XSGD(IR,4),SIDE,ZZ(NEL),QFR(8*NEL),A11W(*),R(2,2), + > Q(2,2),RH(6,6),QH(6,6),RT(3,3),QT(3,3) +*---- +* LOCAL VARIABLES +*---- + INTEGER ISR(8,25) + REAL R2DP(4) + DOUBLE PRECISION QTHP(14,14),QTHZ(14,14),RTHG(14,14), + > HW(14,14),HX(14,14),HY(14,14),HZ(14,14) + DOUBLE PRECISION RR,QQP,QQZ,VOL0,VOL1,DZ,VAR1 + DATA R2DP / 4*0.25 / +*---- +* ASSEMBLY OF MATRIX A11W +*---- + CALL TRIRMA(ISPLH,R,Q,RH,QH,RT,QT,LL,LC,ISR,QTHP,QTHZ,RTHG,HW,HX, + > HY,HZ) + NUM1=0 + NUM2=0 + VOL1=SIDE*SIDE + DO 160 K=1,NEL + L=MAT(K) + IF(L.EQ.0) GO TO 160 + VOL0=VOL(K) + IF(VOL0.EQ.0.0) GO TO 150 + DZ=ZZ(K) + DO 110 I=1,LL + INW1=KN(NUM1+I) + IF(INW1.EQ.0) GO TO 110 + KEY0=MUW(INW1)-INW1 + DO 100 J=1,LL + INW2=KN(NUM1+J) + IF(INW2.EQ.0) GO TO 100 + IF(INW2.EQ.INW1) THEN + QQP=QTHP(I,J)*DZ + QQZ=QTHZ(I,J)*VOL1/DZ + KEY=KEY0+INW2 + VAR1=QQP*XSGD(L,1)+QQZ*XSGD(L,3) + A11W(KEY)=A11W(KEY)+REAL(VAR1) + ELSE IF((INW2.LT.INW1).AND.(HW(I,J).NE.0.0)) THEN + QQP=QTHP(I,J)*HW(I,J)*DZ + KEY=KEY0+INW2 + A11W(KEY)=A11W(KEY)+REAL(QQP)*XSGD(L,1) + ENDIF + 100 CONTINUE + RR=RTHG(I,I)*VOL1*DZ + KEY=KEY0+INW1 + A11W(KEY)=A11W(KEY)+REAL(RR)*XSGD(L,4) + 110 CONTINUE + DO 140 IC=1,8 + QFR1=QFR(NUM2+IC) + IF(QFR1.EQ.0.0) GO TO 140 + IF(IC.LT.7) THEN + DO 120 I1=1,4 + I=ISR(IC,I1) + INW1=KN(NUM1+I) + IF(INW1.EQ.0) GO TO 120 + KEY=MUW(INW1) + RR=R2DP(I1) + A11W(KEY)=A11W(KEY)+REAL(RR)*QFR1 + 120 CONTINUE + ELSE + DO 130 I1=1,LC + I=ISR(IC,I1) + INW1=KN(NUM1+I) + IF(INW1.EQ.0) GO TO 130 + KEY=MUW(INW1) + RR=RTHG(I1,I1) + A11W(KEY)=A11W(KEY)+REAL(RR)*QFR1 + 130 CONTINUE + ENDIF + 140 CONTINUE + 150 NUM1=NUM1+LL + NUM2=NUM2+8 + 160 CONTINUE + RETURN + END +* + SUBROUTINE TRIRWX (IR,NEL,LL4,VOL,MAT,XSGD,SIDE,ZZ,KN,QFR,MUX,IPX, + > A11X,ISPLH,R,Q,RH,QH,RT,QT) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IR,NEL,LL4,MAT(NEL),KN(*),MUX(LL4),IPX(LL4),ISPLH + REAL VOL(NEL),XSGD(IR,4),SIDE,ZZ(NEL),QFR(8*NEL),A11X(*),R(2,2), + > Q(2,2),RH(6,6),QH(6,6),RT(3,3),QT(3,3) +*---- +* LOCAL VARIABLES +*---- + INTEGER ISR(8,25) + REAL R2DP(4) + DOUBLE PRECISION QTHP(14,14),QTHZ(14,14),RTHG(14,14), + > HW(14,14),HX(14,14),HY(14,14),HZ(14,14) + DOUBLE PRECISION RR,QQP,QQZ,VOL0,VOL1,DZ,VAR1 + DATA R2DP / 4*0.25 / +*---- +* ASSEMBLY OF MATRIX A11X +*---- + CALL TRIRMA(ISPLH,R,Q,RH,QH,RT,QT,LL,LC,ISR,QTHP,QTHZ,RTHG,HW,HX, + > HY,HZ) + NUM1=0 + NUM2=0 + VOL1=SIDE*SIDE + DO 230 K=1,NEL + L=MAT(K) + IF(L.EQ.0) GO TO 230 + VOL0=VOL(K) + IF(VOL0.EQ.0.0) GO TO 220 + DZ=ZZ(K) + DO 180 I=1,LL + INW1=KN(NUM1+I) + IF(INW1.EQ.0) GO TO 180 + INX1=IPX(INW1) + KEY0=MUX(INX1)-INX1 + DO 170 J=1,LL + INW2=KN(NUM1+J) + IF(INW2.EQ.0) GO TO 170 + INX2=IPX(INW2) + IF(INX2.EQ.INX1) THEN + QQP=QTHP(I,J)*DZ + QQZ=QTHZ(I,J)*VOL1/DZ + KEY=KEY0+INX2 + VAR1=QQP*XSGD(L,1)+QQZ*XSGD(L,3) + A11X(KEY)=A11X(KEY)+REAL(VAR1) + ELSE IF((INX2.LT.INX1).AND.(HX(I,J).NE.0.0)) THEN + QQP=QTHP(I,J)*HX(I,J)*DZ + KEY=KEY0+INX2 + A11X(KEY)=A11X(KEY)+REAL(QQP)*XSGD(L,1) + ENDIF + 170 CONTINUE + RR=RTHG(I,I)*VOL1*DZ + KEY=KEY0+INX1 + A11X(KEY)=A11X(KEY)+REAL(RR)*XSGD(L,4) + 180 CONTINUE + DO 210 IC=1,8 + QFR1=QFR(NUM2+IC) + IF(QFR1.EQ.0.0) GO TO 210 + IF(IC.LT.7) THEN + DO 190 I1=1,4 + I=ISR(IC,I1) + INW1=KN(NUM1+I) + IF(INW1.EQ.0) GO TO 190 + INX1=IPX(INW1) + KEY=MUX(INX1) + RR=R2DP(I1) + A11X(KEY)=A11X(KEY)+REAL(RR)*QFR1 + 190 CONTINUE + ELSE + DO 200 I1=1,LC + I=ISR(IC,I1) + INW1=KN(NUM1+I) + IF(INW1.EQ.0) GO TO 200 + INX1=IPX(INW1) + KEY=MUX(INX1) + RR=RTHG(I1,I1) + A11X(KEY)=A11X(KEY)+REAL(RR)*QFR1 + 200 CONTINUE + ENDIF + 210 CONTINUE + 220 NUM1=NUM1+LL + NUM2=NUM2+8 + 230 CONTINUE + RETURN + END +* + SUBROUTINE TRIRWY (IR,NEL,LL4,VOL,MAT,XSGD,SIDE,ZZ,KN,QFR,MUY,IPY, + > A11Y,ISPLH,R,Q,RH,QH,RT,QT) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IR,NEL,LL4,MAT(NEL),KN(*),MUY(LL4),IPY(LL4),ISPLH + REAL VOL(NEL),XSGD(IR,4),SIDE,ZZ(NEL),QFR(8*NEL),A11Y(*),R(2,2), + > Q(2,2),RH(6,6),QH(6,6),RT(3,3),QT(3,3) +*---- +* LOCAL VARIABLES +*---- + INTEGER ISR(8,25) + REAL R2DP(4) + DOUBLE PRECISION QTHP(14,14),QTHZ(14,14),RTHG(14,14), + > HW(14,14),HX(14,14),HY(14,14),HZ(14,14) + DOUBLE PRECISION RR,QQP,QQZ,VOL0,VOL1,DZ,VAR1 + DATA R2DP / 4*0.25 / +*---- +* ASSEMBLY OF MATRIX A11Y +*---- + CALL TRIRMA(ISPLH,R,Q,RH,QH,RT,QT,LL,LC,ISR,QTHP,QTHZ,RTHG,HW,HX, + > HY,HZ) + NUM1=0 + NUM2=0 + VOL1=SIDE*SIDE + DO 300 K=1,NEL + L=MAT(K) + IF(L.EQ.0) GO TO 300 + VOL0=VOL(K) + IF(VOL0.EQ.0.0) GO TO 290 + DZ=ZZ(K) + DO 250 I=1,LL + INW1=KN(NUM1+I) + IF(INW1.EQ.0) GO TO 250 + INY1=IPY(INW1) + KEY0=MUY(INY1)-INY1 + DO 240 J=1,LL + INW2=KN(NUM1+J) + IF(INW2.EQ.0) GO TO 240 + INY2=IPY(INW2) + IF(INY2.EQ.INY1) THEN + QQP=QTHP(I,J)*DZ + QQZ=QTHZ(I,J)*VOL1/DZ + KEY=KEY0+INY2 + VAR1=QQP*XSGD(L,1)+QQZ*XSGD(L,3) + A11Y(KEY)=A11Y(KEY)+REAL(VAR1) + ELSE IF((INY2.LT.INY1).AND.(HY(I,J).NE.0.0)) THEN + QQP=QTHP(I,J)*HY(I,J)*DZ + KEY=KEY0+INY2 + A11Y(KEY)=A11Y(KEY)+REAL(QQP)*XSGD(L,1) + ENDIF + 240 CONTINUE + RR=RTHG(I,I)*VOL1*DZ + KEY=KEY0+INY1 + A11Y(KEY)=A11Y(KEY)+REAL(RR)*XSGD(L,4) + 250 CONTINUE + DO 280 IC=1,8 + QFR1=QFR(NUM2+IC) + IF(QFR1.EQ.0.0) GO TO 280 + IF(IC.LT.7) THEN + DO 260 I1=1,4 + I=ISR(IC,I1) + INW1=KN(NUM1+I) + IF(INW1.EQ.0) GO TO 260 + INY1=IPY(INW1) + KEY=MUY(INY1) + RR=R2DP(I1) + A11Y(KEY)=A11Y(KEY)+REAL(RR)*QFR1 + 260 CONTINUE + ELSE + DO 270 I1=1,LC + I=ISR(IC,I1) + INW1=KN(NUM1+I) + IF(INW1.EQ.0) GO TO 270 + INY1=IPY(INW1) + KEY=MUY(INY1) + RR=RTHG(I1,I1) + A11Y(KEY)=A11Y(KEY)+REAL(RR)*QFR1 + 270 CONTINUE + ENDIF + 280 CONTINUE + 290 NUM1=NUM1+LL + NUM2=NUM2+8 + 300 CONTINUE + RETURN + END +* + SUBROUTINE TRIRWZ (IR,NEL,LL4,VOL,MAT,XSGD,SIDE,ZZ,KN,QFR,MUZ,IPZ, + > A11Z,ISPLH,R,Q,RH,QH,RT,QT) +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IR,NEL,LL4,MAT(NEL),KN(*),MUZ(LL4),IPZ(LL4),ISPLH + REAL VOL(NEL),XSGD(IR,4),SIDE,ZZ(NEL),QFR(8*NEL),A11Z(*),R(2,2), + > Q(2,2),RH(6,6),QH(6,6),RT(3,3),QT(3,3) +*---- +* LOCAL VARIABLES +*---- + INTEGER ISR(8,25) + REAL R2DP(4) + DOUBLE PRECISION QTHP(14,14),QTHZ(14,14),RTHG(14,14), + > HW(14,14),HX(14,14),HY(14,14),HZ(14,14) + DOUBLE PRECISION RR,QQP,QQZ,VOL0,VOL1,DZ,VAR1 + DATA R2DP / 4*0.25 / +*---- +* ASSEMBLY OF MATRIX A11Z +*---- + CALL TRIRMA(ISPLH,R,Q,RH,QH,RT,QT,LL,LC,ISR,QTHP,QTHZ,RTHG,HW,HX, + > HY,HZ) + NUM1=0 + NUM2=0 + VOL1=SIDE*SIDE + DO 360 K=1,NEL + L=MAT(K) + IF(L.EQ.0) GO TO 360 + VOL0=VOL(K) + IF(VOL0.EQ.0.0) GO TO 350 + DZ=ZZ(K) + DO 320 I=1,LL + INW1=KN(NUM1+I) + IF(INW1.EQ.0) GO TO 320 + INZ1=IPZ(INW1) + KEY0=MUZ(INZ1)-INZ1 + DO 310 J=1,LL + INW2=KN(NUM1+J) + IF(INW2.EQ.0) GO TO 310 + INZ2=IPZ(INW2) + IF(INZ2.EQ.INZ1) THEN + QQP=QTHP(I,J)*DZ + QQZ=QTHZ(I,J)*VOL1/DZ + KEY=KEY0+INZ2 + VAR1=QQP*XSGD(L,1)+QQZ*XSGD(L,3) + A11Z(KEY)=A11Z(KEY)+REAL(VAR1) + ELSE IF((INZ2.LT.INZ1).AND.(HZ(I,J).NE.0.0)) THEN + QQZ=QTHZ(I,J)*VOL1/DZ + KEY=KEY0+INZ2 + A11Z(KEY)=A11Z(KEY)+REAL(QQZ)*XSGD(L,1) + ENDIF + 310 CONTINUE + RR=RTHG(I,I)*VOL1*DZ + KEY=KEY0+INZ1 + A11Z(KEY)=A11Z(KEY)+REAL(RR)*XSGD(L,4) + 320 CONTINUE + DO 340 IC=1,8 + QFR1=QFR(NUM2+IC) + IF(QFR1.EQ.0.0) GO TO 340 + IF(IC.LT.7) THEN + DO 330 I1=1,4 + I=ISR(IC,I1) + INW1=KN(NUM1+I) + IF(INW1.EQ.0) GO TO 330 + INZ1=IPZ(INW1) + KEY=MUZ(INZ1) + RR=R2DP(I1) + A11Z(KEY)=A11Z(KEY)+REAL(RR)*QFR1 + 330 CONTINUE + ELSE + DO 335 I1=1,LC + I=ISR(IC,I1) + INW1=KN(NUM1+I) + IF(INW1.EQ.0) GO TO 335 + INZ1=IPZ(INW1) + KEY=MUZ(INZ1) + RR=RTHG(I1,I1) + A11Z(KEY)=A11Z(KEY)+REAL(RR)*QFR1 + 335 CONTINUE + ENDIF + 340 CONTINUE + 350 NUM1=NUM1+LL + NUM2=NUM2+8 + 360 CONTINUE + RETURN + END diff --git a/Trivac/src/TRISFH.f b/Trivac/src/TRISFH.f new file mode 100755 index 0000000..f9cfd62 --- /dev/null +++ b/Trivac/src/TRISFH.f @@ -0,0 +1,1022 @@ +*DECK TRISFH + SUBROUTINE TRISFH (IMPX,MAXKN,MAXIP,NBLOS,ISPLH,IELEM,LXH,LZ,MAT, + 1 SIDE,ZZZ,NCODE,ICODE,ZCODE,LL4,LL4F,LL4W,LL4X,LL4Y,LL4Z,VOL, + 2 IDL,IPERT,ZZ,FRZ,KN,QFR,IQFR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Numbering corresponding to a Thomas-Raviart-Schneider finite element +* discretization of a 3-D hexagonal geometry. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IMPX print parameter. +* MAXKN number of components in KN. +* MAXIP maximum number of currents +* NBLOS number of lozenges per direction in 3D with mesh-splitting. +* ISPLH mesh-splitting in 3*ISPLH**2 lozenges per hexagon. +* IELEM degree of the Lagrangian finite elements: =1 (linear); +* =2 (parabolic); =3 (cubic). +* LXH number of hexagons in a plane. +* LZ number of axial planes. +* MAT mixture index assigned to each lozenge. +* SIDE side of a lozenge. +* ZZZ Z-coordinates of the axial planes. +* NCODE type of boundary condition applied on each side (I=1: hbc): +* NCODE(I)=1: VOID; =2: REFL; =6: ALBE; +* =5: SYME; =7: ZERO. +* ICODE physical albedo index on each side of the domain. +* ZCODE albedo corresponding to boundary condition 'VOID' on each +* side (ZCODE(I)=0.0 by default). +* +*Parameters: output +* LL4 order of the system matrices. +* LL4F number of flux unknowns. +* LL4W number of W-directed currents +* LL4X number of X-directed currents +* LL4Y number of Y-directed currents +* LL4Z number of Z-directed currents +* ZZ Z-sides of each hexagon. +* FRZ volume fractions for the axial SYME boundary condition. +* VOL volume of each lozenge. +* IDL position of the average flux component associated with each +* lozenge. +* IPERT mixture permutation index. +* KN ADI permutation indices for the volumes and currents. +* QFR element-ordered boundary conditions. +* IQFR element-ordered physical albedo indices. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IMPX,MAXKN,MAXIP,NBLOS,ISPLH,IELEM,LXH,LZ, + 1 MAT(3,ISPLH**2,LXH*LZ),NCODE(6),ICODE(6),LL4,LL4F,LL4W,LL4X, + 2 LL4Y,LL4Z,IDL(3,NBLOS),IPERT(NBLOS),KN(NBLOS,MAXKN/NBLOS), + 3 IQFR(NBLOS,8) + REAL SIDE,ZZZ(LZ+1),ZCODE(6),VOL(3,NBLOS),ZZ(3,NBLOS), + 1 FRZ(NBLOS),QFR(NBLOS,8) +*---- +* LOCAL VARIABLES +*---- + LOGICAL COND,LL1,LL2 + INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: IJP + INTEGER, DIMENSION(:,:), ALLOCATABLE :: IZGLOB + INTEGER, DIMENSION(:), ALLOCATABLE :: IP,I1,I3,I4,I5 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IJP(LXH,ISPLH,ISPLH),IP(MAXIP),IZGLOB(NBLOS,3)) +*---- +* THOMAS-RAVIART-SCHNEIDER SPECIFIC NUMEROTATION +*---- + NBC=INT((SQRT(REAL((4*LXH-1)/3))+1.)/2.) + IF(LXH.NE.1+3*NBC*(NBC-1)) CALL XABORT('TRISFH: INVALID VALUE OF ' + 1 //'LXH(1).') + IF(ISPLH.EQ.1) THEN + DO 10 I=1,LXH + IJP(I,1,1)=I + 10 CONTINUE + ELSE + I=0 + DO 23 I0=1,2*NBC-1 + JMAX=NBC+I0-1 + IF(I0.GE.NBC) JMAX=3*NBC-I0-1 + IKEEP=I + DO 22 J0=1,JMAX + I=I+1 + DO 21 IM=1,ISPLH + DO 20 JM=1,ISPLH + IJP(I,IM,JM)=ISPLH*(IKEEP*ISPLH+(IM-1)*JMAX+J0-1)+JM + 20 CONTINUE + 21 CONTINUE + 22 CONTINUE + 23 CONTINUE + IF(I.NE.LXH) CALL XABORT('TRISFH: INVALID VALUE OF LXH(2)') + ENDIF + ALLOCATE(I1(3*LXH),I3(2*LXH),I4(NBLOS),I5(NBLOS)) + DO 25 I=1,LXH + I3(I)=I + 25 CONTINUE + DO 30 I=1,LXH*LZ + I4(I)=0 + IF(MAT(1,1,I).GT.0) I4(I)=I + 30 CONTINUE + IZGLOB(:NBLOS,:3)=0 + J1=2+3*(NBC-1)*(NBC-2) + IF(NBC.EQ.1) J1=1 + J3=J1+2*NBC-2 + J5=J3+2*NBC-2 + CALL BIVPER(J1,1,LXH,LXH,I1(1),I3) + CALL BIVPER(J3,3,LXH,LXH,I1(LXH+1),I3) + CALL BIVPER(J5,5,LXH,LXH,I1(2*LXH+1),I3) + I=0 + DO 43 IZ=1,LZ + DO 42 IX=1,LXH + I=I+1 + IOFW=I1(IX) + IOFX=I1(LXH+IX) + IOFY=I1(2*LXH+IX) + DO 41 IM=1,ISPLH + DO 40 JM=1,ISPLH + IZGLOB((IZ-1)*LXH*ISPLH**2+IJP(IOFW,IM,JM),1)=I4(I) + IZGLOB((IZ-1)*LXH*ISPLH**2+IJP(IOFX,IM,JM),2)=I4(I) + IZGLOB((IZ-1)*LXH*ISPLH**2+IJP(IOFY,IM,JM),3)=I4(I) + 40 CONTINUE + 41 CONTINUE + 42 CONTINUE + 43 CONTINUE + DO 50 I=1,LXH + II1=I1(I) + II2=I1(LXH+I) + II3=I1(2*LXH+I) + I3(II1)=II2 + I3(LXH+II1)=II3 + 50 CONTINUE +*---- +* COMPUTE THE FLUX PERMUTATION PART OF MATRIX KN (W <--> X) +*---- + KN(:NBLOS,:3+6*IELEM*IELEM*(IELEM+2))=0 + LT4=0 + DO 70 II2=1,NBLOS + I=IZGLOB(II2,1) + I4(II2)=0 + IF(I.NE.0) THEN + LT4=LT4+1 + I4(II2)=LT4 + ENDIF + 70 CONTINUE + LT4=0 + DO 80 II2=1,NBLOS + I=IZGLOB(II2,2) + I5(II2)=0 + IF(I.NE.0) THEN + LT4=LT4+1 + I5(II2)=LT4 + ENDIF + 80 CONTINUE + IF(ISPLH.EQ.1) THEN + I=0 + DO 95 IZ=1,LZ + DO 90 IX=1,LXH + I=I+1 + IF(IZGLOB(I,1).EQ.0) GO TO 90 + IOF=(IZ-1)*LXH+I3(IX) + KN(I4(I),1)=I5(IOF)+LT4 + 90 CONTINUE + 95 CONTINUE + ELSE + I=0 + DO 105 I0=1,2*NBC-1 + JMAX=NBC+I0-1 + IF(I0.GE.NBC) JMAX=3*NBC-I0-1 + IKEEP=I + DO 100 J0=1,JMAX + I=I+1 + I1(I)=JMAX + I1(LXH+I)=IKEEP + I1(2*LXH+I)=J0 + 100 CONTINUE + 105 CONTINUE + DO 125 IZ=1,LZ + DO 120 I=1,LXH + JMAX=I1(I) + IKEEP=I1(LXH+I) + J00=I1(2*LXH+I) + KMAX=I1(I3(I)) + JKEEP=I1(LXH+I3(I)) + K0=I1(2*LXH+I3(I)) + DO 115 IM=1,ISPLH + DO 110 JM=1,ISPLH + II1=ISPLH*(IKEEP*ISPLH+(IM-1)*JMAX+J00-1)+JM + IOF1=(IZ-1)*LXH*ISPLH**2+II1 + IF(IZGLOB(IOF1,1).EQ.0) GO TO 120 + II2=ISPLH*(JKEEP*ISPLH+(ISPLH-JM)*KMAX+K0-1)+IM + IOF2=(IZ-1)*LXH*ISPLH**2+II2 + KN(I4(IOF1),1)=I5(IOF2)+LT4 + 110 CONTINUE + 115 CONTINUE + 120 CONTINUE + 125 CONTINUE + ENDIF +*---- +* COMPUTE THE FLUX PERMUTATION PART OF MATRIX KN (X <--> Y) +*---- + LT4=0 + DO 130 II2=1,NBLOS + I=IZGLOB(II2,3) + I5(II2)=0 + IF(I.NE.0) THEN + LT4=LT4+1 + I5(II2)=LT4 + ENDIF + 130 CONTINUE + IF(ISPLH.EQ.1) THEN + I=0 + DO 145 IZ=1,LZ + DO 140 IX=1,LXH + I=I+1 + IF(IZGLOB(I,1).EQ.0) GO TO 140 + IOF=(IZ-1)*LXH+I3(LXH+IX) + KN(I4(I),2)=I5(IOF)+2*LT4 + 140 CONTINUE + 145 CONTINUE + ELSE + I=0 + DO 155 I0=1,2*NBC-1 + JMAX=NBC+I0-1 + IF(I0.GE.NBC) JMAX=3*NBC-I0-1 + IKEEP=I + DO 150 J0=1,JMAX + I=I+1 + I1(I)=JMAX + I1(LXH+I)=IKEEP + I1(2*LXH+I)=J0 + 150 CONTINUE + 155 CONTINUE + DO 175 IZ=1,LZ + DO 170 I=1,LXH + JMAX=I1(I) + IKEEP=I1(LXH+I) + J00=I1(2*LXH+I) + KMAX=I1(I3(LXH+I)) + JKEEP=I1(LXH+I3(LXH+I)) + K0=I1(2*LXH+I3(LXH+I)) + DO 165 IM=1,ISPLH + DO 160 JM=1,ISPLH + II1=ISPLH*(IKEEP*ISPLH+(IM-1)*JMAX+J00-1)+JM + IOF1=(IZ-1)*LXH*ISPLH**2+II1 + IF(IZGLOB(IOF1,1).EQ.0) GO TO 170 + II2=ISPLH*(JKEEP*ISPLH+(ISPLH-IM)*KMAX+K0-1)+(ISPLH-JM+1) + IOF2=(IZ-1)*LXH*ISPLH**2+II2 + KN(I4(IOF1),2)=I5(IOF2)+2*LT4 + 160 CONTINUE + 165 CONTINUE + 170 CONTINUE + 175 CONTINUE + ENDIF +*---- +* COMPUTE THE FLUX PERMUTATION PART OF MATRIX KN (Y <--> W) +*---- + IF(ISPLH.EQ.1) THEN + DO 180 I=1,LXH*LZ + IF(IZGLOB(I,1).EQ.0) GO TO 180 + KN(I4(I),3)=I4(I) + 180 CONTINUE + ELSE + I=0 + DO 195 I0=1,2*NBC-1 + JMAX=NBC+I0-1 + IF(I0.GE.NBC) JMAX=3*NBC-I0-1 + IKEEP=I + DO 190 J0=1,JMAX + I=I+1 + I1(I)=JMAX + I1(LXH+I)=IKEEP + I1(2*LXH+I)=J0 + 190 CONTINUE + 195 CONTINUE + DO 215 IZ=1,LZ + DO 210 I=1,LXH + JMAX=I1(I) + IKEEP=I1(LXH+I) + J00=I1(2*LXH+I) + DO 205 IM=1,ISPLH + DO 200 JM=1,ISPLH + II1=ISPLH*(IKEEP*ISPLH+(IM-1)*JMAX+J00-1)+JM + IOF1=(IZ-1)*LXH*ISPLH**2+II1 + IF(IZGLOB(IOF1,1).EQ.0) GO TO 210 + II2=ISPLH*(IKEEP*ISPLH+(JM-1)*JMAX+J00-1)+(ISPLH-IM+1) + IOF2=(IZ-1)*LXH*ISPLH**2+II2 + KN(I4(IOF1),3)=I4(IOF2) + 200 CONTINUE + 205 CONTINUE + 210 CONTINUE + 215 CONTINUE + ENDIF + DEALLOCATE(I5,I4,I3,I1) +*---- +* SET THE CURRENT NUMBERING PART OF MATRIX KN AND MATRIX QFR (W-AXIS) +*---- + LL4W0=(2*LXH*ISPLH*IELEM+2*NBC-1)*ISPLH*LZ*IELEM**2 + LL4Z0=3*LXH*(LZ+1)*(ISPLH**2)*IELEM**2 + LL4F=3*LT4*IELEM**3 + QFR(:NBLOS,:8)=0.0 + IQFR(:NBLOS,:8)=0 + ALBEDO=0.5*(1.0-ZCODE(1))/(1.0+ZCODE(1)) + NELEH=(IELEM+1)*IELEM**2 + NELEZ=6*IELEM**2 + NB1=2*NBC*ISPLH*IELEM+1 + NB2=2*(2*NBC-1)*ISPLH*IELEM+1 + KEL=0 + NDDIR=0 + NUM=0 + DO 345 IZ=1,LZ + FRACT=1.0 + IF((NCODE(5).EQ.5).AND.(IZ.EQ.1)) FRACT=0.5 + IF((NCODE(6).EQ.5).AND.(IZ.EQ.LZ)) FRACT=0.5 + DZZ=ZZZ(IZ+1)-ZZZ(IZ) + DO 290 JSTAGE=1,NBC + DO 282 JEL=1,ISPLH + DO 281 IRANG=1,NBC+JSTAGE-1 + DO 280 IEL=1,ISPLH + KEL=KEL+1 + IF(IZGLOB(KEL,1).EQ.0) GO TO 280 + NUM=NUM+1 + IF((IRANG.EQ.1).AND.(IEL.EQ.1)) THEN + LL1=.TRUE. + ELSE + LL1=(IZGLOB(KEL-1,1).EQ.0) + ENDIF + IF((IRANG.EQ.NBC+JSTAGE-1).AND.(IEL.EQ.ISPLH)) THEN + LL2=.TRUE. + ELSE + LL2=(IZGLOB(KEL+1,1).EQ.0) + ENDIF + LCOUR=0 + DO 255 J=1,IELEM**2 + DO 250 I=1,IELEM+1 + LCOUR=LCOUR+1 + ITEMP = NDDIR + > + (JEL-1)*(2*(NBC+JSTAGE-1)*IELEM*ISPLH+1)*IELEM**2 + > + (IRANG-1)*(2*IELEM*ISPLH) + > + (IEL-1)*IELEM + > + (J-1)*(2*(NBC+JSTAGE-1)*IELEM*ISPLH+1) + I + IF(LCOUR.GT.NELEH) CALL XABORT('TRISFH: BUG1') + IF(KEL.GT.NBLOS) CALL XABORT('TRISFH: BUG2') + KN(NUM,3+LCOUR)=ITEMP + KN(NUM,3+NELEH+LCOUR)=ITEMP+IELEM*ISPLH + 250 CONTINUE + 255 CONTINUE + IF(LL1) THEN + COND=(NCODE(1).EQ.2).OR.((NCODE(1).EQ.1).AND.(ZCODE(1).EQ.1.0)) + IF(COND) THEN + DO 260 I=1,IELEM**2 + KN(NUM,3+(I-1)*(IELEM+1)+1)=0 + 260 CONTINUE + ELSE IF((NCODE(1).EQ.1).AND.(ICODE(1).EQ.0)) THEN + QFR(NUM,1)=SIDE*DZZ*FRACT/ALBEDO + ELSE IF(NCODE(1).EQ.1) THEN + QFR(NUM,1)=SIDE*DZZ*FRACT + IQFR(NUM,1)=ICODE(1) + ENDIF + ENDIF + IF(LL2) THEN + COND=(NCODE(1).EQ.2).OR.((NCODE(1).EQ.1).AND.(ZCODE(1).EQ.1.0)) + IF(COND) THEN + DO 270 I=1,IELEM**2 + KN(NUM,3+NELEH+I*(IELEM+1))=0 + 270 CONTINUE + ELSE IF((NCODE(1).EQ.1).AND.(ICODE(1).EQ.0)) THEN + QFR(NUM,2)=SIDE*DZZ*FRACT/ALBEDO + ELSE IF(NCODE(1).EQ.1) THEN + QFR(NUM,2)=SIDE*DZZ*FRACT + IQFR(NUM,1)=ICODE(1) + ENDIF + ENDIF + 280 CONTINUE + 281 CONTINUE + 282 CONTINUE + NDDIR=NDDIR+(NB1+2*(JSTAGE-1)*ISPLH*IELEM)*ISPLH*IELEM**2 + 290 CONTINUE +* + DO 340 JSTAGE=NBC+1,2*NBC-1 + DO 332 JEL=1,ISPLH + DO 331 IRANG=1,(2*NBC-2)-(JSTAGE-NBC-1) + DO 330 IEL=1,ISPLH + KEL=KEL+1 + IF(IZGLOB(KEL,1).EQ.0) GO TO 330 + NUM=NUM+1 + IF((IRANG.EQ.1).AND.(IEL.EQ.1)) THEN + LL1=.TRUE. + ELSE + LL1=(IZGLOB(KEL-1,1).EQ.0) + ENDIF + IF((IRANG.EQ.(2*NBC-2)-(JSTAGE-NBC-1)).AND.(IEL.EQ.ISPLH)) THEN + LL2=.TRUE. + ELSE + LL2=(IZGLOB(KEL+1,1).EQ.0) + ENDIF + LCOUR=0 + DO 305 J=1,IELEM**2 + DO 300 I=1,IELEM+1 + LCOUR=LCOUR+1 + ITEMP = NDDIR + > + (JEL-1)*(2*(2*NBC-1+NBC-JSTAGE)*IELEM*ISPLH+1)*IELEM**2 + > + (IRANG-1)*(2*IELEM*ISPLH) + > + (IEL-1)*IELEM + > + (J-1)*(2*(2*NBC-1+NBC-JSTAGE)*IELEM*ISPLH+1) + I + IF(LCOUR.GT.NELEH) CALL XABORT('TRISFH: BUG3') + IF(KEL.GT.NBLOS) CALL XABORT('TRISFH: BUG4') + KN(NUM,3+LCOUR)=ITEMP + KN(NUM,3+NELEH+LCOUR)=ITEMP+IELEM*ISPLH + 300 CONTINUE + 305 CONTINUE + IF(LL1) THEN + COND=(NCODE(1).EQ.2).OR.((NCODE(1).EQ.1).AND.(ZCODE(1).EQ.1.0)) + IF(COND) THEN + DO 310 I=1,IELEM**2 + KN(NUM,3+(I-1)*(IELEM+1)+1)=0 + 310 CONTINUE + ELSE IF((NCODE(1).EQ.1).AND.(ICODE(1).EQ.0)) THEN + QFR(NUM,1)=SIDE*DZZ*FRACT/ALBEDO + ELSE IF(NCODE(1).EQ.1) THEN + QFR(NUM,1)=SIDE*DZZ*FRACT + IQFR(NUM,1)=ICODE(1) + ENDIF + ENDIF + IF(LL2) THEN + COND=(NCODE(1).EQ.2).OR.((NCODE(1).EQ.1).AND.(ZCODE(1).EQ.1.0)) + IF(COND) THEN + DO 320 I=1,IELEM**2 + KN(NUM,3+NELEH+I*(IELEM+1))=0 + 320 CONTINUE + ELSE IF((NCODE(1).EQ.1).AND.(ICODE(1).EQ.0)) THEN + QFR(NUM,2)=SIDE*DZZ*FRACT/ALBEDO + ELSE IF(NCODE(1).EQ.1) THEN + QFR(NUM,2)=SIDE*DZZ*FRACT + IQFR(NUM,2)=ICODE(1) + ENDIF + ENDIF + 330 CONTINUE + 331 CONTINUE + 332 CONTINUE + NDDIR=NDDIR+(NB2-2*(JSTAGE-NBC)*ISPLH*IELEM)*ISPLH*IELEM**2 + 340 CONTINUE + 345 CONTINUE +*---- +* SET THE CURRENT NUMBERING PART OF MATRIX KN AND MATRIX QFR (X-AXIS) +*---- + IP(:NBLOS)=0 + DO 350 NUM=1,LT4 + IP(KN(NUM,1)-LT4)=NUM + 350 CONTINUE + KEL=0 + NUM=0 + DO 455 IZ=1,LZ + FRACT=1.0 + IF((NCODE(5).EQ.5).AND.(IZ.EQ.1)) FRACT=0.5 + IF((NCODE(6).EQ.5).AND.(IZ.EQ.LZ)) FRACT=0.5 + DZZ=ZZZ(IZ+1)-ZZZ(IZ) + DO 400 JSTAGE=1,NBC + DO 392 JEL=1,ISPLH + DO 391 IRANG=1,NBC+JSTAGE-1 + DO 390 IEL=1,ISPLH + KEL=KEL+1 + IF(IZGLOB(KEL,2).EQ.0) GO TO 390 + NUM=NUM+1 + IF((IRANG.EQ.1).AND.(IEL.EQ.1)) THEN + LL1=.TRUE. + ELSE + LL1=(IZGLOB(KEL-1,2).EQ.0) + ENDIF + IF((IRANG.EQ.NBC+JSTAGE-1).AND.(IEL.EQ.ISPLH)) THEN + LL2=.TRUE. + ELSE + LL2=(IZGLOB(KEL+1,2).EQ.0) + ENDIF + LCOUR=0 + DO 365 J=1,IELEM**2 + DO 360 I=1,IELEM+1 + LCOUR=LCOUR+1 + ITEMP = NDDIR + > + (JEL-1)*(2*(NBC+JSTAGE-1)*IELEM*ISPLH+1)*IELEM**2 + > + (IRANG-1)*(2*IELEM*ISPLH) + > + (IEL-1)*IELEM + > + (J-1)*(2*(NBC+JSTAGE-1)*IELEM*ISPLH+1) + I + IF(LCOUR.GT.NELEH) CALL XABORT('TRISFH: BUG5') + IF(KEL.GT.NBLOS) CALL XABORT('TRISFH: BUG6') + KN(IP(NUM),3+2*NELEH+LCOUR)=ITEMP + KN(IP(NUM),3+3*NELEH+LCOUR)=ITEMP+IELEM*ISPLH + 360 CONTINUE + 365 CONTINUE + IF(LL1) THEN + COND=(NCODE(1).EQ.2).OR.((NCODE(1).EQ.1).AND.(ZCODE(1).EQ.1.0)) + IF(COND) THEN + DO 370 I=1,IELEM**2 + KN(IP(NUM),3+2*NELEH+(I-1)*(IELEM+1)+1)=0 + 370 CONTINUE + ELSE IF((NCODE(1).EQ.1).AND.(ICODE(1).EQ.0)) THEN + QFR(IP(NUM),3)=SIDE*DZZ*FRACT/ALBEDO + ELSE IF(NCODE(1).EQ.1) THEN + QFR(IP(NUM),3)=SIDE*DZZ*FRACT + IQFR(IP(NUM),3)=ICODE(1) + ENDIF + ENDIF + IF(LL2) THEN + COND=(NCODE(1).EQ.2).OR.((NCODE(1).EQ.1).AND.(ZCODE(1).EQ.1.0)) + IF(COND) THEN + DO 380 I=1,IELEM**2 + KN(IP(NUM),3+3*NELEH+I*(IELEM+1))=0 + 380 CONTINUE + ELSE IF((NCODE(1).EQ.1).AND.(ICODE(1).EQ.0)) THEN + QFR(IP(NUM),4)=SIDE*DZZ*FRACT/ALBEDO + ELSE IF(NCODE(1).EQ.1) THEN + QFR(IP(NUM),4)=SIDE*DZZ*FRACT + IQFR(IP(NUM),4)=ICODE(1) + ENDIF + ENDIF + 390 CONTINUE + 391 CONTINUE + 392 CONTINUE + NDDIR=NDDIR+(NB1+2*(JSTAGE-1)*ISPLH*IELEM)*ISPLH*IELEM**2 + 400 CONTINUE +* + DO 450 JSTAGE=NBC+1,2*NBC-1 + DO 442 JEL=1,ISPLH + DO 441 IRANG=1,(2*NBC-2)-(JSTAGE-NBC-1) + DO 440 IEL=1,ISPLH + KEL=KEL+1 + IF(IZGLOB(KEL,2).EQ.0) GO TO 440 + NUM=NUM+1 + IF((IRANG.EQ.1).AND.(IEL.EQ.1)) THEN + LL1=.TRUE. + ELSE + LL1=(IZGLOB(KEL-1,2).EQ.0) + ENDIF + IF((IRANG.EQ.(2*NBC-2)-(JSTAGE-NBC-1)).AND.(IEL.EQ.ISPLH)) THEN + LL2=.TRUE. + ELSE + LL2=(IZGLOB(KEL+1,2).EQ.0) + ENDIF + LCOUR=0 + DO 415 J=1,IELEM**2 + DO 410 I=1,IELEM+1 + LCOUR=LCOUR+1 + ITEMP = NDDIR + > + (JEL-1)*(2*(2*NBC-1+NBC-JSTAGE)*IELEM*ISPLH+1)*IELEM**2 + > + (IRANG-1)*(2*IELEM*ISPLH) + > + (IEL-1)*IELEM + > + (J-1)*(2*(2*NBC-1+NBC-JSTAGE)*IELEM*ISPLH+1) + I + IF(LCOUR.GT.NELEH) CALL XABORT('TRISFH: BUG7') + IF(KEL.GT.NBLOS) CALL XABORT('TRISFH: BUG8') + KN(IP(NUM),3+2*NELEH+LCOUR)=ITEMP + KN(IP(NUM),3+3*NELEH+LCOUR)=ITEMP+IELEM*ISPLH + 410 CONTINUE + 415 CONTINUE + IF(LL1) THEN + COND=(NCODE(1).EQ.2).OR.((NCODE(1).EQ.1).AND.(ZCODE(1).EQ.1.0)) + IF(COND) THEN + DO 420 I=1,IELEM**2 + KN(IP(NUM),3+2*NELEH+(I-1)*(IELEM+1)+1)=0 + 420 CONTINUE + ELSE IF((NCODE(1).EQ.1).AND.(ICODE(1).EQ.0)) THEN + QFR(IP(NUM),3)=SIDE*DZZ*FRACT/ALBEDO + ELSE IF(NCODE(1).EQ.1) THEN + QFR(IP(NUM),3)=SIDE*DZZ*FRACT + IQFR(IP(NUM),3)=ICODE(1) + ENDIF + ENDIF + IF(LL2) THEN + COND=(NCODE(1).EQ.2).OR.((NCODE(1).EQ.1).AND.(ZCODE(1).EQ.1.0)) + IF(COND) THEN + DO 430 I=1,IELEM**2 + KN(IP(NUM),3+3*NELEH+I*(IELEM+1))=0 + 430 CONTINUE + ELSE IF((NCODE(1).EQ.1).AND.(ICODE(1).EQ.0)) THEN + QFR(IP(NUM),4)=SIDE*DZZ*FRACT/ALBEDO + ELSE IF(NCODE(1).EQ.1) THEN + QFR(IP(NUM),4)=SIDE*DZZ*FRACT + IQFR(IP(NUM),4)=ICODE(1) + ENDIF + ENDIF + 440 CONTINUE + 441 CONTINUE + 442 CONTINUE + NDDIR=NDDIR+(NB2-2*(JSTAGE-NBC)*ISPLH*IELEM)*ISPLH*IELEM**2 + 450 CONTINUE + 455 CONTINUE +*---- +* SET THE CURRENT NUMBERING PART OF MATRIX KN AND MATRIX QFR (Y-AXIS) +*---- + IP(:NBLOS)=0 + DO 460 NUM=1,LT4 + IP(KN(NUM,2)-2*LT4)=NUM + 460 CONTINUE + KEL=0 + NUM=0 + DO 565 IZ=1,LZ + FRACT=1.0 + IF((NCODE(5).EQ.5).AND.(IZ.EQ.1)) FRACT=0.5 + IF((NCODE(6).EQ.5).AND.(IZ.EQ.LZ)) FRACT=0.5 + DZZ=ZZZ(IZ+1)-ZZZ(IZ) + DO 510 JSTAGE=1,NBC + DO 502 JEL=1,ISPLH + DO 501 IRANG=1,NBC+JSTAGE-1 + DO 500 IEL=1,ISPLH + KEL=KEL+1 + IF(IZGLOB(KEL,3).EQ.0) GO TO 500 + NUM=NUM+1 + IF((IRANG.EQ.1).AND.(IEL.EQ.1)) THEN + LL1=.TRUE. + ELSE + LL1=(IZGLOB(KEL-1,3).EQ.0) + ENDIF + IF((IRANG.EQ.NBC+JSTAGE-1).AND.(IEL.EQ.ISPLH)) THEN + LL2=.TRUE. + ELSE + LL2=(IZGLOB(KEL+1,3).EQ.0) + ENDIF + LCOUR=0 + DO 475 J=1,IELEM**2 + DO 470 I=1,IELEM+1 + LCOUR=LCOUR+1 + ITEMP = NDDIR + > + (JEL-1)*(2*(NBC+JSTAGE-1)*IELEM*ISPLH+1)*IELEM**2 + > + (IRANG-1)*(2*IELEM*ISPLH) + > + (IEL-1)*IELEM + > + (J-1)*(2*(NBC+JSTAGE-1)*IELEM*ISPLH+1) + I + IF(LCOUR.GT.NELEH) CALL XABORT('TRISFH: BUG9') + IF(KEL.GT.NBLOS) CALL XABORT('TRISFH: BUG10') + KN(IP(NUM),3+4*NELEH+LCOUR)=ITEMP + KN(IP(NUM),3+5*NELEH+LCOUR)=ITEMP+IELEM*ISPLH + 470 CONTINUE + 475 CONTINUE + IF(LL1) THEN + COND=(NCODE(1).EQ.2).OR.((NCODE(1).EQ.1).AND.(ZCODE(1).EQ.1.0)) + IF(COND) THEN + DO 480 I=1,IELEM**2 + KN(IP(NUM),3+4*NELEH+(I-1)*(IELEM+1)+1)=0 + 480 CONTINUE + ELSE IF((NCODE(1).EQ.1).AND.(ICODE(1).EQ.0)) THEN + QFR(IP(NUM),5)=SIDE*DZZ*FRACT/ALBEDO + ELSE IF(NCODE(1).EQ.1) THEN + QFR(IP(NUM),5)=SIDE*DZZ*FRACT + IQFR(IP(NUM),5)=ICODE(1) + ENDIF + ENDIF + IF(LL2) THEN + COND=(NCODE(1).EQ.2).OR.((NCODE(1).EQ.1).AND.(ZCODE(1).EQ.1.0)) + IF(COND) THEN + DO 490 I=1,IELEM**2 + KN(IP(NUM),3+5*NELEH+I*(IELEM+1))=0 + 490 CONTINUE + ELSE IF((NCODE(1).EQ.1).AND.(ICODE(1).EQ.0)) THEN + QFR(IP(NUM),6)=SIDE*DZZ*FRACT/ALBEDO + ELSE IF(NCODE(1).EQ.1) THEN + QFR(IP(NUM),6)=SIDE*DZZ*FRACT + IQFR(IP(NUM),6)=ICODE(1) + ENDIF + ENDIF + 500 CONTINUE + 501 CONTINUE + 502 CONTINUE + NDDIR=NDDIR+(NB1+2*(JSTAGE-1)*ISPLH*IELEM)*ISPLH*IELEM**2 + 510 CONTINUE +* + DO 560 JSTAGE=NBC+1,2*NBC-1 + DO 552 JEL=1,ISPLH + DO 551 IRANG=1,(2*NBC-2)-(JSTAGE-NBC-1) + DO 550 IEL=1,ISPLH + KEL=KEL+1 + IF(IZGLOB(KEL,3).EQ.0) GO TO 550 + NUM=NUM+1 + IF((IRANG.EQ.1).AND.(IEL.EQ.1)) THEN + LL1=.TRUE. + ELSE + LL1=(IZGLOB(KEL-1,3).EQ.0) + ENDIF + IF((IRANG.EQ.(2*NBC-2)-(JSTAGE-NBC-1)).AND.(IEL.EQ.ISPLH)) THEN + LL2=.TRUE. + ELSE + LL2=(IZGLOB(KEL+1,3).EQ.0) + ENDIF + LCOUR=0 + DO 525 J=1,IELEM**2 + DO 520 I=1,IELEM+1 + LCOUR=LCOUR+1 + ITEMP = NDDIR + > + (JEL-1)*(2*(2*NBC-1+NBC-JSTAGE)*IELEM*ISPLH+1)*IELEM**2 + > + (IRANG-1)*(2*IELEM*ISPLH) + > + (IEL-1)*IELEM + > + (J-1)*(2*(2*NBC-1+NBC-JSTAGE)*IELEM*ISPLH+1) + I + IF(LCOUR.GT.NELEH) CALL XABORT('TRISFH: BUG11') + IF(KEL.GT.NBLOS) CALL XABORT('TRISFH: BUG12') + KN(IP(NUM),3+4*NELEH+LCOUR)=ITEMP + KN(IP(NUM),3+5*NELEH+LCOUR)=ITEMP+IELEM*ISPLH + 520 CONTINUE + 525 CONTINUE + IF(LL1) THEN + COND=(NCODE(1).EQ.2).OR.((NCODE(1).EQ.1).AND.(ZCODE(1).EQ.1.0)) + IF(COND) THEN + DO 530 I=1,IELEM**2 + KN(IP(NUM),3+4*NELEH+(I-1)*(IELEM+1)+1)=0 + 530 CONTINUE + ELSE IF((NCODE(1).EQ.1).AND.(ICODE(1).EQ.0)) THEN + QFR(IP(NUM),5)=SIDE*DZZ*FRACT/ALBEDO + ELSE IF(NCODE(1).EQ.1) THEN + QFR(IP(NUM),5)=SIDE*DZZ*FRACT + IQFR(IP(NUM),5)=ICODE(1) + ENDIF + ENDIF + IF(LL2) THEN + COND=(NCODE(1).EQ.2).OR.((NCODE(1).EQ.1).AND.(ZCODE(1).EQ.1.0)) + IF(COND) THEN + DO 540 I=1,IELEM**2 + KN(IP(NUM),3+5*NELEH+I*(IELEM+1))=0 + 540 CONTINUE + ELSE IF((NCODE(1).EQ.1).AND.(ICODE(1).EQ.0)) THEN + QFR(IP(NUM),6)=SIDE*DZZ*FRACT/ALBEDO + ELSE IF(NCODE(1).EQ.1) THEN + QFR(IP(NUM),6)=SIDE*DZZ*FRACT + IQFR(IP(NUM),6)=ICODE(1) + ENDIF + ENDIF + 550 CONTINUE + 551 CONTINUE + 552 CONTINUE + NDDIR=NDDIR+(NB2-2*(JSTAGE-NBC)*ISPLH*IELEM)*ISPLH*IELEM**2 + 560 CONTINUE + 565 CONTINUE +*---- +* SET THE CURRENT NUMBERING PART OF MATRIX KN AND MATRIX QFR (Z-AXIS) +*---- + KEL=0 + NUM=0 + DO 635 IZ=1,LZ + DO 630 IX=1,LXH*ISPLH**2 + KEL=KEL+1 + IF(IZGLOB(KEL,1).EQ.0) GO TO 630 + NUM=NUM+1 + IF(IZ.EQ.1) THEN + LL1=.TRUE. + ELSE + LL1=(IZGLOB(KEL-LXH*ISPLH**2,1).EQ.0) + ENDIF + IF(IZ.EQ.LZ) THEN + LL2=.TRUE. + ELSE + LL2=(IZGLOB(KEL+LXH*ISPLH**2,1).EQ.0) + ENDIF + DO 572 K=0,2 ! THREE LOZENGES PER HEXAGON + DO 571 I=0,1 ! FACE ZINF/ZSUP + DO 570 J=1,IELEM**2 + LCOUR=(2*K+I)*IELEM**2+J + IF(LCOUR.GT.NELEZ) CALL XABORT('TRISFH: BUG11') + IF(KEL.GT.NBLOS) CALL XABORT('TRISFH: BUG12') + ITEMP = NDDIR + > + 3*(IX-1)*(LZ+1)*IELEM**2 + > + K*(LZ+1)*IELEM**2 + > + (J-1)*(LZ+1) + IZ + I + KN(NUM,3+6*NELEH+LCOUR)=ITEMP + 570 CONTINUE + 571 CONTINUE + 572 CONTINUE +* +* REFL OR ALBE BOUNDARY CONDITION + IF(LL1) THEN + COND=(NCODE(5).EQ.2).OR.((NCODE(5).EQ.1).AND.(ZCODE(5).EQ.1.0)) + IF(COND) THEN + DO 585 K=0,2 + DO 580 J=1,IELEM**2 + LCINF=2*K*IELEM**2+J + KN(NUM,3+6*NELEH+LCINF)=0 + 580 CONTINUE + 585 CONTINUE + ELSE IF((NCODE(5).EQ.1).AND.(ICODE(5).EQ.0)) THEN + ALBEDO=0.5*(1.0-ZCODE(5))/(1.0+ZCODE(5)) + QFR(NUM,7)=0.8660254038*SIDE*SIDE/ALBEDO + ELSE IF(NCODE(5).EQ.1) THEN + QFR(NUM,7)=0.8660254038*SIDE*SIDE + IQFR(NUM,7)=ICODE(5) + ENDIF + ENDIF + IF(LL2) THEN + COND=(NCODE(6).EQ.2).OR.((NCODE(6).EQ.1).AND.(ZCODE(6).EQ.1.0)) + IF(COND) THEN + DO 595 K=0,2 + DO 590 J=1,IELEM**2 + LCSUP=(2*K+1)*IELEM**2+J + KN(NUM,3+6*NELEH+LCSUP)=0 + 590 CONTINUE + 595 CONTINUE + ELSE IF((NCODE(6).EQ.1).AND.(ICODE(6).EQ.0)) THEN + ALBEDO=0.5*(1.0-ZCODE(6))/(1.0+ZCODE(6)) + QFR(NUM,8)=0.8660254038*SIDE*SIDE/ALBEDO + ELSE IF(NCODE(6).EQ.1) THEN + QFR(NUM,8)=0.8660254038*SIDE*SIDE + IQFR(NUM,8)=ICODE(6) + ENDIF + ENDIF +* TRAN BOUNDARY CONDITION + IF((IZ.EQ.LZ).AND.(NCODE(6).EQ.4)) THEN + DO 605 K=0,2 + DO 600 J=1,IELEM**2 + LCSUP=(2*K+1)*IELEM**2+J + KN(NUM,3+6*NELEH+LCSUP)=KN(NUM,3+6*NELEH+LCSUP)-LZ + 600 CONTINUE + 605 CONTINUE + ENDIF +* SYME BOUNDARY CONDITION + IF((NCODE(5).EQ.5).AND.(IZ.EQ.1)) THEN + QFR(NUM,7)=QFR(NUM,8) + IQFR(NUM,7)=IQFR(NUM,8) + DO 615 K=0,2 + DO 610 J=1,IELEM**2 + LCINF=2*K*IELEM**2+J + LCSUP=(2*K+1)*IELEM**2+J + KN(NUM,3+6*NELEH+LCINF)=-KN(NUM,3+6*NELEH+LCSUP) + 610 CONTINUE + 615 CONTINUE + ELSE IF((NCODE(6).EQ.5).AND.(IZ.EQ.LZ)) THEN + QFR(NUM,8)=QFR(NUM,7) + IQFR(NUM,8)=IQFR(NUM,7) + DO 625 K=0,2 + DO 620 J=1,IELEM**2 + LCINF=2*K*IELEM**2+J + LCSUP=(2*K+1)*IELEM**2+J + KN(NUM,3+6*NELEH+LCSUP)=-KN(NUM,3+6*NELEH+LCINF) + 620 CONTINUE + 625 CONTINUE + ENDIF + 630 CONTINUE + 635 CONTINUE +*---- +* REMOVING THE UNUSED UNKNOWNS INDICES FROM KN +*---- + IP(:3*LL4W0+LL4Z0)=0 + DO 645 KEL=1,LT4 + DO 640 ICOUR=1,6*NELEH+NELEZ + IND=ABS(KN(KEL,3+ICOUR)) + IF(IND.GT.MAXIP) CALL XABORT('TRISFH: MAXIP OVERFLOW.') + IF(IND.NE.0) IP(IND)=1 + 640 CONTINUE + 645 CONTINUE + LL4W=0 + DO 650 IND=1,LL4W0 + IF(IP(IND).EQ.1) THEN + LL4W=LL4W+1 + IP(IND)=LL4W + ENDIF + 650 CONTINUE + LL4X=0 + DO 660 IND=1,LL4W0 + IF(IP(LL4W0+IND).EQ.1) THEN + LL4X=LL4X+1 + IP(LL4W0+IND)=LL4W+LL4X + ENDIF + 660 CONTINUE + LL4Y=0 + DO 670 IND=1,LL4W0 + IF(IP(2*LL4W0+IND).EQ.1) THEN + LL4Y=LL4Y+1 + IP(2*LL4W0+IND)=LL4W+LL4X+LL4Y + ENDIF + 670 CONTINUE + LL4Z=0 + DO 680 IND=1,LL4Z0 + IF(IP(3*LL4W0+IND).EQ.1) THEN + LL4Z=LL4Z+1 + IP(3*LL4W0+IND)=LL4W+LL4X+LL4Y+LL4Z + ENDIF + 680 CONTINUE + DO 695 KEL=1,LT4 + DO 690 ICOUR=1,6*NELEH+NELEZ + IF(KN(KEL,3+ICOUR).NE.0) THEN + IND=KN(KEL,3+ICOUR) + KN(KEL,3+ICOUR)=SIGN(IP(ABS(IND)),IND) + ENDIF + 690 CONTINUE + 695 CONTINUE + LL4=LL4F+LL4W+LL4X+LL4Y+LL4Z +*---- +* PRINT A FEW GEOMETRY CHARACTERISTICS +*---- + IF(IMPX.GT.0) THEN + write(6,*) ' ' + write(6,*) 'ISPLH =',ISPLH + write(6,*) 'IELEM =',IELEM + write(6,*) 'NELEH =',NELEH + write(6,*) 'NELEZ =',NELEZ + write(6,*) 'NBLOS =',NBLOS + write(6,*) 'LL4F =',LL4F + write(6,*) 'LL4W =',LL4W + write(6,*) 'LL4X =',LL4X + write(6,*) 'LL4Y =',LL4Y + write(6,*) 'LL4Z =',LL4Z + write(6,*) 'NBC =',NBC + ENDIF +*---- +* SET IPERT +*---- + KEL=0 + DO 714 IZ=1,LZ + DO 703 JSTAGE=1,NBC + DO 702 JEL=1,ISPLH + DO 701 IRANG=1,NBC+JSTAGE-1 + DO 700 IEL=1,ISPLH + KEL=KEL+1 + IHEX=IZGLOB(KEL,1) + IF(IHEX.EQ.0) THEN + IPERT(KEL)=0 + ELSE + IPERT(KEL)=(IHEX-1)*ISPLH**2+(IEL-1)*ISPLH+JEL + ENDIF + IF(IPERT(KEL).GT.NBLOS) call XABORT('TRISFH: NBLOS OVERFLOW(1)') + 700 CONTINUE + 701 CONTINUE + 702 CONTINUE + 703 CONTINUE + DO 713 JSTAGE=NBC+1,2*NBC-1 + DO 712 JEL=1,ISPLH + DO 711 IRANG=1,(2*NBC-2)-(JSTAGE-NBC-1) + DO 710 IEL=1,ISPLH + KEL=KEL+1 + IHEX=IZGLOB(KEL,1) + IF(IHEX.EQ.0) THEN + IPERT(KEL)=0 + ELSE + IPERT(KEL)=(IHEX-1)*ISPLH**2+(IEL-1)*ISPLH+JEL + ENDIF + IF(IPERT(KEL).GT.NBLOS) call XABORT('TRISFH: NBLOS OVERFLOW(2)') + 710 CONTINUE + 711 CONTINUE + 712 CONTINUE + 713 CONTINUE + 714 CONTINUE + IF(KEL.NE.NBLOS) CALL XABORT('TRISFH: IPERT FAILURE.') +*---- +* SET IDL, VOL, FRZ AND ZZ +*---- + NUM=0 + IDL(:3,:NBLOS)=0 + VOL(:3,:NBLOS)=0.0 + FRZ(:NBLOS)=0.0 + ZZ(:3,:NBLOS)=0.0 + DO 725 IZ=1,LZ + FRACT=1.0 + IF((NCODE(5).EQ.5).AND.(IZ.EQ.1)) FRACT=0.5 + IF((NCODE(6).EQ.5).AND.(IZ.EQ.LZ)) FRACT=0.5 + DZ=ZZZ(IZ+1)-ZZZ(IZ) + DO 720 J=1,LXH*ISPLH**2 + KEL=(IZ-1)*LXH*ISPLH**2+J + KEL2=IPERT(KEL) + IF(KEL2.EQ.0) GO TO 720 + NUM=NUM+1 + IDL(1,KEL2)=(NUM-1)*IELEM**3+1 + IDL(2,KEL2)=(KN(NUM,1)-1)*IELEM**3+1 + IDL(3,KEL2)=(KN(NUM,2)-1)*IELEM**3+1 + VOL(:3,KEL2)=2.59807587*SIDE*SIDE*DZ*FRACT/REAL(3) + FRZ(KEL)=FRACT + ZZ(:3,KEL2)=DZ + 720 CONTINUE + 725 CONTINUE + IF(IMPX.GT.2) THEN + WRITE(6,790) 'MAT',(((MAT(I,J,K),I=1,3),J=1,ISPLH**2), + 1 K=1,LXH*LZ) + WRITE(6,790) 'IDL',((IDL(I,J),I=1,3),J=1,NBLOS) + WRITE(6,800) 'ZZ ',((ZZ(I,J),I=1,3),J=1,NBLOS) + WRITE(6,800) 'VOL',((VOL(I,J),I=1,3),J=1,NBLOS) + ENDIF +* + IF(IMPX.GT.0) WRITE(6,810) LL4 + IF(IMPX.GT.2) THEN + WRITE (6,830) + DO 730 K=1,NBLOS + WRITE (6,840) K,(IZGLOB(K,I),I=1,3) + 730 CONTINUE + WRITE (6,850) + DO 740 K=1,LT4 + WRITE (6,860) K,(KN(K,I),I=1,3+2*NELEH) + WRITE (6,870) 'X',(KN(K,I),I=3+2*NELEH+1,3+4*NELEH) + WRITE (6,870) 'Y',(KN(K,I),I=3+4*NELEH+1,3+6*NELEH) + IF(LL4Z.GT.0) THEN + WRITE (6,870) 'Z',(KN(K,I),I=3+6*NELEH+1,3+6*NELEH+NELEZ) + ENDIF + 740 CONTINUE + WRITE (6,880) + DO 750 K=1,LT4 + WRITE (6,890) K,(QFR(K,I),I=1,8) + 750 CONTINUE + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IZGLOB,IP,IJP) + RETURN +* + 790 FORMAT(1X,A3/14(2X,I6)) + 800 FORMAT(1X,A3/7(2X,E12.5)) + 810 FORMAT(31H NUMBER OF UNKNOWNS PER GROUP =,I8) + 830 FORMAT(/22H NUMBERING OF HEXAGONS/1X,21(1H-)//8H ELEMENT,4X, + 1 24H W ----- X ----- Y -----) + 840 FORMAT(1X,I6,5X,3I8) + 850 FORMAT(/22H NUMBERING OF UNKNOWNS/1X,21(1H-)//8H ELEMENT,5X, + 1 20H---> X ---> Y ---> W,4X,8HCURRENTS,89(1H.)) + 860 FORMAT(1X,I6,5X,3I7,4X,1HW,12I8:/(38X,12I8)) + 870 FORMAT(37X,A1,12I8:/(38X,12I8)) + 880 FORMAT(/8H ELEMENT,3X,23HVOID BOUNDARY CONDITION/15X,7(1H-), + 1 3H W ,7(1H-),3X,7(1H-),3H X ,7(1H-),3X,7(1H-),3H Y ,7(1H-), + 2 3X,7(1H-),3H Z ,7(1H-)) + 890 FORMAT(1X,I6,5X,1P,10E10.1/(12X,1P,10E10.1)) + END diff --git a/Trivac/src/TRISPS.f b/Trivac/src/TRISPS.f new file mode 100755 index 0000000..10cd2cf --- /dev/null +++ b/Trivac/src/TRISPS.f @@ -0,0 +1,281 @@ +*DECK TRISPS + SUBROUTINE TRISPS(IPTRK,IPMACR,IPMACP,IPSYS,IMPX,NGRP,NEL,NLF, + 1 NANI,NBFIS,NALBP,LDIFF,IPR,MAT,VOL,NBMIX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover the cross-section data in LCM object with pointer IPMACR, +* compute and store the corresponding Trivac system matrices for a +* simplified PN approximation (or a perturbation to the system +* matrices). +* +*Copyright: +* Copyright (C) 2005 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IPTRK L_TRACK pointer to the TRIVAC tracking information. +* IPMACR L_MACROLIB pointer to the unperturbed cross sections. +* IPMACP L_MACROLIB pointer to the perturbed cross sections if +* IPR.gt.0. Equal to IPMACR if IPR=0. +* IPSYS L_SYSTEM pointer to system matrices. +* IMPX print parameter (equal to zero for no print). +* NGRP number of energy groups. +* NEL total number of finite elements. +* NLF number of Legendre orders for the flux (even number). +* NANI number of Legendre orders for the scattering cross sections. +* NBFIS number of fissionable isotopes. +* NALBP number of physical albedos per energy group. +* LDIFF flag set to .true. to use 1/3D as 'NTOT1' cross sections. +* IPR type of assembly: +* =0: calculation of the system matrices; +* =1: calculation of the derivative of these matrices; +* =2: calculation of the first variation of these matrices; +* =3: identical to IPR=2, but these variation are added to +* unperturbed system matrices. +* MAT index-number of the mixture type assigned to each volume. +* VOL volumes. +* NBMIX total number of material mixtures in the macrolib. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPMACR,IPMACP,IPSYS + INTEGER IMPX,NGRP,NEL,NLF,NANI,NBFIS,NALBP,IPR,MAT(NEL),NBMIX + REAL VOL(NEL) + LOGICAL LDIFF +*---- +* LOCAL VARIABLES +*---- + CHARACTER TEXDIG*12,TEXT12*12,CM*2 + LOGICAL LFIS + TYPE(C_PTR) JPMACP,KPMACP + REAL, DIMENSION(:), ALLOCATABLE :: WORK + REAL, DIMENSION(:,:), ALLOCATABLE :: GAMMA,SGD,ZUFIS + REAL, DIMENSION(:,:,:), ALLOCATABLE :: CHI + DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: GAR + DOUBLE PRECISION, DIMENSION(:,:,:), ALLOCATABLE :: RCAT,RCATI, + 1 RCAT2 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(GAMMA(NALBP,NGRP),SGD(NBMIX,2*NLF),WORK(NBMIX*NGRP), + 1 CHI(NBMIX,NBFIS,NGRP),ZUFIS(NBMIX,NBFIS)) + ALLOCATE(RCAT(NGRP,NGRP,NBMIX),RCATI(NGRP,NGRP,NBMIX)) +*---- +* PROCESS PHYSICAL ALBEDOS. +*---- + IF(NALBP.GT.0) THEN + CALL TRIALB(IPTRK,IPMACR,IPMACP,IPSYS,NGRP,NALBP,IPR,GAMMA) + ENDIF +*---- +* PROCESS MACROLIB INFORMATION FOR VARIOUS LEGENDRE ORDERS AND +* INVERSION OF THE REMOVAL MATRIX. +*---- + IF(NLF.EQ.0) CALL XABORT('TRISPS: SPN APPROXIMATION REQUESTED.') + DO 142 IL=1,NLF + WRITE(CM,'(I2.2)') IL-1 + CALL TRIRCA(IPMACR,IPMACR,NGRP,NBMIX,NANI,LDIFF,IL,0,RCAT) + IF(IPR.EQ.0) THEN + DO 20 IBM=1,NBMIX + DO 15 JGR=1,NGRP + DO 10 IGR=1,NGRP + RCATI(IGR,JGR,IBM)=RCAT(IGR,JGR,IBM) + 10 CONTINUE + 15 CONTINUE + CALL ALINVD(NGRP,RCATI(1,1,IBM),NGRP,IER) + IF(IER.NE.0) CALL XABORT('TRISPS: SINGULAR MATRIX(1).') + 20 CONTINUE + ELSE + ALLOCATE(RCAT2(NGRP,NGRP,NBMIX),GAR(NGRP)) + CALL TRIRCA(IPMACR,IPMACP,NGRP,NBMIX,NANI,LDIFF,IL,IPR,RCAT2) + IF(IPR.EQ.1) THEN + DO 62 IBM=1,NBMIX + DO 31 JGR=1,NGRP + DO 30 IGR=1,NGRP + RCATI(IGR,JGR,IBM)=RCAT(IGR,JGR,IBM) + RCAT(IGR,JGR,IBM)=RCAT2(IGR,JGR,IBM) + 30 CONTINUE + 31 CONTINUE + CALL ALINVD(NGRP,RCATI(1,1,IBM),NGRP,IER) + IF(IER.NE.0) CALL XABORT('TRISPS: SINGULAR MATRIX(2).') + DO 42 JGR=1,NGRP + RCAT2(:NGRP,JGR,IBM)=0.0D0 + DO 41 IGR=1,NGRP + DO 40 KGR=1,NGRP + RCAT2(IGR,JGR,IBM)=RCAT2(IGR,JGR,IBM)+RCATI(IGR,KGR,IBM)* + 1 RCAT(KGR,JGR,IBM) + 40 CONTINUE + 41 CONTINUE + 42 CONTINUE + DO 61 JGR=1,NGRP + GAR(:NGRP)=0.0D0 + DO 51 IGR=1,NGRP + DO 50 KGR=1,NGRP + GAR(IGR)=GAR(IGR)+RCAT2(IGR,KGR,IBM)*RCATI(KGR,JGR,IBM) + 50 CONTINUE + 51 CONTINUE + DO 60 KGR=1,NGRP + RCATI(KGR,JGR,IBM)=-GAR(KGR) + 60 CONTINUE + 61 CONTINUE + 62 CONTINUE + ELSE IF(IPR.EQ.2) THEN + DO 82 IBM=1,NBMIX + DO 71 JGR=1,NGRP + DO 70 IGR=1,NGRP + RCATI(IGR,JGR,IBM)=RCAT(IGR,JGR,IBM) + RCAT(IGR,JGR,IBM)=RCAT2(IGR,JGR,IBM) + RCAT2(IGR,JGR,IBM)=RCAT(IGR,JGR,IBM)+RCATI(IGR,JGR,IBM) + 70 CONTINUE + 71 CONTINUE + CALL ALINVD(NGRP,RCATI(1,1,IBM),NGRP,IER) + IF(IER.NE.0) CALL XABORT('TRISPS: SINGULAR MATRIX(3).') + CALL ALINVD(NGRP,RCAT2(1,1,IBM),NGRP,IER) + IF(IER.NE.0) CALL XABORT('TRISPS: SINGULAR MATRIX(4).') + DO 81 JGR=1,NGRP + DO 80 IGR=1,NGRP + RCATI(IGR,JGR,IBM)=RCAT2(IGR,JGR,IBM)-RCATI(IGR,JGR,IBM) + 80 CONTINUE + 81 CONTINUE + 82 CONTINUE + ELSE IF(IPR.EQ.3) THEN + DO 100 IBM=1,NBMIX + DO 91 JGR=1,NGRP + DO 90 IGR=1,NGRP + RCAT(IGR,JGR,IBM)=RCAT(IGR,JGR,IBM)+RCAT2(IGR,JGR,IBM) + RCATI(IGR,JGR,IBM)=RCAT(IGR,JGR,IBM) + 90 CONTINUE + 91 CONTINUE + CALL ALINVD(NGRP,RCATI(1,1,IBM),NGRP,IER) + IF(IER.NE.0) CALL XABORT('TRISPS: SINGULAR MATRIX(5).') + 100 CONTINUE + ENDIF + DEALLOCATE(GAR,RCAT2) + ENDIF +* + DO 141 IGR=1,NGRP + IGMIN=IGR + IGMAX=IGR + DO 111 IBM=1,NBMIX + DO 110 JGR=1,NGRP + IF((RCAT(IGR,JGR,IBM).NE.0.0).OR.(RCATI(IGR,JGR,IBM).NE.0.0)) THEN + IGMIN=MIN(IGMIN,JGR) + IGMAX=MAX(IGMAX,JGR) + ENDIF + 110 CONTINUE + 111 CONTINUE + DO 140 JGR=IGMIN,IGMAX + DO 120 IBM=1,NBMIX + WORK(IBM)=REAL(RCAT(IGR,JGR,IBM)) + 120 CONTINUE + WRITE(TEXT12,'(4HSCAR,A2,2I3.3)') CM,IGR,JGR + CALL LCMPUT(IPSYS,TEXT12,NBMIX,2,WORK) + DO 130 IBM=1,NBMIX + WORK(IBM)=REAL(RCATI(IGR,JGR,IBM)) + 130 CONTINUE + WRITE(TEXT12,'(4HSCAI,A2,2I3.3)') CM,IGR,JGR + CALL LCMPUT(IPSYS,TEXT12,NBMIX,2,WORK) + 140 CONTINUE + 141 CONTINUE + 142 CONTINUE +*---- +* COMPUTE AND FACTORIZE THE DIAGONAL SYSTEM MATRICES. +*---- + DO 162 IGR=1,NGRP + DO 150 IL=1,NLF + WRITE(TEXT12,'(4HSCAR,I2.2,2I3.3)') IL-1,IGR,IGR + CALL LCMGET(IPSYS,TEXT12,SGD(1,IL)) + WRITE(TEXT12,'(4HSCAI,I2.2,2I3.3)') IL-1,IGR,IGR + CALL LCMGET(IPSYS,TEXT12,SGD(1,NLF+IL)) + 150 CONTINUE + WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR + CALL TRIASN(TEXT12,IPTRK,IPSYS,IMPX,NBMIX,NEL,NLF,NALBP,IPR,MAT, + 1 VOL,GAMMA(1,IGR),SGD(1,1),SGD(1,1+NLF)) +*---- +* PUT A FLAG IN IPSYS TO IDENTIFY NON-ZERO SCATTERING TERMS. +*---- + DO 161 IL=1,NLF + DO 160 JGR=1,NGRP + WRITE(TEXT12,'(4HSCAR,I2.2,2I3.3)') IL-1,IGR,JGR + CALL LCMLEN(IPSYS,TEXT12,LENGT,ITYLCM) + IF(LENGT.EQ.NBMIX) THEN + WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR + CALL LCMPUT(IPSYS,TEXT12,1,2,0.0) + ENDIF + 160 CONTINUE + 161 CONTINUE + 162 CONTINUE +*---- +* PROCESS FISSION SPECTRUM TERMS +*---- + JPMACP=LCMGID(IPMACP,'GROUP') + KPMACP=LCMGIL(JPMACP,1) + CALL LCMLEN(KPMACP,'CHI',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + IF(LENGT.NE.NBMIX*NBFIS) CALL XABORT('TRISPS: INVALID LENGTH ' + 1 //'FOR CHI INFORMATION.') + DO 180 IGR=1,NGRP + KPMACP=LCMGIL(JPMACP,IGR) + CALL LCMGET(KPMACP,'CHI',CHI(1,1,IGR)) + 180 CONTINUE + ELSE + DO 192 IBM=1,NBMIX + DO 191 IFISS=1,NBFIS + CHI(IBM,IFISS,1)=1.0 + DO 190 IGR=2,NGRP + CHI(IBM,IFISS,IGR)=0.0 + 190 CONTINUE + 191 CONTINUE + 192 CONTINUE + ENDIF +*---- +* PROCESS FISSION NUSIGF TERMS +*---- + DO 230 IGR=1,NGRP +* PROCESS SECONDARY GROUP IGR. + LFIS=.FALSE. + DO 201 IBM=1,NBMIX + DO 200 IFISS=1,NBFIS + LFIS=LFIS.OR.(CHI(IBM,IFISS,IGR).NE.0.0) + 200 CONTINUE + 201 CONTINUE + IF(LFIS) THEN + DO 220 JGR=1,NGRP + KPMACP=LCMGIL(JPMACP,JGR) + CALL LCMLEN(KPMACP,'NUSIGF',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + IF(LENGT.NE.NBMIX*NBFIS) CALL XABORT('TRISPS: INVALID LENG' + 1 //'TH FOR NUSIGF INFORMATION.') + CALL LCMGET(KPMACP,'NUSIGF',ZUFIS) + SGD(:NBMIX,1)=0.0 + DO 211 IBM=1,NBMIX + DO 210 IFISS=1,NBFIS + SGD(IBM,1)=SGD(IBM,1)+CHI(IBM,IFISS,IGR)*ZUFIS(IBM,IFISS) + 210 CONTINUE + 211 CONTINUE + WRITE(TEXDIG,'(4HFISS,2I3.3)') IGR,JGR + CALL LCMPUT(IPSYS,TEXDIG,NBMIX,2,SGD(1,1)) + WRITE (TEXDIG,'(1HB,2I3.3)') IGR,JGR + CALL TRIDIG(TEXDIG,IPTRK,IPSYS,IMPX,NBMIX,NEL,IPR,MAT,VOL, + 1 SGD) + ENDIF + 220 CONTINUE + ENDIF + 230 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(RCAT,RCATI) + DEALLOCATE(GAMMA,SGD,WORK,CHI,ZUFIS) + RETURN + END diff --git a/Trivac/src/TRISYS.f b/Trivac/src/TRISYS.f new file mode 100755 index 0000000..722f1e9 --- /dev/null +++ b/Trivac/src/TRISYS.f @@ -0,0 +1,285 @@ +*DECK TRISYS
+ SUBROUTINE TRISYS(IPTRK,IPMACR,IPMACP,IPSYS,IMPX,NGRP,NEL,NBFIS,
+ 1 NALBP,IPR,MAT,VOL,NBMIX)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Recover the diffusion coefficient and cross-section data in the LCM
+* object with pointer IPMACR, compute and store the corresponding
+* Trivac system matrices (or a perturbation to the system matrices).
+*
+*Copyright:
+* Copyright (C) 2002 Ecole Polytechnique de Montreal
+* This library is free software; you can redistribute it and/or
+* modify it under the terms of the GNU Lesser General Public
+* License as published by the Free Software Foundation; either
+* version 2.1 of the License, or (at your option) any later version
+*
+*Author(s): A. Hebert
+*
+*Parameters: input
+* IPTRK L_TRACK pointer to the TRIVAC tracking information.
+* IPMACR L_MACROLIB pointer to the unperturbed cross sections.
+* IPMACP L_MACROLIB pointer to the perturbed cross sections if
+* IPR.gt.0. Equal to IPMACR if IPR=0.
+* IPSYS L_SYSTEM pointer to system matrices.
+* IMPX print parameter (equal to zero for no print).
+* NGRP number of energy groups.
+* NEL total number of finite elements.
+* NBFIS number of fissionable isotopes.
+* NALBP number of physical albedos per energy group.
+* IPR type of assembly:
+* =0: calculation of the system matrices;
+* =1: calculation of the derivative of these matrices;
+* =2: calculation of the first variation of these matrices;
+* =3: identical to IPR=2, but these variation are added to
+* unperturbed system matrices.
+* MAT index-number of the mixture type assigned to each volume.
+* VOL volumes.
+* NBMIX total number of material mixtures in the macrolib.
+*
+*-----------------------------------------------------------------------
+*
+ USE GANLIB
+*----
+* SUBROUTINE ARGUMENTS
+*----
+ TYPE(C_PTR) IPTRK,IPMACR,IPMACP,IPSYS
+ INTEGER IMPX,NGRP,NEL,NBFIS,NALBP,IPR,MAT(NEL),NBMIX
+ REAL VOL(NEL)
+*----
+* LOCAL VARIABLES
+*----
+ CHARACTER TEXDIG*12,HSMG*131
+ LOGICAL LFIS
+ TYPE(C_PTR) JPMACR,KPMACR,JPMACP,KPMACP
+ INTEGER, DIMENSION(:), ALLOCATABLE :: IJJ,NJJ,IPOS
+ REAL, DIMENSION(:), ALLOCATABLE :: WORK
+ REAL, DIMENSION(:,:), ALLOCATABLE :: GAMMA,SGD,DSGD,ZUFIS
+ REAL, DIMENSION(:,:,:), ALLOCATABLE :: CHI
+*----
+* SCRATCH STORAGE ALLOCATION
+*----
+ ALLOCATE(IJJ(NBMIX),NJJ(NBMIX),IPOS(NBMIX))
+ ALLOCATE(GAMMA(NALBP,NGRP),SGD(NBMIX,4),DSGD(NBMIX,4),
+ 1 WORK(NBMIX*NGRP),CHI(NBMIX,NBFIS,NGRP),ZUFIS(NBMIX,NBFIS))
+*----
+* PROCESS PHYSICAL ALBEDOS.
+*----
+ IF(NALBP.GT.0) THEN
+ CALL TRIALB(IPTRK,IPMACR,IPMACP,IPSYS,NGRP,NALBP,IPR,GAMMA)
+ ENDIF
+*----
+* LOOP OVER ENERGY GROUPS
+*----
+ JPMACR=LCMGID(IPMACR,'GROUP')
+ JPMACP=LCMGID(IPMACP,'GROUP')
+ DO 110 IGR=1,NGRP
+* PROCESS SECONDARY GROUP IGR.
+ KPMACR=LCMGIL(JPMACR,IGR)
+ KPMACP=LCMGIL(JPMACP,IGR)
+*----
+* PROCESS LEAKAGE AND REMOVAL TERMS
+*----
+ CALL LCMLEN(KPMACR,'NTOT0',LENGT,ITYLCM)
+ IF(LENGT.EQ.0) THEN
+ CALL XABORT('TRISYS: NO TOTAL CROSS SECTIONS.')
+ ELSE IF(LENGT.GT.NBMIX) THEN
+ CALL XABORT('TRISYS: INVALID LENGTH FOR TOTAL CROSS SECTIONS.')
+ ENDIF
+ CALL LCMGET(KPMACR,'NTOT0',SGD(1,4))
+ CALL LCMLEN(KPMACR,'SIGW00',LENGT,ITYLCM)
+ IF(LENGT.GT.0) THEN
+ IF(LENGT.GT.NBMIX) CALL XABORT('TRISYS: INVALID LENGTH FOR '
+ 1 //'''SIGW00'' CROSS SECTIONS.')
+ CALL LCMGET(KPMACR,'SIGW00',SGD(1,1))
+ DO 10 IBM=1,LENGT
+ SGD(IBM,4)=SGD(IBM,4)-SGD(IBM,1)
+ 10 CONTINUE
+ ENDIF
+ CALL LCMLEN(KPMACR,'DIFF',LENGT1,ITYLCM)
+ IF(LENGT1.GT.0) THEN
+ IF(LENGT1.GT.NBMIX) CALL XABORT('TRISYS: INVALID LENGTH FOR'
+ 1 //' DIFF (ISOTROPIC DIFFUSION COEFFICIENT).')
+ CALL LCMGET(KPMACR,'DIFF',SGD(1,1))
+ DO 20 IBM=1,LENGT1
+ SGD(IBM,2)=SGD(IBM,1)
+ SGD(IBM,3)=SGD(IBM,1)
+ 20 CONTINUE
+ ENDIF
+ CALL LCMLEN(KPMACR,'DIFFX',LENGT2,ITYLCM)
+ IF(LENGT2.GT.0) THEN
+ IF(LENGT2.GT.NBMIX) CALL XABORT('TRISYS: INVALID LENGTH FOR'
+ 1 //' DIFFX (ANISOTROPIC DIFFUSION COEFFICIENT).')
+ CALL LCMGET(KPMACR,'DIFFX',SGD(1,1))
+ DO 30 IBM=1,LENGT2
+ SGD(IBM,2)=SGD(IBM,1)
+ SGD(IBM,3)=SGD(IBM,1)
+ 30 CONTINUE
+ ENDIF
+ CALL LCMLEN(KPMACR,'DIFFY',LENGT3,ITYLCM)
+ IF(LENGT3.GT.0) THEN
+ IF(LENGT3.GT.NBMIX) CALL XABORT('TRISYS: INVALID LENGTH FOR'
+ 1 //' DIFFY (ANISOTROPIC DIFFUSION COEFFICIENT).')
+ CALL LCMGET(KPMACR,'DIFFY',SGD(1,2))
+ ENDIF
+ CALL LCMLEN(KPMACR,'DIFFZ',LENGT3,ITYLCM)
+ IF(LENGT3.GT.0) THEN
+ IF(LENGT3.GT.NBMIX) CALL XABORT('TRISYS: INVALID LENGTH FOR'
+ 1 //' DIFFZ (ANISOTROPIC DIFFUSION COEFFICIENT).')
+ CALL LCMGET(KPMACR,'DIFFZ',SGD(1,3))
+ ENDIF
+ IF((LENGT1.EQ.0).AND.(LENGT2.EQ.0)) THEN
+ CALL XABORT('TRISYS: NO DIFFUSION COEFFICIENTS.')
+ ENDIF
+ WRITE(TEXDIG,'(1HA,2I3.3)') IGR,IGR
+ IF(IPR.EQ.0) THEN
+* COMPUTE UNPERTURBED SYSTEM MATRICES.
+ DO 35 IBM=1,NBMIX
+ IF((SGD(IBM,1).LT.0.0).OR.(SGD(IBM,4).LT.0.0)) THEN
+ WRITE(HSMG,'(28HTRISYS: NEGATIVE XS IN GROUP,I5)') IGR
+ CALL XABORT(HSMG)
+ ENDIF
+ 35 CONTINUE
+ CALL TRIASM(TEXDIG,IPTRK,IPSYS,IMPX,NBMIX,NEL,NALBP,0,MAT,VOL,
+ 1 GAMMA(1,IGR),SGD,SGD)
+ ELSE
+* COMPUTE A PERTURBATION TO THE SYSTEM MATRICES
+ DO 45 J=1,4
+ DO 40 IBM=1,NBMIX
+ DSGD(IBM,J)=0.0
+ 40 CONTINUE
+ 45 CONTINUE
+ CALL LCMLEN(KPMACP,'NTOT0',LENGT,ITYLCM)
+ IF(LENGT.GT.0) THEN
+ IF(LENGT.GT.NBMIX) CALL XABORT('TRISYS: INVALID LENGTH FOR'
+ 1 //' DELTA TOTAL CROSS SECTIONS.')
+ CALL LCMGET(KPMACP,'NTOT0',DSGD(1,4))
+ ENDIF
+ CALL LCMLEN(KPMACP,'SIGW00',LENGT,ITYLCM)
+ IF(LENGT.GT.0) THEN
+ IF(LENGT.GT.NBMIX) CALL XABORT('TRISYS: INVALID LENGTH FOR'
+ 1 //' DELTA ''SIGW00'' CROSS SECTIONS.')
+ CALL LCMGET(KPMACP,'SIGW00',DSGD(1,1))
+ DO 50 IBM=1,LENGT
+ DSGD(IBM,4)=DSGD(IBM,4)-DSGD(IBM,1)
+ DSGD(IBM,1)=0.0
+ 50 CONTINUE
+ ENDIF
+ CALL LCMLEN(KPMACP,'DIFF',LENGT,ITYLCM)
+ IF(LENGT.GT.0) THEN
+ IF(LENGT.GT.NBMIX) CALL XABORT('TRISYS: INVALID LENGTH FOR'
+ 1 //' DELTA DIFF (ISOTROPIC DIFFUSION COEFFICIENT).')
+ CALL LCMGET(KPMACP,'DIFF',DSGD(1,1))
+ DO 60 IBM=1,LENGT
+ DSGD(IBM,2)=DSGD(IBM,1)
+ DSGD(IBM,3)=DSGD(IBM,1)
+ 60 CONTINUE
+ ENDIF
+ CALL LCMLEN(KPMACP,'DIFFX',LENGT,ITYLCM)
+ IF(LENGT.GT.0) THEN
+ IF(LENGT.GT.NBMIX) CALL XABORT('TRISYS: INVALID LENGTH FOR'
+ 1 //' DELTA DIFFX (ANISOTROPIC DIFFUSION COEFFICIENT).')
+ CALL LCMGET(KPMACP,'DIFFX',DSGD(1,1))
+ CALL LCMGET(KPMACP,'DIFFY',DSGD(1,2))
+ CALL LCMGET(KPMACP,'DIFFZ',DSGD(1,3))
+ ENDIF
+ CALL TRIASM(TEXDIG,IPTRK,IPSYS,IMPX,NBMIX,NEL,NALBP,IPR,MAT,
+ 1 VOL,GAMMA(1,IGR),SGD,DSGD)
+ ENDIF
+*----
+* PROCESS SCATTERING TERMS
+*----
+ CALL LCMLEN(KPMACP,'NJJS00',LENGT,ITYLCM)
+ IF(LENGT.GT.NBMIX) CALL XABORT('TRISYS: INVALID LENGTH FOR ''N'
+ 1 //'JJS00'' INFORMATION.')
+ IF(LENGT.GT.0) THEN
+ CALL LCMGET(KPMACP,'NJJS00',NJJ)
+ CALL LCMGET(KPMACP,'IJJS00',IJJ)
+ JGRMIN=IGR
+ JGRMAX=IGR
+ DO 80 IBM=1,LENGT
+ JGRMIN=MIN(JGRMIN,IJJ(IBM)-NJJ(IBM)+1)
+ JGRMAX=MAX(JGRMAX,IJJ(IBM))
+ 80 CONTINUE
+ CALL LCMGET(KPMACP,'IPOS00',IPOS)
+ CALL LCMGET(KPMACP,'SCAT00',WORK)
+ DO 100 JGR=JGRMAX,JGRMIN,-1
+ IF(JGR.EQ.IGR) GO TO 100
+ DO 90 IBM=1,LENGT
+ IF((JGR.GT.IJJ(IBM)-NJJ(IBM)).AND.(JGR.LE.IJJ(IBM))) THEN
+ SGD(IBM,1)=WORK(IPOS(IBM)+IJJ(IBM)-JGR)
+ ELSE
+ SGD(IBM,1)=0.0
+ ENDIF
+ 90 CONTINUE
+ WRITE (TEXDIG,'(1HA,2I3.3)') IGR,JGR
+ CALL TRIDIG(TEXDIG,IPTRK,IPSYS,IMPX,NBMIX,NEL,IPR,MAT,
+ 1 VOL,SGD)
+ 100 CONTINUE
+ ENDIF
+ 110 CONTINUE
+*----
+* PROCESS FISSION SPECTRUM TERMS
+*----
+ KPMACP=LCMGIL(JPMACP,1)
+ CALL LCMLEN(KPMACP,'CHI',LENGT,ITYLCM)
+ IF(LENGT.GT.0) THEN
+ IF(LENGT.NE.NBMIX*NBFIS) CALL XABORT('TRISYS: INVALID LENGTH '
+ 1 //'FOR CHI INFORMATION.')
+ DO 120 IGR=1,NGRP
+ KPMACP=LCMGIL(JPMACP,IGR)
+ CALL LCMGET(KPMACP,'CHI',CHI(1,1,IGR))
+ 120 CONTINUE
+ ELSE
+ DO 132 IBM=1,NBMIX
+ DO 131 IFISS=1,NBFIS
+ CHI(IBM,IFISS,1)=1.0
+ DO 130 IGR=2,NGRP
+ CHI(IBM,IFISS,IGR)=0.0
+ 130 CONTINUE
+ 131 CONTINUE
+ 132 CONTINUE
+ ENDIF
+*----
+* PROCESS FISSION NUSIGF TERMS
+*----
+ DO 170 IGR=1,NGRP
+* PROCESS SECONDARY GROUP IGR.
+ LFIS=.FALSE.
+ DO 141 IBM=1,NBMIX
+ DO 140 IFISS=1,NBFIS
+ LFIS=LFIS.OR.(CHI(IBM,IFISS,IGR).NE.0.0)
+ 140 CONTINUE
+ 141 CONTINUE
+ IF(LFIS) THEN
+ DO 160 JGR=1,NGRP
+ KPMACP=LCMGIL(JPMACP,JGR)
+ CALL LCMLEN(KPMACP,'NUSIGF',LENGT,ITYLCM)
+ IF(LENGT.GT.0) THEN
+ IF(LENGT.NE.NBMIX*NBFIS) CALL XABORT('TRISYS: INVALID LENG'
+ 1 //'TH FOR NUSIGF INFORMATION.')
+ CALL LCMGET(KPMACP,'NUSIGF',ZUFIS)
+ SGD(:NBMIX,1)=0.0
+ DO 151 IBM=1,NBMIX
+ DO 150 IFISS=1,NBFIS
+ SGD(IBM,1)=SGD(IBM,1)+CHI(IBM,IFISS,IGR)*ZUFIS(IBM,IFISS)
+ 150 CONTINUE
+ 151 CONTINUE
+ WRITE(TEXDIG,'(4HFISS,2I3.3)') IGR,JGR
+ CALL LCMPUT(IPSYS,TEXDIG,NBMIX,2,SGD(1,1))
+ WRITE (TEXDIG,'(1HB,2I3.3)') IGR,JGR
+ CALL TRIDIG(TEXDIG,IPTRK,IPSYS,IMPX,NBMIX,NEL,IPR,MAT,VOL,
+ 1 SGD)
+ ENDIF
+ 160 CONTINUE
+ ENDIF
+ 170 CONTINUE
+*----
+* SCRATCH STORAGE DEALLOCATION
+*----
+ DEALLOCATE(GAMMA,SGD,DSGD,WORK,CHI,ZUFIS)
+ DEALLOCATE(IJJ,NJJ,IPOS)
+ RETURN
+ END
diff --git a/Trivac/src/TRITCO.f b/Trivac/src/TRITCO.f new file mode 100755 index 0000000..87ec38d --- /dev/null +++ b/Trivac/src/TRITCO.f @@ -0,0 +1,252 @@ +*DECK TRITCO + SUBROUTINE TRITCO (NEL,LL4,ISPLH,IR,IQF,K,KK1,KK2,KK3,KK4,KK5, + 1 VOL0,MAT,MATN,DIF,DDF,SIDE,ZZ,QFR,IPR,A) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Mesh centered finite difference coefficients in hexagonal geometry +* with triangular sub meshing. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Benaboud +* +*Parameters: input +* NEL total number of finite elements. +* LL4 order of the system matrices. +* ISPLH number of triangles (equal to 6*(ISPLH-1)**2). +* IR first dimension for matrices DIF and DDF. +* IQF index in array QFR. +* K index of finite element. +* KK1 first neighbour of the triangular finite element. +* KK2 second neighbour of the triangular finite element. +* KK3 third neighbour of the triangular finite element. +* KK4 fourth neighbour of the triangular finite element. +* KK5 fifth neighbour of the triangular finite element. +* VOL0 volume of the finite element. +* MAT mixture index assigned to each hexagon. +* MATN mixture index assigned to each triangle. +* DIF directional diffusion coefficients. +* DDF variation of directional diffusion coefficients. +* SIDE side of an hexagon. +* ZZ Z-directed mesh spacings. +* QFR element-ordered boundary conditions. +* IPR type of matrix assembly: +* =0: compute the system matrices; +* =1: compute the derivative of system matrices; +* =2 or =3: compute the variation of system matrices. +* +*Parameters: output +* A mesh centered finite difference coefficients. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NEL,LL4,ISPLH,IR,IQF,K,KK1,KK2,KK3,KK4,KK5,MAT(NEL), + 1 MATN(LL4),IPR + REAL VOL0,DIF(IR,3),DDF(IR,3),SIDE,ZZ(NEL),QFR(8) + DOUBLE PRECISION A(5) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION SHARM,DHARM,VHARM +* FORMULA WIHOUT VARIATION OR DERIVATIVE. + SHARM(X1,X2,DIF1,DIF2)=2.0D0*DIF1*DIF2/(X1*DIF2+X2*DIF1) +* FORMULA WITH DERIVATIVE. + DHARM(X1,X2,DIF1,DIF2,DDF1,DDF2)=2.0D0*(X1*DIF2*DIF2*DDF1+ + 1 X2*DIF1*DIF1*DDF2)/(X1*DIF2+X2*DIF1)**2 +* FORMULA WITH VARIATION. + VHARM(X1,X2,DIF1,DIF2,DDF1,DDF2)=2.0D0*((DIF1+DDF1)*(DIF2+DDF2) + 1 /(X1*(DIF2+DDF2)+X2*(DIF1+DDF1))-DIF1*DIF2/(X1*DIF2+X2*DIF1)) +* + L=MAT(K) + DZ=ZZ(K) + DS=SIDE/(SQRT(3.0)*(ISPLH-1)) + DT=SIDE/(ISPLH-1) + IF(IPR.EQ.0) THEN +* FORMULE DIRECTE. + IF(KK1.GT.0) THEN + A(1)=SHARM(DS,DS,DIF(L,1),DIF(MATN(KK1),1))*DT*DZ + ELSE IF(KK1.EQ.-1) THEN + A(1)=SHARM(DS,DS,DIF(L,1),DS*QFR(IQF)/2.0)*DT*DZ + ELSE IF(KK1.EQ.-2) THEN + A(1)=0.0D0 + ELSE IF(KK1.EQ.-3) THEN + A(1)=2.0D0*SHARM(DS,DS,DIF(L,1),DIF(L,1))*DT*DZ + ENDIF +* + IF(KK2.GT.0) THEN + A(2)=SHARM(DS,DS,DIF(L,1),DIF(MATN(KK2),1))*DT*DZ + ELSE IF(KK2.EQ.-1) THEN + A(2)=SHARM(DS,DS,DIF(L,1),DS*QFR(IQF)/2.0)*DT*DZ + ELSE IF(KK2.EQ.-2) THEN + A(2)=0.0D0 + ELSE IF(KK2.EQ.-3) THEN + A(2)=2.0D0*SHARM(DS,DS,DIF(L,1),DIF(L,1))*DT*DZ + ENDIF +* + IF(KK3.GT.0) THEN + A(3)=SHARM(DS,DS,DIF(L,1),DIF(MATN(KK3),1))*DT*DZ + ELSE IF(KK3.EQ.-1) THEN + A(3)=SHARM(DS,DS,DIF(L,1),DS*QFR(IQF)/2.0)*DT*DZ + ELSE IF(KK3.EQ.-2) THEN + A(3)=0.0D0 + ELSE IF(KK3.EQ.-3) THEN + A(3)=2.0D0*SHARM(DS,DS,DIF(L,1),DIF(L,1))*DT*DZ + ENDIF +* + IF(KK4.GT.0) THEN + A(4)=SHARM(DZ,ZZ(KK4),DIF(L,1),DIF(MAT(KK4),1))*VOL0/DZ + ELSE IF(KK4.EQ.-1) THEN + A(4)=SHARM(DZ,DZ,DIF(L,1),DZ*QFR(7)/2.0)*VOL0/DZ + ELSE IF(KK4.EQ.-2) THEN + A(4)=0.0D0 + ELSE IF(KK4.EQ.-3) THEN + A(4)=2.0D0*SHARM(DZ,DZ,DIF(L,1),DIF(L,1))*VOL0/DZ + ENDIF +* + IF(KK5.GT.0) THEN + A(5)=SHARM(DZ,ZZ(KK5),DIF(L,1),DIF(MAT(KK5),1))*VOL0/DZ + ELSE IF(KK5.EQ.-1) THEN + A(5)=SHARM(DZ,DZ,DIF(L,1),DZ*QFR(8)/2.0)*VOL0/DZ + ELSE IF(KK5.EQ.-2) THEN + A(5)=0.0D0 + ELSE IF(KK5.EQ.-3) THEN + A(5)=2.0D0*SHARM(DZ,DZ,DIF(L,1),DIF(L,1))*VOL0/DZ + ENDIF +* + ELSE IF(IPR.EQ.1) THEN +* FORMULE DE DERIVEE. + IF(KK1.GT.0) THEN + A(1)=DHARM(DS,DS,DIF(L,1),DIF(MATN(KK1),1),DDF(L,1), + 1 DDF(MATN(KK1),1))*DZ*DT + ELSE IF(KK1.EQ.-1) THEN + A(1)=DHARM(DS,DS,DIF(L,1),DS*QFR(IQF)/2.0,DDF(L,1),0.0) + 1 *DZ*DT + ELSE IF(KK1.EQ.-2) THEN + A(1)=0.0D0 + ELSE IF(KK1.EQ.-3) THEN + A(1)=2.0D0*DDF(L,1)*DZ*DT/DS + ENDIF +* + IF(KK2.GT.0) THEN + A(2)=DHARM(DS,DS,DIF(L,1),DIF(MATN(KK2),1),DDF(L,1), + 1 DDF(MATN(KK2),1))*DZ*DT + ELSE IF(KK2.EQ.-1) THEN + A(2)=DHARM(DS,DS,DIF(L,1),DS*QFR(IQF)/2.0,DDF(L,1),0.0) + 1 *DZ*DT + ELSE IF(KK2.EQ.-2) THEN + A(2)=0.0D0 + ELSE IF(KK2.EQ.-3) THEN + A(2)=2.0D0*DDF(L,1)*DZ*DT/DS + ENDIF +* + IF(KK3.GT.0) THEN + A(3)=DHARM(DS,DS,DIF(L,1),DIF(MATN(KK3),1),DDF(L,1), + 1 DDF(MATN(KK3),1))*DZ*DT + ELSE IF(KK3.EQ.-1) THEN + A(3)=DHARM(DS,DS,DIF(L,1),DS*QFR(IQF)/2.0,DDF(L,1),0.0) + 1 *DZ*DT + ELSE IF(KK3.EQ.-2) THEN + A(3)=0.0D0 + ELSE IF(KK3.EQ.-3) THEN + A(3)=2.0D0*DDF(L,1)*DZ*DT/DS + ENDIF +* + IF(KK4.GT.0) THEN + A(4)=DHARM(DZ,ZZ(KK4),DIF(L,3),DIF(MAT(KK4),3),DDF(L,3), + 1 DDF(MAT(KK4),3))*VOL0/DZ + ELSE IF(KK4.EQ.-1) THEN + A(4)=DHARM(DZ,DZ,DIF(L,3),DZ*QFR(7)/2.0,DDF(L,3),0.0) + 1 *VOL0/DZ + ELSE IF(KK4.EQ.-2) THEN + A(4)=0.0D0 + ELSE IF(KK4.EQ.-3) THEN + A(4)=2.0D0*DDF(L,3)*VOL0/(DZ*DZ) + ENDIF +* + IF(KK5.GT.0) THEN + A(5)=DHARM(DZ,ZZ(KK5),DIF(L,3),DIF(MAT(KK5),3),DDF(L,3), + 1 DDF(MAT(KK5),3))*VOL0/DZ + ELSE IF(KK5.EQ.-1) THEN + A(5)=DHARM(DZ,DZ,DIF(L,3),DZ*QFR(8)/2.0,DDF(L,3),0.0) + 1 *VOL0/DZ + ELSE IF(KK5.EQ.-2) THEN + A(5)=0.0D0 + ELSE IF(KK5.EQ.-3) THEN + A(5)=2.0D0*DDF(L,3)*VOL0/(DZ*DZ) + ENDIF +* + ELSE IF(IPR.GE.2) THEN +* FORMULE DE VARIATION. + IF(KK1.GT.0) THEN + A(1)=VHARM(DS,DS,DIF(L,1),DIF(MATN(KK1),1),DDF(L,1), + 1 DDF(MATN(KK1),1))*DZ*DT + ELSE IF(KK1.EQ.-1) THEN + A(1)=VHARM(DS,DS,DIF(L,1),DS*QFR(IQF)/2.0,DDF(L,1),0.0) + 1 *DZ*DT + ELSE IF(KK1.EQ.-2) THEN + A(1)=0.0D0 + ELSE IF(KK1.EQ.-3) THEN + A(1)=2.0D0*DDF(L,1)*DZ*DT/DS + ENDIF +* + IF(KK2.GT.0) THEN + A(2)=VHARM(DS,DS,DIF(L,1),DIF(MATN(KK2),1),DDF(L,1), + 1 DDF(MATN(KK2),1))*DZ*DT + ELSE IF(KK2.EQ.-1) THEN + A(2)=VHARM(DS,DS,DIF(L,1),DS*QFR(IQF)/2.0,DDF(L,1),0.0) + 1 *DZ*DT + ELSE IF(KK2.EQ.-2) THEN + A(2)=0.0D0 + ELSE IF(KK2.EQ.-3) THEN + A(2)=2.0D0*DDF(L,1)*DZ*DT/DS + ENDIF +* + IF(KK3.GT.0) THEN + A(3)=VHARM(DS,DS,DIF(L,1),DIF(MATN(KK3),1),DDF(L,1), + 1 DDF(MATN(KK3),1))*DZ*DT + ELSE IF(KK3.EQ.-1) THEN + A(3)=VHARM(DS,DS,DIF(L,1),DS*QFR(IQF)/2.0,DDF(L,1),0.0) + 1 *DZ*DT + ELSE IF(KK3.EQ.-2) THEN + A(3)=0.0D0 + ELSE IF(KK3.EQ.-3) THEN + A(3)=2.0D0*DDF(L,1)*DZ*DT/DS + ENDIF +* + IF(KK4.GT.0) THEN + A(4)=VHARM(DZ,ZZ(KK4),DIF(L,3),DIF(MAT(KK4),3),DDF(L,3), + 1 DDF(MAT(KK4),3))*VOL0/DZ + ELSE IF(KK4.EQ.-1) THEN + A(4)=VHARM(DZ,DZ,DIF(L,3),DZ*QFR(7)/2.0,DDF(L,3),0.0) + 1 *VOL0/DZ + ELSE IF(KK4.EQ.-2) THEN + A(4)=0.0D0 + ELSE IF(KK4.EQ.-3) THEN + A(4)=2.0D0*DDF(L,3)*VOL0/(DZ*DZ) + ENDIF +* + IF(KK5.GT.0) THEN + A(5)=VHARM(DZ,ZZ(KK5),DIF(L,3),DIF(MAT(KK5),3),DDF(L,3), + 1 DDF(MAT(KK5),3))*VOL0/DZ + ELSE IF(KK5.EQ.-1) THEN + A(5)=VHARM(DZ,DZ,DIF(L,3),DZ*QFR(8)/2.0,DDF(L,3),0.0) + 1 *VOL0/DZ + ELSE IF(KK5.EQ.-2) THEN + A(5)=0.0D0 + ELSE IF(KK5.EQ.-3) THEN + A(5)=2.0D0*DDF(L,3)*VOL0/(DZ*DZ) + ENDIF +* + ENDIF + RETURN + END diff --git a/Trivac/src/TRITRK.f b/Trivac/src/TRITRK.f new file mode 100755 index 0000000..42cfd2e --- /dev/null +++ b/Trivac/src/TRITRK.f @@ -0,0 +1,886 @@ +*DECK TRITRK + SUBROUTINE TRITRK (MAXPTS,IPTRK,IPGEOM,IMPX,IELEM,ICOL,ICHX,ISEG, + 1 IMPV,NLF,NVD,ISPN,ISCAT,NADI) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover of the geometry and tracking for TRIVAC. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* MAXPTS allocated storage for arrays of dimension NEL. +* IPTRK L_TRACK pointer to the TRIVAC tracking information. +* IPGEOM L_GEOM pointer to the geometry. +* IMPX print flag. +* IELEM degree of the Lagrangian finite elements: +* =1: linear finite elements or finite differences; +* =2: parabolic finite elements; +* =3: cubic finite elements; +* =4: quartic finite elements. +* ICOL type of quadrature used to integrate the mass matrix: +* =1: analytical integration; +* =2: Gauss-Lobatto quadrature (collocation method); +* =3: Gauss-Legendre quadrature (superconvergent) +* IELEM=1 and ICOL=2 are finite difference approximations. +* ICHX type of discretization method: +* =1: variational collocation method (primal finite elements +* with Gauss-Lobatto quadrature); +* =2: dual finite element approximations; +* =3: nodal collocation method with full tensorial products +* (dual finite elements with Gauss-Lobatto quadrature). +* ISEG number of elements in a vector register. Equal to zero for +* operations in scalar mode. +* IMPV print parameter for supervectorial operations. +* NLF number of Legendre orders for the flux. Equal to zero for +* diffusion theory. +* NVD type of void boundary condition if NLF>0 and ICOL=3. +* ISPN type of transport solution: +* =0: complete PN method; +* =1: simplified PN method. +* ISCAT source anisotropy: +* =1: isotropic sources in laboratory system; +* =2: linearly anisotropic sources in laboratory system. +* NADI number of ADI iterations at the inner iterative level. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPTRK,IPGEOM + INTEGER MAXPTS,IMPX,IELEM,ICOL,ICHX,ISEG,IMPV,NLF,NVD,ISPN,ISCAT, + 1 NADI +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + LOGICAL ILK,CYLIND,CHEX + CHARACTER HSMG*131 + INTEGER ISTATE(NSTATE),IGP(NSTATE),NCODE(6),ICODE(6) + REAL ZCODE(6) + INTEGER, DIMENSION(:), ALLOCATABLE :: MAT,IDL,IPERT,KN,IQFR,IDP, + 1 IMX,ISPLX,ISPLY,ISPLZ,MUW,MUX,MUY,MUZ,IPW,IPX,IPY,IPZ,ISET + REAL, DIMENSION(:), ALLOCATABLE :: VOL,XXX,YYY,ZZZ,XX,YY,ZZ,DD, + 1 QFR,FRZ,RR0,XR0,ANG + REAL, DIMENSION(:,:), ALLOCATABLE :: V,H + DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: CTRAN + INTEGER, DIMENSION(:), ALLOCATABLE :: NBLW,LBLW,MUVW,IPVW,NBLX, + 1 LBLX,MUVX,IPVX,NBLY,LBLY,MUVY,IPVY,NBLZ,LBLZ,MUVZ,IPVZ + REAL, DIMENSION(:), ALLOCATABLE :: BBW,BBX,BBY,BBZ + INTEGER, DIMENSION(:), ALLOCATABLE :: IPBBW,IPBBX,IPBBY,IPBBZ +* +******************* TRIVAC GEOMETRICAL STRUCTURE. ********************** +* * +* ITYPE : =2 : CARTESIAN 1-D GEOMETRY; * +* =3 : TUBE 1-D GEOMETRY; * +* =5 : CARTESIAN 2-D GEOMETRY; * +* =6 : TUBE 2-D GEOMETRY; * +* =7 : CARTESIAN 3-D GEOMETRY; * +* =8 : HEXAGONAL 2-D GEOMETRY; * +* =9 : HEXAGONAL 3-D GEOMETRY. * +* IHEX : TYPE OF HEXAGONAL SYMMETRY. * +* IDIAG : =0 NO DIAGONAL SYMMETRY; =1 DIAGONAL SYMMETRY. * +* IELEM : DEGREE OF THE LAGRANGIAN FINITE ELEMENTS. * +* =1: LINEAR FINITE ELEMENTS OR FINITE DIFFERENCES; * +* =2: PARABOLIC FINITE ELEMENTS; * +* =3: CUBIC FINITE ELEMENTS; * +* =4: QUARTIC FINITE ELEMENTS. * +* ICOL : TYPE OF QUADRATURE USED TO INTEGRATE THE MASS MATRIX.* +* =1: ANALYTICAL INTEGRATION; * +* =2: GAUSS-LOBATTO QUADRATURE (COLLOCATION METHOD); * +* =3: GAUSS-LEGENDRE QUADRATURE (SUPERCONVERGENT). * +* IELEM=1 AND ICOL=2 ARE FINITE DIFFERENCE APPROX. * +* ICHX : TYPE OF DISCRETIZATION METHOD. * +* =1: VARIATIONAL COLLOCATION METHOD (PRIMAL FINITE * +* ELEMENTS WITH GAUSS-LOBATTO QUADRATURE); * +* =2: DUAL FINITE ELEMENT APPROXIMATIONS; * +* =3: NODAL COLLOCATION METHOD WITH FULL TENSORIAL * +* PRODUCTS (DUAL FINITE ELEMENTS WITH GAUSS- * +* LOBATTO QUADRATURE). * +* SIDE : SIDE OF THE HEXAGONS. * +* LL4 : ORDER OF THE MATRICES PER GROUP IN TRIVAC. * +* NCODE : TYPES OF BOUNDARY CONDITIONS. DIMENSION=6 * +* ZCODE : ALBEDOS. DIMENSION=6 * +* LX,LY,LZ : NUMBER OF ELEMENTS ALONG THE X, Y AND Z AXIS. * +* XX : X-DIRECTED MESH SPACINGS. DIMENSION=LX*LY*LZ * +* YY : Y-DIRECTED MESH SPACINGS. DIMENSION=LX*LY*LZ * +* ZZ : Z-DIRECTED MESH SPACINGS. DIMENSION=LX*LY*LZ * +* DD : USED WITH CYLINDRICAL GEOMETRIES. DIMENSION=LX*LY*LZ * +* KN : ELEMENT-ORDERED UNKNOWN LIST. DIMENSION LX*LY*LZ*ICO * +* WHERE ICO IS THE NUMBER OF UNKNOWN PER ELEMENT. * +* QFR : ELEMENT-ORDERED BOUNDARY CONDITIONS. * +* DIMENSION 6*LX*LY*LZ OR 8*LX*LZ * +* IQFR : ELEMENT-ORDERED PHYSICAL ALBEDO INDICES. * +* DIMENSION 6*LX*LY*LZ OR 8*LX*LZ * +* MUW : INDICES USED WITH W-DIRECTED COMPRESSED DIAGONAL * +* STORAGE MODE MATRICES. DIMENSION LL4W * +* MUX : INDICES USED WITH X-DIRECTED COMPRESSED DIAGONAL * +* STORAGE MODE MATRICES. DIMENSION LL4X * +* MUY : INDICES USED WITH Y-DIRECTED COMPRESSED DIAGONAL * +* STORAGE MODE MATRICES. DIMENSION LL4Y * +* MUZ : INDICES USED WITH Z-DIRECTED COMPRESSED DIAGONAL * +* STORAGE MODE MATRICES. DIMENSION LL4Z * +* IPW : W-DIRECTED PERMUTATION MATRIX. DIMENSION LL4 * +* IPX : X-DIRECTED PERMUTATION MATRIX. DIMENSION LL4 * +* IPY : Y-DIRECTED PERMUTATION MATRIX. DIMENSION LL4 * +* IPZ : Z-DIRECTED PERMUTATION MATRIX. DIMENSION LL4 * +* * +* SUPERVECTORIAL OPERATION INFORMATION: * +* ISEG : NUMBER OF ELEMENTS IN A VECTOR REGISTER. EQUAL TO * +* ZERO FOR OPERATIONS IN SCALAR MODE. * +* IMPV : PRINT PARAMETER FOR SUPERVECTORIAL OPERATIONS. * +* LTSW : MAXIMUM BANDWIDTH. =2 FOR TRIDIAGONAL SYSTEMS. * +* LONW : NUMBER OF GROUPS OF LINEAR SYSTEMS FOR W-MATRICES. * +* LONX : NUMBER OF GROUPS OF LINEAR SYSTEMS FOR X-MATRICES. * +* LONY : NUMBER OF GROUPS OF LINEAR SYSTEMS FOR Y-MATRICES. * +* LONZ : NUMBER OF GROUPS OF LINEAR SYSTEMS FOR Z-MATRICES. * +* NBLW : NUMBER OF LINEAR SYSTEMS PER W-GROUP. DIMENSION LONW * +* NBLX : NUMBER OF LINEAR SYSTEMS PER X-GROUP. DIMENSION LONX * +* NBLY : NUMBER OF LINEAR SYSTEMS PER Y-GROUP. DIMENSION LONY * +* NBLZ : NUMBER OF LINEAR SYSTEMS PER Z-GROUP. DIMENSION LONZ * +* LBLW : NUMBER OF UNKNOWNS PER W-GROUP. DIMENSION LONW * +* LBLX : NUMBER OF UNKNOWNS PER X-GROUP. DIMENSION LONX * +* LBLY : NUMBER OF UNKNOWNS PER Y-GROUP. DIMENSION LONY * +* LBLZ : NUMBER OF UNKNOWNS PER Z-GROUP. DIMENSION LONZ * +* MUVW : INDICES USED WITH W-DIRECTED COMPRESSED DIAGONAL * +* STORAGE MODE MATRICES IN VECTOR MODE. DIMENSION LL4W * +* MUVX : INDICES USED WITH X-DIRECTED COMPRESSED DIAGONAL * +* STORAGE MODE MATRICES IN VECTOR MODE. DIMENSION LL4X * +* MUVY : INDICES USED WITH Y-DIRECTED COMPRESSED DIAGONAL * +* STORAGE MODE MATRICES IN VECTOR MODE. DIMENSION LL4Y * +* MUVZ : INDICES USED WITH Z-DIRECTED COMPRESSED DIAGONAL * +* STORAGE MODE MATRICES IN VECTOR MODE. DIMENSION LL4Z * +* IPVW : W-DIRECTED VECTOR PERMUTATION MATRIX. DIMENSION LL4 * +* IPVX : X-DIRECTED VECTOR PERMUTATION MATRIX. DIMENSION LL4 * +* IPVY : Y-DIRECTED VECTOR PERMUTATION MATRIX. DIMENSION LL4 * +* IPVZ : Z-DIRECTED VECTOR PERMUTATION MATRIX. DIMENSION LL4 * +* * +* INFORMATION RELATED TO CYLINDRICAL CORRECTIONS IN CARTESIAN GEOMETRY * +* NR0 : NUMBER OF RADII. * +* RR0 : RADII. DIMENSION NR0 * +* XR0 : COORDINATES ON PRINCIPAL AXIS. DIMENSION NR0 * +* ANG : ANGLES FOR APPLYING CIRCULAR CORRECTION. * +* DIMENSION NR0 * +* * +************************************************************************ +* +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(MAT(MAXPTS),IDL(MAXPTS),VOL(MAXPTS)) +* + CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE) + ITYPE=ISTATE(1) +* + IF(IMPX.GE.1) WRITE (6,'(/35H TRITRK: DEGREE OF FINITE ELEMENT I, + 1 6HELEM =,I3/9X,25HTYPE OF QUADRATURE ICOL =,I3/9X,10HTYPE OF DI, + 2 19HSCRETIZATION ICHX =,I3/)') IELEM,ICOL,ICHX + IF((IMPX.GE.1).AND.(ISEG.GT.0)) WRITE (6,'(18H TRITRK: SUPERVECT, + 1 27HORIZATION OPTION ON. ISEG =,I4,8H IMPV =,I3/)') ISEG,IMPV + IF(ISTATE(9).EQ.0) THEN + IF((ITYPE.NE.1).AND.(ITYPE.NE.2).AND.(ITYPE.NE.3).AND. + 1 (ITYPE.NE.5).AND.(ITYPE.NE.6).AND.(ITYPE.NE.7).AND. + 2 (ITYPE.NE.8).AND.(ITYPE.NE.9)) THEN + CALL XABORT('TRITRK: DISCRETIZATION NOT AVAILABLE.') + ENDIF + ALLOCATE(XXX(MAXPTS+1),YYY(MAXPTS+1),ZZZ(MAXPTS+1)) +* + ALLOCATE(ISPLX(MAXPTS),ISPLY(MAXPTS),ISPLZ(MAXPTS)) + CALL READ3D(MAXPTS,MAXPTS,MAXPTS,MAXPTS,IPGEOM,IHEX,IR,ILK, + 1 SIDE,XXX,YYY,ZZZ,IMPX,LX,LY,LZ,MAT,NEL,NCODE,ICODE,ZCODE, + 2 ISPLX,ISPLY,ISPLZ,ISPLH,ISPLL) + DEALLOCATE(ISPLX,ISPLY,ISPLZ) + IF((ITYPE.GE.8).AND.(ICHX.EQ.2)) THEN + IF(ISPLL.EQ.0) THEN + CALL XABORT('TRITRK: SPLITL KEYWORD MISSING IN GEOMETRY.') + ENDIF + ISPLH=ISPLL + ELSE IF(ITYPE.GE.8) THEN + ISPLH=ISPLH+1 + ENDIF + ELSE + CALL XABORT('TRITRK: DISCRETIZATION NOT AVAILABLE.') + ENDIF +*---- +* UNFOLD HEXAGONAL GEOMETRY CASES. +*---- + CHEX=(ITYPE.EQ.8).OR.(ITYPE.EQ.9) + IF(CHEX.AND.(IHEX.NE.9)) THEN + ALLOCATE(IDP(MAXPTS),IMX(NEL)) + DO 30 I=1,NEL + IMX(I)=MAT(I) + 30 CONTINUE + LXOLD=LX + CALL BIVALL(MAXPTS,IHEX,LXOLD,LX,IDP) + DO 41 KZ=1,LZ + DO 40 KX=1,LX + KEL=IDP(KX)+(KZ-1)*LXOLD + MAT(KX+(KZ-1)*LX)=IMX(KEL) + 40 CONTINUE + 41 CONTINUE + DEALLOCATE(IMX,IDP) + NEL=LX*LZ + ENDIF +*---- +* PROCESS INFORMATION RELATED TO CYLINDRICAL CORRECTION IN CARTESIAN +* GEOMETRIES. +*---- + CALL LCMLEN(IPGEOM,'RR0',NR0,ITYLCM) + IF(NR0.GT.0) THEN + IF((ITYPE.NE.5).AND.(ITYPE.NE.7)) CALL XABORT('TRITRK: CYLIND' + 1 //'RICAL CORRECTIONS ARE LIMITED TO CARTESIAN GEOMETRIES.') + IF(IMPX.GT.0) WRITE(6,'(/33H TRITRK: PERFORM A CYLINDRICAL CO, + 2 35HRRECTION ON THE CARTESIAN BOUNDARY.)') + ALLOCATE(RR0(NR0),XR0(NR0),ANG(NR0)) + CALL LCMGET(IPGEOM,'RR0',RR0) + CALL LCMGET(IPGEOM,'XR0',XR0) + CALL LCMGET(IPGEOM,'ANG',ANG) + CALL LCMPUT(IPTRK,'RR0',NR0,2,RR0) + CALL LCMPUT(IPTRK,'XR0',NR0,2,XR0) + CALL LCMPUT(IPTRK,'ANG',NR0,2,ANG) + DEALLOCATE(ANG,XR0,RR0) + ENDIF +* + IF(LX*LY*LZ.GT.MAXPTS) THEN + WRITE (HSMG,'(39HTRITRK: MAXPTS SHOULD BE INCREASED FROM,I8, + 1 3H TO,I8)') MAXPTS,LX*LY*LZ + CALL XABORT(HSMG) + ENDIF +*---- +* 1-D AND 2-D CASES. +*---- + IDIM=1 + IF((ITYPE.EQ.5).OR.(ITYPE.EQ.6).OR.(ITYPE.EQ.8)) IDIM=2 + IF((ITYPE.EQ.7).OR.(ITYPE.EQ.9)) IDIM=3 + IF((NCODE(3).EQ.0).AND.(NCODE(4).EQ.0).AND.(.NOT.CHEX)) THEN + IF((IDIM.NE.1).OR.(LY.NE.1)) CALL XABORT('TRITRK: INVALID 1D ' + 1 //'GEOMETRY.') + NCODE(3)=2 + NCODE(4)=5 + ZCODE(3)=1.0 + ZCODE(4)=1.0 + YYY(1)=0.0 + YYY(2)=2.0 + ENDIF + IF((NCODE(5).EQ.0).AND.(NCODE(6).EQ.0)) THEN + IF((IDIM.EQ.3).OR.(LZ.NE.1)) CALL XABORT('TRITRK: INVALID 1D ' + 1 //'OR 2D GEOMETRY.') + NCODE(5)=2 + NCODE(6)=5 + ZCODE(5)=1.0 + ZCODE(6)=1.0 + ZZZ(1)=0.0 + ZZZ(2)=2.0 + ENDIF +*---- +* 2-D CYLINDRICAL CASES. +*---- + CYLIND=(ITYPE.EQ.3).OR.(ITYPE.EQ.6) + IF(ITYPE.EQ.6) THEN + LY=LZ + DO 45 I=1,LZ+1 + YYY(I)=ZZZ(I) + 45 CONTINUE + NCODE(3)=NCODE(5) + NCODE(4)=NCODE(6) + ICODE(3)=ICODE(5) + ICODE(4)=ICODE(6) + ZCODE(3)=ZCODE(5) + ZCODE(4)=ZCODE(6) + NCODE(5)=0 + NCODE(6)=0 + ZCODE(5)=0.0 + ZCODE(6)=0.0 + ENDIF +*---- +* UNFOLD THE DOMAIN IN DIAGONAL SYMMETRY CASES. +*---- + IDIAG=0 + IF((NCODE(2).EQ.3).AND.(NCODE(3).EQ.3)) THEN + IDIAG=1 + NCODE(3)=NCODE(1) + NCODE(2)=NCODE(4) + ICODE(3)=ICODE(1) + ICODE(2)=ICODE(4) + ZCODE(3)=ZCODE(1) + ZCODE(2)=ZCODE(4) + K=NEL + DO 82 IZ=LZ,1,-1 + IOFF=(IZ-1)*LX*LY + DO 81 IY=LY,1,-1 + DO 70 IX=LX,IY+1,-1 + MAT(IOFF+(IY-1)*LX+IX)=MAT(IOFF+(IX-1)*LY+IY) + 70 CONTINUE + DO 80 IX=IY,1,-1 + MAT(IOFF+(IY-1)*LX+IX)=MAT(K) + K=K-1 + 80 CONTINUE + 81 CONTINUE + 82 CONTINUE + NEL=LX*LY*LZ + IF(K.NE.0) THEN + CALL XABORT('TRITRK: UNABLE TO UNFOLD THE DOMAIN(1).') + ENDIF + ELSE IF((NCODE(1).EQ.3).AND.(NCODE(4).EQ.3)) THEN + IDIAG=1 + NCODE(1)=NCODE(3) + NCODE(4)=NCODE(2) + ICODE(1)=ICODE(3) + ICODE(4)=ICODE(2) + ZCODE(1)=ZCODE(3) + ZCODE(4)=ZCODE(2) + K=NEL + DO 92 IZ=LZ,1,-1 + IOFF=(IZ-1)*LX*LY + DO 91 IY=LY,1,-1 + DO 90 IX=LX,IY,-1 + MAT(IOFF+(IY-1)*LX+IX)=MAT(K) + K=K-1 + 90 CONTINUE + 91 CONTINUE + 92 CONTINUE + DO 102 IZ=1,LZ + IOFF=(IZ-1)*LX*LY + DO 101 IY=1,LY + DO 100 IX=1,IY-1 + MAT(IOFF+(IY-1)*LX+IX)=MAT(IOFF+(IX-1)*LY+IY) + 100 CONTINUE + 101 CONTINUE + 102 CONTINUE + NEL=LX*LY*LZ + IF(K.NE.0) THEN + CALL XABORT('TRITRK: UNABLE TO UNFOLD THE DOMAIN(2).') + ENDIF + ENDIF + IF(IMPX.GT.5) THEN + WRITE(6,600) 'NCODE',(NCODE(I),I=1,6) + WRITE(6,600) 'MAT',(MAT(I),I=1,LX*LY*LZ) + ENDIF +* + CALL KDRCPU(TK1) + MAXQF=6*NEL + IF(CHEX) MAXQF=8*NEL + IF((ICHX.EQ.1).AND.(.NOT.CHEX)) THEN + MAXKN=NEL*(IELEM+1)**3 + ELSE IF((ICHX.EQ.2).AND.(.NOT.CHEX)) THEN + MAXKN=NEL*(1+6*IELEM**2) + ELSE IF((ICHX.EQ.3).AND.(.NOT.CHEX)) THEN + MAXKN=6*NEL + ELSE IF((ICHX.EQ.1).AND.CHEX) THEN + IF(ISPLH.EQ.1) THEN + MAXKN=12*NEL + ELSE + MAXKN=2*(1+ISPLH*(ISPLH-1)*3)*NEL + ENDIF + ELSE IF((ICHX.EQ.2).AND.CHEX) THEN + MAXKN=(NEL*ISPLH**2)*(3+6*IELEM*IELEM*(IELEM+2)) + MAXQF=(NEL*ISPLH**2)*8 + ELSE IF((ICHX.EQ.3).AND.CHEX) THEN + IF(ISPLH.EQ.1) THEN + MAXKN=8*NEL + ELSE + MAXKN=(18*(ISPLH-1)**2+8)*NEL + ENDIF + ELSE + CALL XABORT('TRITRK: INVALID TYPE OF DISCRETIZATION.') + ENDIF + IF(CYLIND) THEN + MAXDD=NEL + ELSE + MAXDD=1 + ENDIF + IF((ICHX.NE.2).AND.CHEX.AND.(IELEM.NE.1)) CALL XABORT('TRITRK: T' + 1 //'HIS HEXAGONAL DISCRETIZATIONS IS LIMITED TO LINEAR ORDER.') + IF(CHEX.AND.(NCODE(1).EQ.5)) CALL XABORT('TRITRK: SYME BOUNDARY ' + 1 //'CONDITION IS NOT AVAILABLE AROUND THE HEXAGONAL PLANE.') + ALLOCATE(XX(NEL),YY(NEL),ZZ(NEL),DD(MAXDD),KN(MAXKN),QFR(MAXQF), + 1 IQFR(MAXQF)) + KN(:MAXKN)=0 + QFR(:MAXQF)=0.0 + IQFR(:MAXQF)=0 + LL4=0 + IF((ICHX.EQ.1).AND.(.NOT.CHEX)) THEN + CALL TRIPKN(IELEM,LX,LY,LZ,LL4,CYLIND,XXX,YYY,ZZZ,XX,YY,ZZ,DD, + 1 KN,QFR,IQFR,VOL,MAT,NCODE,ICODE,ZCODE,IMPX) + IF((IMPX.GT.0).AND.(IELEM.EQ.1)) THEN + WRITE (6,'(/40H TRITRK: MESH CORNER FINITE DIFFERENCES.)') + ENDIF + LL4W=0 + LL4X=LL4 + LL4Y=LL4 + LL4Z=LL4 + ELSE IF((ICHX.EQ.2).AND.(.NOT.CHEX)) THEN + CALL TRIDKN(IMPX,LX,LY,LZ,CYLIND,IELEM,LL4,LL4F,LL4X,LL4Y, + 1 LL4Z,NCODE,ICODE,ZCODE,MAT,VOL,XXX,YYY,ZZZ,XX,YY,ZZ,DD,KN, + 2 QFR,IQFR,IDL) + MAXIP=LX*LY*LZ + NUN=LL4 + ELSE IF((ICHX.EQ.3).AND.(.NOT.CHEX)) THEN + MAXIP=LX*LY*LZ + CALL TRIDFC(IMPX,LX,LY,LZ,CYLIND,NCODE,ICODE,ZCODE,MAT,XXX, + 1 YYY,ZZZ,LL0,VOL,XX,YY,ZZ,DD,KN,QFR,IQFR) + IF(IELEM.EQ.1) THEN + LL4=LL0 + IF(IMPX.GT.0) WRITE (6,'(/29H TRITRK: MESH CENTERED FINITE, + 1 13H DIFFERENCES.)') + ELSE IF((IELEM.GT.1).AND.(ICHX.EQ.3)) THEN + LL4=LL0*IELEM**IDIM + IF(IMPX.GT.0) WRITE (6,'(/29H TRITRK: NODAL COLLOCATION ME, + 1 13HTHOD OF ORDER,I3,1H.)') IELEM + ENDIF +* COMPUTE INDICES IDL. + IF(ICHX.EQ.3) THEN +* NODAL COLLOCATION METHOD. + NUN=0 + DO 110 K=1,NEL + IDL(K)=0 + IF(MAT(K).EQ.0) GO TO 110 + NUN=NUN+1 + IDL(K)=1+IELEM*(NUN-1) + 110 CONTINUE + NUN=LL4 + ENDIF + LL4W=0 + LL4X=LL4 + LL4Y=LL4 + LL4Z=LL4 + ELSE IF((ICHX.EQ.1).AND.CHEX) THEN + MAXIP=1 + IF(IELEM.NE.1) CALL XABORT('TRITRK: INVALID DISCRETIZATION.') + CALL TRIPRH(ISPLH,IPTRK,LX,LZ,LL4,SIDE,ZZZ,ZZ,KN,QFR,IQFR,VOL, + 1 MAT,NCODE,ICODE,ZCODE,IMPX) + IF(IMPX.GT.0) WRITE (6,'(/32H TRITRK: MESH CORNER FINITE DIFF, + 1 39HERENCES FOR HEXAGONAL GEOMETRY. ISPLH =,I3,1H.)') ISPLH + LL4W=LL4 + LL4X=LL4 + LL4Y=LL4 + LL4Z=LL4 + ELSE IF((ICHX.EQ.2).AND.CHEX) THEN + NEL=LX*LZ + LXH=LX/(3*ISPLH**2) + NBLOS=LXH*LZ*ISPLH**2 + NBC=INT((SQRT(REAL((4*LXH-1)/3))+1.)/2.) + MAXIP=3*(2*LXH*ISPLH*IELEM+2*NBC-1)*ISPLH*LZ*IELEM**2 + 1 +3*LXH*(LZ+1)*(ISPLH**2)*IELEM**2 + ALLOCATE(IPERT(NBLOS),FRZ(NBLOS)) + CALL TRISFH(IMPX,MAXKN,MAXIP,NBLOS,ISPLH,IELEM,LXH,LZ,MAT,SIDE, + 1 ZZZ,NCODE,ICODE,ZCODE,LL4,LL4F,LL4W,LL4X,LL4Y,LL4Z,VOL,IDL, + 2 IPERT,ZZ,FRZ,KN,QFR,IQFR) + CALL LCMPUT(IPTRK,'IPERT',NBLOS,1,IPERT) + CALL LCMPUT(IPTRK,'FRZ',NBLOS,2,FRZ) + DEALLOCATE(FRZ,IPERT) + NUN=LL4 + IF(IMPX.GT.0) WRITE (6,'(/32H TRITRK: THOMAS-RAVIART-SCHNEIDE, + 1 49HR FINITE ELEMENTS FOR HEXAGONAL GEOMETRY. ISPLH =,I3,1H.)') + 2 ISPLH + ELSE IF((ICHX.EQ.3).AND.CHEX) THEN + MAXIP=LX*LZ + IF(IELEM.NE.1) CALL XABORT('TRITRK: INVALID DISCRETIZATION.') + CALL TRIDFH(ISPLH,IPTRK,IDIM,LX,LZ,LL4,NUN,SIDE,ZZZ,ZZ,KN,QFR, + 1 IQFR,VOL,MAT,IDL,NCODE,ICODE,ZCODE,IMPX) + IF(IMPX.GT.0) WRITE (6,'(/32H TRITRK: MESH CENTERED FINITE DI, + 1 41HFFERENCES FOR HEXAGONAL GEOMETRY. ISPLH =,I3,1H.)') ISPLH + LL4W=LL4 + LL4X=LL4 + LL4Y=LL4 + LL4Z=LL4 + ENDIF +*---- +* APPEND THE PN FLUXES AT THE END OF UNKNOWN VECTOR. +*---- + IF(NLF.GE.2) THEN + IF((ITYPE.EQ.2).OR.((ITYPE.EQ.5).AND.(ISPN.EQ.1)).OR. + 1 ((ITYPE.EQ.7).AND.(ISPN.EQ.1))) THEN + NUN=LL4+LL4*(NLF-2)/2 + ELSE IF((ITYPE.EQ.8).AND.(ISPN.EQ.1)) THEN + NUN=NUN+NUN*(NLF-2)/2 + ELSE IF((ITYPE.EQ.9).AND.(ISPN.EQ.1)) THEN + NUN=NUN+NUN*(NLF-2)/2 + ELSE + CALL XABORT('TRITRK: GEOMETRY NOT SUPPORTED WITH PN.') + ENDIF + ENDIF +*---- +* COMPUTE INDICES IDL FOR PRIMAL FINITE ELEMENTS. +*---- + IF(ICHX.EQ.1) THEN + NUN=LL4 + DO 130 K=1,NEL + IF(MAT(K).EQ.0) THEN + IDL(K)=0 + ELSE + NUN=NUN+1 + IDL(K)=NUN + ENDIF + 130 CONTINUE + ENDIF +* + IF(IMPX.GT.0) WRITE (6,'(/34H TRITRK: ORDER OF LINEAR SYSTEMS =, + 1 I8/9X,37HNUMBER OF UNKNOWNS PER ENERGY GROUP =,I8)') LL4,NUN + DEALLOCATE(ZZZ,YYY,XXX) + CALL KDRCPU(TK2) + IF(IMPX.GE.2) WRITE(6,'(/37H TRITRK: CPU TIME FOR FINITE ELEMENT , + 1 11HNUMBERING =,F7.2,2H S)') TK2-TK1 +*---- +* COMPUTE INDICES MUW, MUX, MUY, MUZ, IPW, IPX, IPY AND IPZ. +*---- + CALL KDRCPU(TK1) + IF(CHEX) ALLOCATE(MUW(LL4)) + ALLOCATE(MUX(LL4),MUY(LL4),MUZ(LL4)) + IF(CHEX) ALLOCATE(IPW(LL4)) + IF(ICHX.NE.2) THEN + ALLOCATE(IPX(LL4),IPY(LL4),IPZ(LL4)) + DO 140 I=1,LL4 + IPX(I)=I + 140 CONTINUE + ENDIF +* + IF((ICHX.EQ.1).AND.(.NOT.CHEX)) THEN + CALL BIVCOL(IPTRK,IMPX,IELEM,2) + CALL TRICHP(IELEM,LX,LY,LZ,LL4,MAT,KN,MUX,MUY,MUZ,IPY,IPZ,IMPX) + ELSE IF((ICHX.EQ.2).AND.(.NOT.CHEX)) THEN + LL4W=0 + CALL BIVCOL(IPTRK,IMPX,IELEM,ICOL) + CALL LCMSIX(IPTRK,'BIVCOL',1) + ALLOCATE(V((IELEM+1),IELEM)) + CALL LCMGET(IPTRK,'V',V) + CALL LCMSIX(IPTRK,' ',2) + ALLOCATE(IPBBX(2*IELEM*LL4X),IPBBY(2*IELEM*LL4Y), + 1 IPBBZ(2*IELEM*LL4Z)) + ALLOCATE(BBX(2*IELEM*LL4X),BBY(2*IELEM*LL4Y),BBZ(2*IELEM*LL4Z)) + CALL TRICHD(IMPX,LX,LY,LZ,CYLIND,IELEM,LL4,LL4F,LL4X,LL4Y,LL4Z, + 1 MAT,VOL,XX,YY,ZZ,DD,KN,V,MUX,MUY,MUZ,IPBBX,IPBBY,IPBBZ,BBX,BBY, + 2 BBZ) + IF(LL4X.GT.0) THEN + CALL LCMPUT(IPTRK,'IPBBX',2*IELEM*LL4X,1,IPBBX) + CALL LCMPUT(IPTRK,'XB',2*IELEM*LL4X,2,BBX) + ENDIF + IF(LL4Y.GT.0) THEN + CALL LCMPUT(IPTRK,'IPBBY',2*IELEM*LL4Y,1,IPBBY) + CALL LCMPUT(IPTRK,'YB',2*IELEM*LL4Y,2,BBY) + ENDIF + IF(LL4Z.GT.0) THEN + CALL LCMPUT(IPTRK,'IPBBZ',2*IELEM*LL4Z,1,IPBBZ) + CALL LCMPUT(IPTRK,'ZB',2*IELEM*LL4Z,2,BBZ) + ENDIF + DEALLOCATE(BBZ,BBY,BBX,IPBBZ,IPBBY,IPBBX) + DEALLOCATE(V) + ELSE IF((ICHX.EQ.3).AND.(.NOT.CHEX)) THEN + CALL TRICH1(IELEM,IDIM,LX,LY,LZ,LL4,MAT,KN,MUX,MUY,MUZ,IPY, + 1 IPZ,IMPX) + ELSE IF((ICHX.EQ.1).AND.CHEX) THEN + CALL BIVCOL(IPTRK,IMPX,IELEM,2) + CALL TRICH3(ISPLH,IPTRK,LX,LZ,LL4,MAT,KN,MUW,MUX,MUY,MUZ,IPW, + 1 IPX,IPY,IPZ,IMPX) + ELSE IF((ICHX.EQ.2).AND.CHEX) THEN + LXH=LX/(3*ISPLH**2) + NBLOS=LXH*LZ*ISPLH**2 + ALLOCATE(IPERT(NBLOS),FRZ(NBLOS)) + CALL LCMGET(IPTRK,'IPERT',IPERT) + CALL LCMGET(IPTRK,'FRZ',FRZ) + CALL BIVCOL(IPTRK,IMPX,IELEM,ICOL) + CALL LCMSIX(IPTRK,'BIVCOL',1) + ALLOCATE(V((IELEM+1),IELEM),H((IELEM+1),IELEM)) + CALL LCMGET(IPTRK,'V',V) + CALL LCMGET(IPTRK,'H',H) + CALL LCMSIX(IPTRK,' ',2) + ALLOCATE(IPBBW(2*IELEM*LL4W),IPBBX(2*IELEM*LL4X), + 1 IPBBY(2*IELEM*LL4Y),IPBBZ(2*IELEM*LL4Z)) + ALLOCATE(BBW(2*IELEM*LL4W),BBX(2*IELEM*LL4X), + 1 BBY(2*IELEM*LL4Y),BBZ(2*IELEM*LL4Z)) + ALLOCATE(CTRAN(((IELEM+1)*IELEM)**2)) + CALL TRICHH(IMPX,MAXKN,NBLOS,LXH,LZ,IELEM,ISPLH,LL4,LL4F,LL4W, + 1 LL4X,LL4Y,LL4Z,SIDE,ZZ,FRZ,IPERT,KN,V,H,MUW,MUX,MUY,MUZ,IPBBW, + 2 IPBBX,IPBBY,IPBBZ,BBW,BBX,BBY,BBZ,CTRAN) + CALL LCMPUT(IPTRK,'CTRAN',((IELEM+1)*IELEM)**2,4,CTRAN) + CALL LCMPUT(IPTRK,'IPBBW',2*IELEM*LL4W,1,IPBBW) + CALL LCMPUT(IPTRK,'WB',2*IELEM*LL4W,2,BBW) + CALL LCMPUT(IPTRK,'IPBBX',2*IELEM*LL4X,1,IPBBX) + CALL LCMPUT(IPTRK,'XB',2*IELEM*LL4X,2,BBX) + CALL LCMPUT(IPTRK,'IPBBY',2*IELEM*LL4Y,1,IPBBY) + CALL LCMPUT(IPTRK,'YB',2*IELEM*LL4Y,2,BBY) + IF(LL4Z.GT.0) THEN + CALL LCMPUT(IPTRK,'IPBBZ',2*IELEM*LL4Z,1,IPBBZ) + CALL LCMPUT(IPTRK,'ZB',2*IELEM*LL4Z,2,BBZ) + ENDIF + DEALLOCATE(BBZ,BBY,BBX,BBW,IPBBZ,IPBBY,IPBBX,IPBBW) + DEALLOCATE(H,V,CTRAN,FRZ,IPERT) + ELSE IF((ICHX.EQ.3).AND.CHEX) THEN + CALL TRICH4(ISPLH,IPTRK,IDIM,LX,LZ,LL4,MAT,KN,MUW,MUX,MUY,MUZ, + 1 IPW,IPX,IPY,IPZ,IMPX) + ENDIF + CALL KDRCPU(TK2) + IF(IMPX.GE.2) WRITE(6,'(/36H TRITRK: CPU TIME FOR ADI SPLITTING , + 1 11HNUMBERING =,F7.2,2H S)') TK2-TK1 + IF(IMPX.GT.5) THEN + I1=1 + DO 150 I=1,(NEL-1)/8+1 + I2=I1+7 + IF(I2.GT.NEL) I2=NEL + WRITE (6,620) (J,J=I1,I2) + WRITE (6,630) (MAT(J),J=I1,I2) + WRITE (6,640) (IDL(J),J=I1,I2) + WRITE (6,650) (VOL(J),J=I1,I2) + I1=I1+8 + 150 CONTINUE + ENDIF +*---- +* SUPERVECTORIZATION CONTROL. +*---- + LTSW=0 + IF(ISEG.GT.0) THEN + CALL KDRCPU(TK1) + ALLOCATE(ISET(LL4)) + IF(CHEX) THEN + ISET(1)=0 + K1=MUW(1)+1 + DO 160 I=2,LL4W + ISET(I)=0 + K2=MUW(I) + DO 155 J=I-K2+K1,I-1 + ISET(J)=1 + 155 CONTINUE + K1=K2+1 + 160 CONTINUE + NSYS=0 + DO 165 I=1,LL4W + IF(ISET(I).EQ.0) NSYS=NSYS+1 + 165 CONTINUE + LONW=1+(NSYS-1)/ISEG + ALLOCATE(NBLW(LONW),LBLW(LONW),MUVW(LONW),IPVW(LONW)) + CALL VECPER('W',IMPV,ISEG,LL4W,MUW,LONW,LTSW2,NBLW,LBLW, + 1 MUVW,IPVW) + IMU=0 + DO 166 I=1,LONW + IMU=IMU+LBLW(I) + 166 CONTINUE + LTSW=MAX(LTSW,LTSW2) + CALL LCMPUT(IPTRK,'NBLW',LONW,1,NBLW) + CALL LCMPUT(IPTRK,'LBLW',LONW,1,LBLW) + CALL LCMPUT(IPTRK,'MUVW',IMU,1,MUVW) + CALL LCMPUT(IPTRK,'IPVW',LL4W,1,IPVW) + DEALLOCATE(IPVW,MUVW,LBLW,NBLW) + IMU=IMU*ISEG + CALL LCMPUT(IPTRK,'LL4VW',1,1,IMU) + ENDIF + IF(IDIAG.EQ.0) THEN + ISET(1)=0 + K1=MUX(1)+1 + DO 175 I=2,LL4X + ISET(I)=0 + K2=MUX(I) + DO 170 J=I-K2+K1,I-1 + ISET(J)=1 + 170 CONTINUE + K1=K2+1 + 175 CONTINUE + NSYS=0 + DO 180 I=1,LL4X + IF(ISET(I).EQ.0) NSYS=NSYS+1 + 180 CONTINUE + LONX=1+(NSYS-1)/ISEG + ALLOCATE(NBLX(LONX),LBLX(LONX),MUVX(LONX),IPVX(LONX)) + CALL VECPER('X',IMPV,ISEG,LL4X,MUX,LONX,LTSW2,NBLX,LBLX, + 1 MUVX,IPVX) + IMU=0 + DO 185 I=1,LONX + IMU=IMU+LBLX(I) + 185 CONTINUE + LTSW=MAX(LTSW,LTSW2) + CALL LCMPUT(IPTRK,'NBLX',LONX,1,NBLX) + CALL LCMPUT(IPTRK,'LBLX',LONX,1,LBLX) + CALL LCMPUT(IPTRK,'MUVX',IMU,1,MUVX) + CALL LCMPUT(IPTRK,'IPVX',LL4X,1,IPVX) + DEALLOCATE(IPVX,MUVX,LBLX,NBLX) + IMU=IMU*ISEG + CALL LCMPUT(IPTRK,'LL4VX',1,1,IMU) + ENDIF + IF(IDIM.GE.2) THEN + ISET(1)=0 + K1=MUY(1)+1 + DO 200 I=2,LL4Y + ISET(I)=0 + K2=MUY(I) + DO 190 J=I-K2+K1,I-1 + ISET(J)=1 + 190 CONTINUE + K1=K2+1 + 200 CONTINUE + NSYS=0 + DO 210 I=1,LL4Y + IF(ISET(I).EQ.0) NSYS=NSYS+1 + 210 CONTINUE + LONY=1+(NSYS-1)/ISEG + ALLOCATE(NBLY(LONY),LBLY(LONY),MUVY(LONY),IPVY(LONY)) + CALL VECPER('Y',IMPV,ISEG,LL4Y,MUY,LONY,LTSW2,NBLY,LBLY, + 1 MUVY,IPVY) + IMU=0 + DO 215 I=1,LONY + IMU=IMU+LBLY(I) + 215 CONTINUE + LTSW=MAX(LTSW,LTSW2) + CALL LCMPUT(IPTRK,'NBLY',LONY,1,NBLY) + CALL LCMPUT(IPTRK,'LBLY',LONY,1,LBLY) + CALL LCMPUT(IPTRK,'MUVY',IMU,1,MUVY) + CALL LCMPUT(IPTRK,'IPVY',LL4Y,1,IPVY) + DEALLOCATE(IPVY,MUVY,LBLY,NBLY) + IMU=IMU*ISEG + CALL LCMPUT(IPTRK,'LL4VY',1,1,IMU) + ENDIF + IF(IDIM.EQ.3) THEN + ISET(1)=0 + K1=MUZ(1)+1 + DO 230 I=2,LL4Z + ISET(I)=0 + K2=MUZ(I) + DO 220 J=I-K2+K1,I-1 + ISET(J)=1 + 220 CONTINUE + K1=K2+1 + 230 CONTINUE + NSYS=0 + DO 240 I=1,LL4Z + IF(ISET(I).EQ.0) NSYS=NSYS+1 + 240 CONTINUE + LONZ=1+(NSYS-1)/ISEG + ALLOCATE(NBLZ(LONZ),LBLZ(LONZ),MUVZ(LONZ),IPVZ(LONZ)) + CALL VECPER('Z',IMPV,ISEG,LL4Z,MUZ,LONZ,LTSW2,NBLZ,LBLZ, + 1 MUVZ,IPVZ) + IMU=0 + DO 250 I=1,LONZ + IMU=IMU+LBLZ(I) + 250 CONTINUE + LTSW=MAX(LTSW,LTSW2) + CALL LCMPUT(IPTRK,'NBLZ',LONZ,1,NBLZ) + CALL LCMPUT(IPTRK,'LBLZ',LONZ,1,LBLZ) + CALL LCMPUT(IPTRK,'MUVZ',IMU,1,MUVZ) + CALL LCMPUT(IPTRK,'IPVZ',LL4Z,1,IPVZ) + DEALLOCATE(IPVZ,MUVZ,LBLZ,NBLZ) + IMU=IMU*ISEG + CALL LCMPUT(IPTRK,'LL4VZ',1,1,IMU) + ENDIF + DEALLOCATE(ISET) + CALL KDRCPU(TK2) + IF(IMPX.GE.2) WRITE(6,'(/33H TRITRK: CPU TIME FOR SUPERVECTOR, + 1 19HIZATION NUMBERING =,F7.2,2H S)') TK2-TK1 + ENDIF +*---- +* SAVE STATE-VECTOR AND TRACKING INFORMATION. +*---- + IGP(:NSTATE)=0 + IGP(1)=NEL + IGP(2)=NUN + IF(ILK) THEN + IGP(3)=0 + ELSE + IGP(3)=1 + ENDIF + IGP(4)=ISTATE(7) + IGP(5)=0 + IGP(6)=ITYPE + IGP(7)=IHEX + IGP(8)=IDIAG + IGP(9)=IELEM + IGP(10)=ICOL + IGP(11)=LL4 + IGP(12)=ICHX + IGP(13)=ISPLH + IGP(14)=LX + IGP(15)=LY + IGP(16)=LZ + IGP(17)=ISEG + IF(ISEG.NE.0) THEN + IGP(18)=IMPV + IGP(19)=LTSW + IGP(20)=LONW + IGP(21)=LONX + IGP(22)=LONY + IGP(23)=LONZ + ENDIF + IGP(24)=NR0 + IF(ICHX.EQ.2) THEN + IGP(25)=LL4F + IGP(26)=LL4W + IGP(27)=LL4X + IGP(28)=LL4Y + IGP(29)=LL4Z + ENDIF + IGP(30)=NLF + IGP(31)=ISPN + IGP(32)=ISCAT + IGP(33)=NADI + IGP(34)=NVD + CALL LCMPUT(IPTRK,'STATE-VECTOR',NSTATE,1,IGP) + CALL LCMPUT(IPTRK,'MATCOD',NEL,1,MAT) + CALL LCMPUT(IPTRK,'VOLUME',NEL,2,VOL) + CALL LCMPUT(IPTRK,'KEYFLX',NEL,1,IDL) + CALL LCMPUT(IPTRK,'NCODE',6,1,NCODE) + CALL LCMPUT(IPTRK,'ZCODE',6,2,ZCODE) + CALL LCMPUT(IPTRK,'ICODE',6,1,ICODE) + CALL LCMPUT(IPTRK,'ZZ',NEL,2,ZZ) + CALL LCMPUT(IPTRK,'KN',MAXKN,1,KN) + CALL LCMPUT(IPTRK,'QFR',MAXQF,2,QFR) + CALL LCMPUT(IPTRK,'IQFR',MAXQF,1,IQFR) + IF(ICHX.NE.2) THEN + CALL LCMPUT(IPTRK,'IPX',LL4,1,IPX) + DEALLOCATE(IPX) + ENDIF + IF(CHEX) THEN + CALL LCMPUT(IPTRK,'SIDE',1,2,SIDE) + CALL LCMPUT(IPTRK,'MUW',LL4W,1,MUW) + IF(ICHX.NE.2) THEN + CALL LCMPUT(IPTRK,'IPW',LL4,1,IPW) + DEALLOCATE(IPW) + ENDIF + DEALLOCATE(MUW) + ELSE + CALL LCMPUT(IPTRK,'XX',NEL,2,XX) + CALL LCMPUT(IPTRK,'YY',NEL,2,YY) + IF(.NOT.CYLIND) DD=0.0 + CALL LCMPUT(IPTRK,'DD',MAXDD,2,DD) + ENDIF + DEALLOCATE(XX,YY,ZZ,DD,KN,QFR,IQFR) + IF((IDIAG.EQ.0).AND.(LL4X.GT.0)) THEN + CALL LCMPUT(IPTRK,'MUX',LL4X,1,MUX) + ENDIF + IF((IDIM.GE.2).AND.(LL4Y.GT.0)) THEN + CALL LCMPUT(IPTRK,'MUY',LL4Y,1,MUY) + IF(ICHX.NE.2) THEN + CALL LCMPUT(IPTRK,'IPY',LL4,1,IPY) + DEALLOCATE(IPY) + ENDIF + ELSE + IF(ICHX.NE.2) DEALLOCATE(IPY) + ENDIF + IF((IDIM.EQ.3).AND.(LL4Z.GT.0)) THEN + CALL LCMPUT(IPTRK,'MUZ',LL4Z,1,MUZ) + IF(ICHX.NE.2) THEN + CALL LCMPUT(IPTRK,'IPZ',LL4,1,IPZ) + DEALLOCATE(IPZ) + ENDIF + ELSE + IF(ICHX.NE.2) DEALLOCATE(IPZ) + ENDIF + DEALLOCATE(MUZ,MUY,MUX) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(MAT,IDL,VOL) + RETURN +* + 600 FORMAT(/26H TRITRK: VALUES OF VECTOR ,A6,4H ARE/(1X,1P,20I6)) + 620 FORMAT (///11H REGION ,8(I8,6X,1HI)) + 630 FORMAT ( 11H MIXTURE ,8(I8,6X,1HI)) + 640 FORMAT ( 11H POINTER ,8(I8,6X,1HI)) + 650 FORMAT ( 11H VOLUME ,8(1P,E13.6,2H I)) + END diff --git a/Trivac/src/TRIVAA.f b/Trivac/src/TRIVAA.f new file mode 100755 index 0000000..acee907 --- /dev/null +++ b/Trivac/src/TRIVAA.f @@ -0,0 +1,303 @@ +*DECK TRIVAA + SUBROUTINE TRIVAA(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* TRIVAC type (3-D and ADI) system matrix assembly operator. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1): create or modification type(L_SYSTEM); +* HENTRY(2): read-only type(L_MACROLIB) (unperturbed); +* HENTRY(3): read-only type(L_TRACK); +* HENTRY(4): optional read-only type(L_MACROLIB) (perturbed). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*Comments: +* The TRIVAA: calling specifications are: +* SYST := TRIVAA: [ SYST ] MACRO TRACK [ DMACRO ] :: (trivaa\_data) ; +* where +* SYST : name of the \emph{lcm} object (type L\_SYSTEM) containing the +* system matrices. If SYST appears on the RHS, the system matrices +* previously stored in SYST are kept. +* MACRO : name of the \emph{lcm} object (type L\_MACROLIB) containing the +* macroscopic cross sections and diffusion coefficients. +* TRACK : name of the \emph{lcm} object (type L\_TRIVAC) containing the +* TRIVAC \emph{tracking}. +* DMACRO : name of the \emph{lcm} object (type L\_MACROLIB) containing +* derivatives or perturbations of the macroscopic cross sections and +* diffusion coefficients. If DMACRO is given, only the derivatives or +* perturbations of the system matrices are computed. +* trivaa\_data : structure containing the data to module TRIVAA: +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 + TYPE(C_PTR) KENTRY(NENTRY) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + CHARACTER TEXT4*4,TEXT11*12,TEXT12*12,HSMG*131,TITLE*72,CNAM*12 + DOUBLE PRECISION DFLOTT + INTEGER IGP(NSTATE),IPAR(NSTATE),ITR(NSTATE) + LOGICAL LDIFF + TYPE(C_PTR) IPSYS,JPSYS,KPSYS,IPMACR,JPMACR,KPMACR,IPTRK,IPMACP + INTEGER, DIMENSION(:), ALLOCATABLE :: MAT + REAL, DIMENSION(:), ALLOCATABLE :: VOL,UN,VII +*---- +* PARAMETER VALIDATION. +*---- + IF(NENTRY.LE.2) CALL XABORT('TRIVAA: THREE PARAMETERS EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('TRIVAA: L' + 1 //'CM OBJECT EXPECTED AT LHS.') + IF((JENTRY(1).NE.0).AND.(JENTRY(1).NE.1)) CALL XABORT('TRIVAA: E' + 1 //'NTRY IN CREATE OR MODIFICATION MODE EXPECTED.') + IF((JENTRY(3).NE.2).OR.((IENTRY(3).NE.1).AND.(IENTRY(3).NE.2))) + 1 CALL XABORT('TRIVAA: LCM OBJECT IN READ-ONLY MODE EXPECTED AT F' + 2 //'IRST RHS.') + IF((JENTRY(2).NE.2).OR.((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2))) + 1 CALL XABORT('TRIVAA: LCM OBJECT IN READ-ONLY MODE EXPECTED AT S' + 2 //'ECOND RHS.') + CALL LCMGTC(KENTRY(3),'SIGNATURE',12,TEXT11) + IF(TEXT11.NE.'L_TRACK') THEN + TEXT12=HENTRY(3) + CALL XABORT('TRIVAA: SIGNATURE OF '//TEXT12//' IS '//TEXT11// + 1 '. L_TRACK EXPECTED.') + ENDIF + CALL LCMGTC(KENTRY(3),'TRACK-TYPE',12,TEXT11) + IF(TEXT11.NE.'TRIVAC') THEN + TEXT12=HENTRY(3) + CALL XABORT('TRIVAA: TRACK-TYPE OF '//TEXT12//' IS '//TEXT11 + 1 //'. TRIVAC EXPECTED.') + ENDIF + TEXT11='L_SYSTEM' + IPSYS=KENTRY(1) + CALL LCMPTC(IPSYS,'SIGNATURE',12,TEXT11) + IPMACR=KENTRY(2) + IPTRK=KENTRY(3) + TEXT12=HENTRY(2) + CALL LCMPTC(IPSYS,'LINK.MACRO',12,TEXT12) + TEXT12=HENTRY(3) + CALL LCMPTC(IPSYS,'LINK.TRACK',12,TEXT12) +*---- +* RECOVER GENERAL TRACKING INFORMATION. +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',IGP) + NEL=IGP(1) + NLF=IGP(30) + ISCAT=IGP(32) + LDIFF=(ISCAT.LT.0) + ISCAT=ABS(ISCAT) + IF((NLF.NE.0).AND.(IGP(31).NE.1)) CALL XABORT('TRIVAA: ONLY SPN ' + 1 //'DISCRETIZATIONS ARE ALLOWED.') + ITY=2 + IF(IGP(12).EQ.2) ITY=3 + ALLOCATE(MAT(NEL),VOL(NEL)) + CALL LCMGET(IPTRK,'MATCOD',MAT) + CALL LCMGET(IPTRK,'VOLUME',VOL) + CALL LCMLEN(IPTRK,'TITLE',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + CALL LCMGTC(IPTRK,'TITLE',72,TITLE) + ELSE + TITLE='*** NO TITLE PROVIDED ***' + ENDIF +*---- +* RECOVER MACROLIB PARAMETERS. +*---- + CALL LCMGTC(IPMACR,'SIGNATURE',12,TEXT11) + IF(TEXT11.NE.'L_MACROLIB') THEN + TEXT12=HENTRY(2) + CALL XABORT('TRIVAA: SIGNATURE OF '//TEXT12//' IS '//TEXT11// + 1 '. L_MACROLIB EXPECTED.') + ENDIF + CALL LCMGET(IPMACR,'STATE-VECTOR',IPAR) + NGRP=IPAR(1) + NBMIX=IPAR(2) + NANI=IPAR(3) + NBFIS=IPAR(4) + NALBP=IPAR(8) + IF(IGP(4).GT.NBMIX) THEN + WRITE(HSMG,'(46HTRIVAA: THE NUMBER OF MIXTURES IN THE TRACKING, + 1 2H (,I5,51H) IS GREATER THAN THE NUMBER OF MIXTURES IN THE MAC, + 2 7HROLIB (,I5,2H).)') IGP(4),NBMIX + CALL XABORT(HSMG) + ENDIF +* + IMPX=1 + IASM=0 + IPR=0 + IUNIT=0 + IOVEL=0 + NSTEP=0 + 10 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.EQ.10) GO TO 30 + IF(INDIC.NE.3) CALL XABORT('TRIVAA: CHARACTER DATA EXPECTED.') + IF(TEXT4.EQ.'EDIT') THEN + CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('TRIVAA: INTEGER DATA EXPECTED(1).') + ELSE IF(TEXT4.EQ.'SKIP') THEN +* OPTION TO SKIP THE SYSTEM MATRIX ASSEMBLY (DO NOT SKIP THE +* LDLT FACTORIZATION). + IASM=1 + ELSE IF(TEXT4.EQ.'DERI') THEN + IPR=1 + WRITE(6,'(/43H TRIVAA: USE DERIVATIVE OF SYSTEM MATRICES.)') + ELSE IF(TEXT4.EQ.'PERT') THEN + IPR=2 + WRITE(6,'(/41H TRIVAA: PERTURBATION OF SYSTEM MATRICES.)') + ELSE IF(TEXT4.EQ.'UNIT') THEN +* COMPUTE THE UNITARY WEIGHTING MATRIX. + IUNIT=1 + ALLOCATE(UN(NBMIX)) + UN(:NBMIX)=1.0 + CALL TRIDIG('RM',IPTRK,IPSYS,IMPX,NBMIX,NEL,0,MAT,VOL,UN) + DEALLOCATE(UN) + ELSE IF(TEXT4.EQ.'OVEL') THEN +* COMPUTE THE RECIPROCAL NEUTRON VELOCITIES MATRIX. + IOVEL=1 + JPMACR=LCMGID(IPMACR,'GROUP') + ALLOCATE(VII(NBMIX)) + DO 25 IGR=1,NGRP + KPMACR=LCMGIL(JPMACR,IGR) + CALL LCMLEN(KPMACR,'OVERV',LENGT,ITYLCM) + IF(LENGT.EQ.0) THEN + CALL XABORT('TRIVAA: NO ''VELOCITY'' INFORMATION.') + ELSE IF(LENGT.GT.NBMIX) THEN + CALL XABORT('TRIVAA: INVALID LENGTH FOR ''VELOCITY'' IN' + 1 //'FORMATION.') + ENDIF + CALL LCMGET(KPMACR,'OVERV',VII) + WRITE (CNAM,'(1HV,2I3.3)') IGR,IGR + CALL TRIDIG(CNAM,IPTRK,IPSYS,IMPX,NBMIX,NEL,0,MAT,VOL,VII) + 25 CONTINUE + DEALLOCATE(VII) + ELSE IF(TEXT4.EQ.';') THEN + GO TO 30 + ELSE + CALL XABORT('TRIVAA: '//TEXT4//' IS AN INVALID KEY WORD.') + ENDIF + GO TO 10 +*---- +* 2-MACROLIBS PERTURBATION CALCULATION. +*---- + 30 IF(IPR.GT.0) THEN + IF(NENTRY.LE.3) CALL XABORT('TRIVAA: 4 PARAMETERS EXPECTED WIT' + 1 //'H DERI OR PERT OPTIONS.') + IF((JENTRY(4).NE.2).OR.((IENTRY(4).NE.1).AND.(IENTRY(4).NE.2))) + 1 CALL XABORT('TRIVAA: LINKED LIST OR XSM FILE IN READ-ONLY MODE' + 2 //' EXPECTED AT THIRD RHS.') + IPMACP=KENTRY(4) + CALL LCMGTC(IPMACP,'SIGNATURE',12,TEXT11) + IF(TEXT11.NE.'L_MACROLIB') THEN + TEXT12=HENTRY(4) + CALL XABORT('TRIVAA: SIGNATURE OF '//TEXT12//' IS ' + 1 //TEXT11//'. L_MACROLIB EXPECTED.') + ENDIF + CALL LCMGET(IPMACP,'STATE-VECTOR',IPAR) + NSTEP=IPAR(11) + IF((IPAR(1).NE.NGRP).OR.(IPAR(2).GT.NBMIX)) THEN + WRITE(HSMG,'(43HTRIVAA: INCONSISTENT PERTURBATION MACROLIB , + 1 1H'',A12,8H''. NGRP=,2I5,7H NBMIX=,2I9)') HENTRY(4),IPAR(1), + 2 NGRP,IPAR(2),NBMIX + CALL XABORT(HSMG) + ENDIF + ENDIF +*---- +* SET THE STATE VECTOR FOR THE L_SYSTEM OBJECT +*---- + ITR(:NSTATE)=0 + ITR(1)=NGRP + ITR(2)=IGP(11) + ITR(3)=0 + ITR(4)=ITY + IF((NLF.GT.0).AND.(ITY.GE.3)) ITR(4)=10+ITR(4) + IF(IUNIT.EQ.1) ITR(5)=1 + ITR(6)=NSTEP + ITR(7)=NBMIX + NAN=MIN(ISCAT,NANI) + ITR(8)=NLF + ITR(9)=IPR + CALL LCMPUT(IPSYS,'STATE-VECTOR',NSTATE,1,ITR) +*---- +* SYSTEM MATRIX ASSEMBLY. +*---- + IF((IASM.EQ.0).AND.(IPR.EQ.0)) THEN + IF(NLF.EQ.0) THEN +* DIFFUSION THEORY. + CALL TRISYS(IPTRK,IPMACR,IPMACR,IPSYS,IMPX,NGRP,NEL,NBFIS, + 1 NALBP,IPR,MAT,VOL,NBMIX) + ELSE +* SIMPLIFIED PN THEORY. + CALL TRISPS(IPTRK,IPMACR,IPMACR,IPSYS,IMPX,NGRP,NEL,NLF, + 1 NAN,NBFIS,NALBP,LDIFF,IPR,MAT,VOL,NBMIX) + ENDIF + ELSE IF((IASM.EQ.1).AND.(IPR.EQ.0)) THEN +* PERFORM FACTORIZATION WITHOUT ASSEMBLY. + DO 40 I=1,NGRP + WRITE(TEXT11,'(1HA,2I3.3)') I,I + CALL MTLDLF(TEXT11,IPTRK,IPSYS,ITY,IMPX) + 40 CONTINUE + ELSE IF((IPR.GT.0).AND.(NSTEP.EQ.0)) THEN +* ASSEMBLY OF PERTURBED SYSTEM MATRICES (NO STEP DIRECTORIES). + IF(NLF.EQ.0) THEN +* DIFFUSION THEORY. + CALL TRISYS(IPTRK,IPMACR,IPMACP,IPSYS,IMPX,NGRP,NEL,NBFIS, + 1 NALBP,IPR,MAT,VOL,NBMIX) + ELSE +* SIMPLIFIED PN THEORY. + CALL TRISPS(IPTRK,IPMACR,IPMACP,IPSYS,IMPX,NGRP,NEL,NLF, + 1 NAN,NBFIS,NALBP,LDIFF,IPR,MAT,VOL,NBMIX) + ENDIF + ELSE IF(NSTEP.GT.0) THEN +* ASSEMBLY OF PERTURBED SYSTEM MATRICES (WITH STEP DIRECTORIES). + JPMACR=LCMGID(IPMACP,'STEP') + JPSYS=LCMLID(IPSYS,'STEP',NSTEP) + DO 50 ISTEP=1,NSTEP + KPMACR=LCMGIL(JPMACR,ISTEP) + KPSYS=LCMDIL(JPSYS,ISTEP) + CALL LCMPUT(KPSYS,'STATE-VECTOR',NSTATE,1,ITR) + IF(NLF.EQ.0) THEN +* DIFFUSION THEORY. + CALL TRISYS(IPTRK,IPMACR,KPMACR,KPSYS,IMPX,NGRP,NEL,NBFIS, + 1 NALBP,IPR,MAT,VOL,NBMIX) + ELSE +* SIMPLIFIED PN THEORY. + CALL TRISPS(IPTRK,IPMACR,KPMACR,KPSYS,IMPX,NGRP,NEL,NLF, + 1 NAN,NBFIS,NALBP,LDIFF,IPR,MAT,VOL,NBMIX) + ENDIF + 50 CONTINUE + ELSE + CALL XABORT('TRIVAA: INVALID REQUEST.') + ENDIF +* + IF(IMPX.GE.3) CALL LCMLIB(IPSYS) +*---- +* RELEASE GENERAL TRACKING INFORMATION. +*---- + DEALLOCATE(VOL,MAT) + RETURN + END diff --git a/Trivac/src/TRIVAC.f90 b/Trivac/src/TRIVAC.f90 new file mode 100755 index 0000000..015fcd9 --- /dev/null +++ b/Trivac/src/TRIVAC.f90 @@ -0,0 +1,79 @@ +program TRIVAC + use GANLIB + implicit none + integer, parameter :: iout=6 + character(len=131) :: hsmg +!---- +! local storage +!---- + integer :: iprint,ier +!---- +! gan-2000 external functions +!---- + integer, external :: KERNEL + interface + integer(c_int) function trimod(cmodul, nentry, hentry, ientry, jentry, & + kentry, hparam_c) bind(c) + use, intrinsic :: iso_c_binding + character(kind=c_char), dimension(*) :: cmodul + integer(c_int), value :: nentry + character(kind=c_char), dimension(13,*) :: hentry + integer(c_int), dimension(nentry) :: ientry, jentry + type(c_ptr), dimension(nentry) :: kentry + character(kind=c_char), dimension(73,*) :: hparam_c + end function trimod + end interface +!---- +! variables for TRIVAC version +!---- + integer :: imvers + character(len=64) :: date + character(len=48) :: rev + character(len=6), parameter :: namsbr='trivac' +!---- +! version information recovered from cvs +!---- + imvers=5 + call KDRVER(rev,date) + write(iout,6000) namsbr,imvers,rev,date + write(iout,6010) namsbr +!---- +! execute the cle-2000 driver +!---- + iprint=0 + ier=KERNEL(trimod,iprint) + if( ier /= 0 )then + write(hsmg,'(27hTRIVAC: kernel error (code=,I5,2h).)') ier + call XABORT(hsmg) + endif +!---- +! all modules processed +!---- + write(iout,6030) namsbr,imvers,rev + stop +!---- +! formats +!---- + 6000 format( ' TTTTTTTT RRRRRR IIIIII VV VV AA CCCCC '/ & + ' TTTTTTTT RRRRRRR IIIIII VV VV AAAA CCCCCCC'/ & + ' TT RR RR II VV VV AAAA CC CC'/ & + ' TT RRRRR II VV VV AA AA CC '/ & + ' TT RRRRR II VV VV AAAAAA CC '/ & + ' TT RR RR II VV VV AAAAAA CC CC'/ & + ' TT RR RR IIIIII VVVV AA AA CCCCCCC'/ & + ' TT RR RR IIIIII VV AA AA CCCCC '// & + ' VERSION ',A6,I2,2X,A,4X,A/ & + ' GROUPE D''ANALYSE NUCLEAIRE'/ & + ' ECOLE POLYTECHNIQUE DE MONTREAL'///) + 6010 format( ' COPYRIGHT NOTICE FOR THIS VERSION OF ',A6,':'/ & + ' --------------------------------------------'/ & + ' Copyright (C) 2002 Ecole Polytechnique de Montreal '/ & + ' This library is free software; you can redistribute it' / & + ' and/or modify it under the terms of the GNU Lesser General' / & + ' Public License as published by the Free Software Foundation;' / & + ' either version 2.1 of the License, or (at your option) any' / & + ' later version '////) + 6030 format(//1x,'normal end of execution for ',a6,i2,2x,a/ & + 1x,'check for warning in listing'/ & + 1x,'before assuming your run was successful') +end program TRIVAC diff --git a/Trivac/src/TRIVAT.f b/Trivac/src/TRIVAT.f new file mode 100755 index 0000000..bf3ae40 --- /dev/null +++ b/Trivac/src/TRIVAT.f @@ -0,0 +1,314 @@ +*DECK TRIVAT + SUBROUTINE TRIVAT(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* TRIVAC type (3-D and ADI) tracking operator. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1): create or modification type(L_TRACK); +* HENTRY(2): read-only type(L_GEOM). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*Comments: +* The TRIVAT: calling specifications are: +* TRACK := TRIVAT: [ TRACK ] GEOM :: (trivat\_data) ; +* where +* TRACK : name of the \emph{lcm} object (type L\_TRIVAC) containing the +* \emph{tracking} information. If TRACK} appears on the RHS, the previous +* settings will be applied by default. +* GEOM : name of the \emph{lcm} object (type L\_GEOM) containing the +* geometry. +* trivat\_data : structure containing the data to module TRIVAT: +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 + TYPE(C_PTR) KENTRY(NENTRY) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + CHARACTER TEXT4*4,TEXT12*12,TITLE*72,HSIGN*12 + DOUBLE PRECISION DFLOTT + LOGICAL LOG,LDIFF + INTEGER IGP(NSTATE),ISTATE(NSTATE),NCODE(6) +*---- +* PARAMETER VALIDATION. +*---- + IF(NENTRY.LE.1) CALL XABORT('TRIVAT: TWO PARAMETERS EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('TRIVAT: L' + 1 //'CM OBJECT EXPECTED AT LHS.') + IF((JENTRY(1).NE.0).AND.(JENTRY(1).NE.1)) CALL XABORT('TRIVAT: E' + 1 //'NTRY IN CREATE OR MODIFICATION MODE EXPECTED.') + IF((JENTRY(2).NE.2).OR.((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2))) + 1 CALL XABORT('TRIVAT: LCM OBJECT IN READ-ONLY MODE EXPECTED AT R' + 2 //'HS.') + CALL LCMGTC(KENTRY(2),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_GEOM') THEN + TEXT12=HENTRY(2) + CALL XABORT('TRIVAT: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_GEOM EXPECTED.') + ENDIF + HSIGN='L_TRACK' + CALL LCMPTC(KENTRY(1),'SIGNATURE',12,HSIGN) + HSIGN='TRIVAC' + CALL LCMPTC(KENTRY(1),'TRACK-TYPE',12,HSIGN) + CALL LCMGET(KENTRY(2),'STATE-VECTOR',ISTATE) + ITYPE=ISTATE(1) + CALL LCMLEN(KENTRY(2),'BIHET',ILONG,ITYLCM) + IF(ILONG.NE.0) CALL XABORT('TRIVAT: DOUBLE-HETEROGENEITY NOT SUP' + 1 //'PORTED.') +* + IMPX=1 + TITLE=' ' + IF(JENTRY(1).EQ.0) THEN + MAXPTS=ISTATE(6) + IELEM=1 + ICOL=2 + ICHX=3 + ISEG=0 + IMPV=1 + NLF=0 + ISPN=0 + ISCAT=0 + NADI=2 + NVD=0 + CALL LCMGET(KENTRY(2),'NCODE',NCODE) + LOG=.FALSE. + DO 10 I=1,6 + LOG=LOG.OR.(NCODE(I).EQ.3) + 10 CONTINUE + IF(LOG) MAXPTS=2*MAXPTS + LDIFF=.FALSE. + ELSE + CALL LCMGTC(KENTRY(1),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_TRACK') THEN + TEXT12=HENTRY(1) + CALL XABORT('TRIVAT: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_TRACK EXPECTED.') + ENDIF + CALL LCMGTC(KENTRY(1),'TRACK-TYPE',12,HSIGN) + IF(HSIGN.NE.'TRIVAC') THEN + TEXT12=HENTRY(3) + CALL XABORT('TRIVAT: TRACK-TYPE OF '//TEXT12//' IS '//HSIGN + 1 //'. TRIVAC EXPECTED.') + ENDIF + CALL LCMGET(KENTRY(1),'STATE-VECTOR',IGP) + MAXPTS=IGP(1) + IELEM=IGP(9) + ICOL=IGP(10) + ICHX=IGP(12) + ISEG=IGP(17) + IMPV=IGP(18) + NLF=IGP(30) + ISPN=IGP(31) + ISCAT=IGP(32) + NADI=IGP(33) + NVD=IGP(34) + CALL LCMLEN(KENTRY(1),'TITLE',LENGT,ITYLCM) + IF(LENGT.GT.0) CALL LCMGTC(KENTRY(1),'TITLE',72,TITLE) + LDIFF=(ISCAT.LT.0) + ENDIF + 15 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.EQ.10) GO TO 30 + 20 IF(INDIC.NE.3) CALL XABORT('TRIVAT: CHARACTER DATA EXPECTED.') + IF(TEXT4.EQ.'EDIT') THEN + CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('TRIVAT: INTEGER DATA EXPECTED(1).') + ELSE IF(TEXT4.EQ.'TITL') THEN + CALL REDGET(INDIC,NITMA,FLOTT,TITLE,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('TRIVAT: TITLE EXPECTED.') + ELSE IF(TEXT4.EQ.'MAXR') THEN + CALL REDGET(INDIC,MAXPTS,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('TRIVAT: INTEGER DATA EXPECTED(2).') + ELSE IF(TEXT4.EQ.'PRIM') THEN +* MESH CORNER FINITE DIFFERENCES OR PRIMAL FINITE ELEMENTS. + IELEM=1 + ICHX=1 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.EQ.1) THEN + IELEM=NITMA + ELSE + GO TO 20 + ENDIF + ELSE IF(TEXT4.EQ.'DUAL') THEN +* MESH CENTERED FINITE DIFFERENCES OR MIXED-DUAL FINITE ELEMENTS. + IELEM=1 + ICOL=2 + ICHX=2 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.EQ.1) THEN + IELEM=NITMA + CALL REDGET(INDIC,ICOL,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('TRIVAT: INTEGER DATA EXPECTED.') + ELSE + GO TO 20 + ENDIF + ELSE IF(TEXT4.EQ.'MCFD') THEN +* MESH CENTERED FINITE DIFFERENCES OR NODAL COLLOCATION. + IELEM=1 + ICHX=3 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.EQ.1) THEN + IELEM=NITMA + ELSE + GO TO 20 + ENDIF + ELSE IF(TEXT4.EQ.'LUMP') THEN +* NODAL COLLOCATION WITH SERENDIPITY APPROXIMATION. + IELEM=1 + ICHX=4 + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.EQ.1) THEN + IELEM=NITMA + ELSE + GO TO 20 + ENDIF + ELSE IF(TEXT4.EQ.'VOID') THEN + IF(NLF.EQ.0) CALL XABORT('TRIVAT: SPN-RELATED OPTION.') + CALL REDGET(INDIC,NVD,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('TRIVAT: INTEGER DATA EXPECTED.') + IF((NVD.LT.0).OR.(NVD.GT.2)) CALL XABORT('TRIVAT: INVALID VAL' + 1 //'UE OF NVD (0, 1 OR 2 EXPECTED).') + ELSE IF(TEXT4.EQ.'VECT') THEN + ISEG=64 + CALL REDGET(INDIC,ISEG,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) GO TO 20 + IF(MOD(ISEG,64).NE.0) WRITE(6,'(/25H TRIVAT: ***WARNING*** IS, + 1 27HEG IS NOT A MULTIPLE OF 64.)') + ELSE IF(TEXT4.EQ.'PRTV') THEN + CALL REDGET(INDIC,IMPV,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('TRIVAT: INTEGER DATA EXPECTED.') + ELSE IF(TEXT4.EQ.'SPN') THEN + CALL REDGET(INDIC,NLF,FLOTT,TEXT4,DFLOTT) + IF((INDIC.EQ.3).AND.(TEXT4.EQ.'DIFF')) THEN + LDIFF=.TRUE. + CALL REDGET(INDIC,NLF,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('TRIVAT: INTEGER DATA EXPECTED' + 1 //'(10).') + ELSE IF(INDIC.NE.1) THEN + CALL XABORT('TRIVAT: INTEGER DATA OR DIFF KEYWORD EXPECTED.') + ENDIF + IF(NLF.EQ.0) THEN +* DIFFUSION THEORY. + ISCAT=0 + ISPN=0 + ELSE + IF(MOD(NLF,2).EQ.0) CALL XABORT('TRIVAT: ODD SPN ORDER EXP' + 1 //'ECTED.') + NLF=NLF+1 + ISCAT=NLF + ISPN=1 + ENDIF + ELSE IF(TEXT4.EQ.'SCAT') THEN + IF(NLF.EQ.0) CALL XABORT('TRIVAT: DEFINE PN OR SPN FIRST.') + CALL REDGET(INDIC,ISCAT,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('TRIVAT: INTEGER DATA EXPECTED.') + IF(ISCAT.LE.0) CALL XABORT('TRIVAT: POSITIVE ISCAT EXPECTED.') + ELSE IF(TEXT4.EQ.'ADI') THEN + CALL REDGET(INDIC,NADI,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('TRIVAT: INTEGER DATA EXPECTED.') + ELSE IF(TEXT4.EQ.';') THEN + GO TO 30 + ELSE + CALL XABORT('TRIVAT: '//TEXT4//' IS AN INVALID KEY WORD.') + ENDIF + GO TO 15 +* + 30 IF(LDIFF) ISCAT=-ISCAT + IF(TITLE.NE.' ') CALL LCMPTC(KENTRY(1),'TITLE',72,TITLE) + IF((NLF.GT.0).AND.(IELEM.LT.0)) CALL XABORT('TRIVAT: SPN APPROXI' + 1 //'MATIONS LIMITED TO DUAL DISCRETIZATIONS.') + TEXT12=HENTRY(2) + CALL LCMPTC(KENTRY(1),'LINK.GEOM',12,TEXT12) + IF(IMPX.GT.1) WRITE(6,100) TITLE +* + IF(MAXPTS.EQ.0) CALL XABORT('TRIVAT: MAXPTS NOT DEFINED.') + CALL TRITRK (MAXPTS,KENTRY(1),KENTRY(2),IMPX,IELEM,ICOL,ICHX, + 1 ISEG,IMPV,NLF,NVD,ISPN,ISCAT,NADI) +* + IF(IMPX.GT.1) THEN + CALL LCMGET(KENTRY(1),'STATE-VECTOR',IGP) + WRITE(6,110) (IGP(I),I=1,16),IGP(24),(IGP(I),I=30,34) + IF(IGP(17).NE.0) WRITE(6,120) (IGP(I),I=17,23) + IF(IGP(12).EQ.2) WRITE(6,130) (IGP(I),I=25,29) + ENDIF + RETURN +* + 100 FORMAT(1H1,45HTTTTTTTT RRRRRR IIIIII VV VV AA CCCCC , + 1 85(1H*)/47H TTTTTTTT RRRRRRR IIIIII VV VV AAAA CCCCCCC , + 2 46(1H*),38H MULTIGROUP VERSION. A. HEBERT (1993)/ + 3 46H TT RR RR II VV VV AAAA CC CC/ + 4 46H TT RRRRR II VV VV AA AA CC / + 5 46H TT RRRRR II VV VV AAAAAA CC / + 6 46H TT RR RR II VV VV AAAAAA CC CC/ + 7 46H TT RR RR IIIIII VVVV AA AA CCCCCCC/ + 8 46H TT RR RR IIIIII VV AA AA CCCCC //1X,A72//) + 110 FORMAT(/14H STATE VECTOR:/ + 1 7H NREG ,I8,22H (NUMBER OF REGIONS)/ + 2 7H NUN ,I8,23H (NUMBER OF UNKNOWNS)/ + 3 7H ILK ,I8,39H (0=LEAKAGE PRESENT/1=LEAKAGE ABSENT)/ + 4 7H NBMIX ,I8,36H (MAXIMUM NUMBER OF MIXTURES USED)/ + 5 7H NSURF ,I8,29H (NUMBER OF OUTER SURFACES)/ + 6 7H ITYPE ,I8,21H (TYPE OF GEOMETRY)/ + 7 7H IHEX ,I8,31H (TYPE OF HEXAGONAL SYMMETRY)/ + 8 7H IDIAG ,I8,41H (0/1=DIAGONAL SYMMETRY ABSENT/PRESENT)/ + 9 7H IELEM ,I8,28H (TYPE OF FINITE ELEMENTS)/ + 1 7H ICOL ,I8,47H (TYPE OF QUADRATURE USED TO INTEGRATE THE MA, + 2 10HSS MATRIX)/ + 3 7H LL4 ,I8,46H (ORDER OF THE MATRICES PER GROUP IN TRIVAC)/ + 4 7H ICHX ,I8,47H (1=PRIMAL/2=THOMAS-RAVIART/3=NODAL COLLOCATI, + 5 10HON (MCFD))/ + 6 7H ISPLH ,I8,37H (TYPE OF HEXAGONAL MESH-SPLITTING)/ + 7 7H LX ,I8,40H (NUMBER OF ELEMENTS ALONG THE X AXIS)/ + 8 7H LY ,I8,40H (NUMBER OF ELEMENTS ALONG THE Y AXIS)/ + 9 7H LZ ,I8,40H (NUMBER OF ELEMENTS ALONG THE Z AXIS)/ + 1 7H NR0 ,I8,47H (NUMBER OF RADII IN CYLINDRICAL CORRECTION A, + 2 9HLGORITHM)/ + 3 7H NLF ,I8,45H (0=DIFFUSION/NB OF PN ORDERS FOR THE FLUX)/ + 4 7H ISPN ,I8,34H (0=COMPLETE PN/1=SIMPLIFIED PN)/ + 5 7H ISCAT ,I8,47H (1=ISOTROPIC SOURCE/2=LINEARLY ANISOTROPIC S, + 6 6HOURCE)/ + 7 7H NADI ,I8,29H (NUMBER OF ADI ITERATIONS)/ + 8 7H NVD ,I8,47H (0=PN-TYPE VOID/1=SN-TYPE VOID/2=DIFFUSION-T, + 9 9HYPE VOID)) + 120 FORMAT(/44H STATE VECTOR FOR SUPERVECTORIAL OPERATIONS:/ + 1 7H ISEG ,I8,46H (NUMBER OF COMPONENTS IN A VECTOR REGISTER)/ + 2 7H IMPV ,I8,20H (PRINT PARAMETER)/ + 3 7H LTSW ,I8,22H (MAXIMUM BANDWIDTH)/ + 4 7H LONW ,I8,48H (NB OF GROUPS OF LINEAR SYSTEMS ALONG W AXIS)/ + 5 7H LONX ,I8,48H (NB OF GROUPS OF LINEAR SYSTEMS ALONG X AXIS)/ + 6 7H LONY ,I8,48H (NB OF GROUPS OF LINEAR SYSTEMS ALONG Y AXIS)/ + 7 7H LONZ ,I8,48H (NB OF GROUPS OF LINEAR SYSTEMS ALONG Z AXIS)) + 130 FORMAT(/40H STATE VECTOR FOR THOMAS-RAVIART METHOD:/ + 1 7H LL4F ,I8,24H (ORDER OF MATRICES T)/ + 2 7H LL4W ,I8,25H (ORDER OF MATRICES AW)/ + 3 7H LL4X ,I8,25H (ORDER OF MATRICES AX)/ + 4 7H LL4Y ,I8,25H (ORDER OF MATRICES AY)/ + 5 7H LL4Z ,I8,25H (ORDER OF MATRICES AZ)) + END diff --git a/Trivac/src/TRIZNR.f b/Trivac/src/TRIZNR.f new file mode 100755 index 0000000..02f4230 --- /dev/null +++ b/Trivac/src/TRIZNR.f @@ -0,0 +1,131 @@ +*DECK TRIZNR + SUBROUTINE TRIZNR(IMPX,ICOTE,CENTER,CELEM,IAXIS,NR0,RR0,XR0,ANG, + 1 QFR,QTR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Calculates the correcting factor for cylinder outside elements. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input +* IMPX print parameter (equal to zero for no print). +* ICOTE face number (1=X-, 2=X+, 3=Y-, 4=Y+, 5=Z-, 6=Z+). +* CENTER coordinates for center of cylinder. +* CELEM coordinates for center of the element. +* IAXIS principal axis for cylinder. +* NR0 number of radii. +* RR0 radii. +* XR0 coordinates on principal axis. +* ANG angles for applying circular correction. +* +*Parameters: output +* QFR used to compute transmission factor ( K0/COST ). +* QTR used to compute transmission factor ( K0*(R0-RELEM) ). +* +*----------------------------------------------------------------------- +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IMPX,ICOTE,IAXIS,NR0 + REAL CENTER(3),CELEM(3),RR0(NR0),XR0(NR0),ANG(NR0),QFR,QTR +*---- +* LOCAL VARIABLES +*---- + CHARACTER*4 AXE(6) + PARAMETER ( PI= 3.1415926535, PIO2= 0.5*PI, EPSERR=0.05 ) + DATA AXE/ '1=X-', '2=X+', '3=Y-', '4=Y+', '5=Z-', '6=Z+'/ + R0 = RR0(1) + TET0= 0.0 + DO 5 IR = 1, NR0 + IF(CELEM(IAXIS).GT.XR0(IR)) THEN + R0 = RR0(IR) + TET0= ANG(IR) + ENDIF + 5 CONTINUE + PITET0 = PIO2 - TET0 +* + IC = (ICOTE+1)/2 + IF(IC.EQ.IAXIS) CALL XABORT('TRIZNR: NOT POSSIBLE TO PROJECT CYL' + 1 //'INDERS ON THAT AXIS.') +* +* FIND THE ANGLE OF THE ELEMENT + IX= MOD(IAXIS ,3) + 1 + IY= MOD(IAXIS+1,3) + 1 + THETA = ABS(ATAN2( CELEM(IX)-CENTER(IX), CELEM(IY)-CENTER(IY) )) + IF( THETA.LE.PITET0 )THEN +* NO CORRECTION + QFR = 1.0 + QTR = 0.0 + ELSE +* CIRCULAR BOUNDARY CONDITION IS APPLIED + JC1 = 0 + CCFR0 = 0.0 + RELEM = 0.0 + DO 10 JC= 1, 3 + IF( JC.NE.IAXIS ) THEN +* CALCULATE THE RADIUS OF THE ELEMENT + RELEM= RELEM + (CENTER(JC)-CELEM(JC))**2 +* CALCULATE THE DISTANCE BETWEEN THE "JC" COORDINATES OF THE +* CENTER OF THE CYLINDER AND OF ACTUAL CYLINDRICAL BOUNDARY +* IN THE IC DIRECTION + IF( JC.NE.IC ) THEN + JC1 = 2*JC + CCFR0= (CENTER(JC) - CELEM(JC)) + ENDIF + ENDIF + 10 CONTINUE + RELEM= SQRT(RELEM) + IF((IMPX.GT.0).AND.(ABS((RELEM-R0)/R0).GT.EPSERR)) THEN + WRITE(6,1001) CELEM, THETA, RELEM, R0 + ENDIF +* +* THEN, CALCULATE +* THE DISTANCE BETWEEN THE CENTER OF THE BOUNDARY +* ELEMENT AND THE ACTUAL BOUNDARY IN THE IC DIRECTION (DELT) +* AND +* THE DIRECTION COSINE OF THE OUTWARD DIRECTED +* NORMAL AT THE ACTUAL BOUNDARY IN THE IC DIRECTION (COST) +* + DELT = (R0*R0-CCFR0*CCFR0) + IF( DELT.LT.0.0)THEN + JC = JC1/2 + WRITE(6,'(7H ICOTE=,I4,7H IAXIS=,I4)') ICOTE,IAXIS + WRITE(6,2001) AXE(JC1), CELEM(JC), AXE(JC1), CELEM(IC), + > AXE(ICOTE), R0, DELT, AXE(ICOTE), CELEM(IAXIS) + WRITE(6,2002) + DO 20 IR=1, NR0 + WRITE(6,2003) IR, XR0(IR), RR0(IR) + 20 CONTINUE + CALL XABORT('TRIZNR: ALGORITHM FAILURE.') + ENDIF + DELT = SQRT(DELT) + COST = DELT / R0 + DELT = DELT - ABS( CELEM(IC)-CENTER(IC) ) +* + QFR = COST + QTR = DELT*COST + ENDIF + RETURN +* + 1001 FORMAT( 1X,' SURFACE POINT:', 3E11.4,' ANGLE: ', F6.4, + > ' RAYON ELEMENT:', E11.4,' CYLINDRE: ', E11.4 ) + 2001 FORMAT( /1X,'*** ERREUR / REACTEUR CYLINDRIQUE ***'/ 5X, + >' LA COTE SUR L AXE ',A4,' DE L ELEMENT SITUE A',E15.6, + >' (AXE ',A4,') ET',E15.6,' (AXE ',A4,')'/5X,' EST ', + >'SUPERIEURE AU RAYON DU CYLINDRE (R0 = ',E15.6,')'/ + > 5X,' DISTANCE (DELT) :',E15.6,' A LA FRONTIERE SUR L AXE ',A4/ + > 5X,' VALEUR EN ALTITUDE:',E15.6/ + >1X,'*** IMPOSSIBLE - ARRET DE L EXECUTION ***') + 2002 FORMAT( /1X,'*** ON DONNE LES ALTITUDES ET LES RAYONS'/ + >' NREG Z(NREG) R(NREG)'/) + 2003 FORMAT(1X,I4,2X,E15.6,2X,E15.6) + END diff --git a/Trivac/src/VAL.f b/Trivac/src/VAL.f new file mode 100755 index 0000000..f3b9c19 --- /dev/null +++ b/Trivac/src/VAL.f @@ -0,0 +1,528 @@ +*DECK VAL + SUBROUTINE VAL(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Interpolate the flux distribution. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Chambon +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1): create type(L_FVIEW); +* HENTRY(2): read-only type(L_TRACK); +* HENTRY(3): read-only type(L_FLUX). +* HENTRY(4): read-only type(L_MACROLIB). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +*Comments: +* The VAL: calling specifications are: +* IFLU := VAL: TRKNAM FLUNAM :: (descval) ; +* where +* IFLU : name of the \dds{interpflux} data structure (L\_FVIEW} signature) +* where the interpolated flux distribution will be stored. +* TRKNAM : name of the read-only \dds{tracking} data structure (L\_TRACK +* signature) containing the tracking. +* FLUNAM : name of the read-only \dds{fluxunk} data structure (L\_FLUX +* signature) containing a transport solution. +* descval : structure containing the input data to this module to compute +* interpolated flux +* +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + INTEGER NSTATE + PARAMETER (NSTATE=40) + CHARACTER TEXT12*12,HSIGN*12,CMODUL*12 + INTEGER INDIC,NITMA + DOUBLE PRECISION DFLOT,ZNORM,XDRCST,EVJ + REAL FLOT + REAL DX,DY,DZ,POWER + LOGICAL L2D,L3D + INTEGER IGP(NSTATE),IFL(NSTATE),IFV(NSTATE),IMV(NSTATE),NXD,NYD, + 1 NZD,IELEM,NUN,IMPX,DIM,NG,NLF,NXI,NYI,NZI,NREG,ICHX,IDIM,ITYPE, + 2 L4,MAXKN,MKN,LC,ITYLCM,IREG,IGMAX,NMIX,NBFIS,IBM,IFISS,LENGT, + 3 LL4F,LL4X,LL4Y,ITRIAL,ICORN + INTEGER I,IG,J,K + REAL E(25) + TYPE(C_PTR) IPFVW,IPTRK,IPFLU,JPFLU,JPFVW,IPMAC,JPMAC,KPMAC +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, DIMENSION(:), ALLOCATABLE :: MAT,KFLX,KN + REAL, DIMENSION(:), ALLOCATABLE :: XX,YY,ZZ,MXD,MYD,MZD,MXI,MYI, + 1 MZI,FLXD,XXX,YYY,ZZZ,SGD,VOL + REAL, DIMENSION(:,:), ALLOCATABLE :: FXYZ + REAL, DIMENSION(:,:), ALLOCATABLE :: ZUFIS +*---- +* PARAMETER VALIDATION +*---- + IF((NENTRY.NE.3).AND.(NENTRY.NE.4)) THEN + CALL XABORT('VAL: 3 OR 4 PARAMETERS EXPECTED.') + ENDIF + IPMAC=C_NULL_PTR + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('FLD: LCM ' + 1 //'OBJECT EXPECTED AT LHS.') + IF(JENTRY(1).NE.0) CALL XABORT('VAL: ENTRY IN CREATE MODE ' + 1 //'EXPECTED.') + IPFVW=KENTRY(1) + DO I=2,NENTRY + IF(JENTRY(I).NE.2) CALL XABORT('VAL: LCM OBJECT IN READ-ONLY ' + 1 //'MODE EXPECTED AT RHS.') + CALL LCMGTC(KENTRY(I),'SIGNATURE',12,HSIGN) + IF(HSIGN.EQ.'L_FLUX') THEN + IPFLU=KENTRY(I) + ELSEIF(HSIGN.EQ.'L_TRACK') THEN + IPTRK=KENTRY(I) + CALL LCMGTC(IPTRK,'TRACK-TYPE',12,CMODUL) + ELSEIF(HSIGN.EQ.'L_MACROLIB') THEN + IPMAC=KENTRY(I) + ELSE + TEXT12=HENTRY(I) + CALL XABORT('VAL: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_FLUX, L_TRACK OR L_MACROLIB EXPECTED.') + ENDIF + ENDDO + HSIGN='L_FVIEW' + CALL LCMPTC(KENTRY(1),'SIGNATURE',12,HSIGN) + L2D=.TRUE. + L3D=.TRUE. +* + CALL LCMGET(IPFLU,'STATE-VECTOR',IFL) + NG=IFL(1) +*---- +* RECOVER GENERAL TRACKING INFORMATION +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',IGP) + NREG=IGP(1) + NUN=IGP(2) + ITYPE=IGP(6) + NLF=0 + ICHX=0 + IDIM=1 + LL4F=0 + LL4X=0 + LL4Y=0 + IGMAX=NG+1 + IF((ITYPE.EQ.5).OR.(ITYPE.EQ.6).OR.(ITYPE.EQ.8)) IDIM=2 + IF((ITYPE.EQ.7).OR.(ITYPE.EQ.9)) IDIM=3 + IF(CMODUL.EQ.'BIVAC') THEN + L3D=.FALSE. + IELEM=IGP(8) + NLF=IGP(14) + NXD=IGP(12) + NYD=IGP(13) + NZD=1 + IF(NYD.EQ.0) L2D=.FALSE. + CALL XABORT('VAL: BIVAC is currently not supported.') + ELSE IF(CMODUL.EQ.'TRIVAC') THEN + L3D=.TRUE. + IELEM=IGP(9) + L4=IGP(11) + ICHX=IGP(12) + NLF=IGP(30) + NXD=IGP(14) + NYD=IGP(15) + NZD=IGP(16) + LL4F=IGP(25) + LL4X=IGP(27) + LL4Y=IGP(28) + IGMAX=IGP(39) + IF(NYD.EQ.0) L2D=.FALSE. + IF(NZD.EQ.0) L3D=.FALSE. + NZD=MAX(1,NZD) + ENDIF +*---- +* READ INPUTS +*---- + IMPX=0 + DX=1. + DY=1. + DZ=1. + ZNORM=1.0D0 + ICORN=1 + 10 CALL REDGET(INDIC,NITMA,FLOT,TEXT12,DFLOT) + IF(INDIC.NE.3) CALL XABORT('VAL: character data expected.') + IF(TEXT12.EQ.'EDIT') THEN + CALL REDGET(INDIC,IMPX,FLOT,TEXT12,DFLOT) + IF(INDIC.NE.1) CALL XABORT('VAL: integer data expected.') + ELSE IF(TEXT12.EQ.'MODE') THEN + CALL REDGET(INDIC,NITMA,FLOT,TEXT12,DFLOT) + IF(INDIC.NE.1) CALL XABORT('VAL: integer data expected.') + JPFLU=LCMGID(IPFLU,'MODE') + IPFLU=LCMGIL(JPFLU,NITMA) + ELSE IF(TEXT12.EQ.'DIM') THEN + CALL REDGET(INDIC,DIM,FLOT,TEXT12,DFLOT) + IF((DIM.LE.0).OR.(DIM.GE.4)) CALL XABORT('VAL: 1<=DIM<=3 expec' + 1 //'ted.') + CALL REDGET(INDIC,NITMA,DX,TEXT12,DFLOT) + IF(DIM.GE.2) CALL REDGET(INDIC,NITMA,DY,TEXT12,DFLOT) + IF(DIM.EQ.3) CALL REDGET(INDIC,NITMA,DZ,TEXT12,DFLOT) + ELSE IF(TEXT12.EQ.'POWR') THEN +* NORMALIZATION TO A GIVEN FISSION POWER. + IF(.NOT.C_ASSOCIATED(IPMAC)) CALL XABORT('VAL: MISSING RHS MAC' + 1 //'ROLIB.') + CALL LCMGET(IPMAC,'STATE-VECTOR',IMV) + NMIX=IMV(2) + NBFIS=IMV(4) + ALLOCATE(MAT(NREG),KFLX(NREG),VOL(NREG),FLXD(NUN),SGD(NMIX)) + CALL LCMGET(IPTRK,'MATCOD',MAT) + CALL LCMGET(IPTRK,'KEYFLX',KFLX) + CALL LCMGET(IPTRK,'VOLUME',VOL) + CALL REDGET (INDIC,NITMA,POWER,TEXT12,DFLOT) ! power in MW + IF(INDIC.NE.2) CALL XABORT('VAL: REAL DATA EXPECTED.') +* NORMALIZATION FACTOR FOR THE DIRECT FLUX. + EVJ=XDRCST('eV','J') + ZNORM=0.0D0 + JPFLU=LCMGID(IPFLU,'FLUX') + JPMAC=LCMGID(IPMAC,'GROUP') + DO IG=1,NG + CALL LCMGDL(JPFLU,IG,FLXD) + KPMAC=LCMGIL(JPMAC,IG) + CALL LCMLEN(KPMAC,'H-FACTOR',LENGT,ITYLCM) + IF(LENGT.GT.0) THEN + CALL LCMGET(KPMAC,'H-FACTOR',SGD) + ELSE + ! assume 2.5 n and 200 MeV per fission + WRITE(6,'(/44H VAL: *** WARNING *** NO H-FACTOR FOUND ON L, + 1 24HCM. USE NU*SIGF INSTEAD.)') + ALLOCATE(ZUFIS(NMIX,NBFIS)) + SGD(:NMIX)=0.0 + CALL LCMGET(KPMAC,'NUSIGF',ZUFIS) + DO IBM=1,NMIX + DO IFISS=1,NBFIS + SGD(IBM)=SGD(IBM)+ZUFIS(IBM,IFISS)*2.0E8/2.5 + ENDDO + ENDDO + DEALLOCATE(ZUFIS) + ENDIF + DO 20 K=1,NREG + IBM=MAT(K) + IF((IBM.EQ.0).OR.(KFLX(K).EQ.0)) GO TO 20 + ZNORM=ZNORM+FLXD(KFLX(K))*VOL(K)*SGD(IBM)*EVJ + 20 CONTINUE + ENDDO + ZNORM=POWER*1.0D6/ZNORM + WRITE(6,300) ' DIRECT',ZNORM + DEALLOCATE(SGD,FLXD,VOL,KFLX,MAT) + ELSE IF(TEXT12.EQ.'NOCCOR') THEN + ICORN=0 + ELSE IF(TEXT12.EQ.'CCOR') THEN + ICORN=1 + ELSE IF(TEXT12.EQ.';') THEN + GO TO 30 + ELSE + CALL XABORT('VAL: unknownn keyword-->'//TEXT12) + ENDIF + GO TO 10 +*---- +* Get Data in L_TRACK +*---- + 30 ALLOCATE(MAT(NREG),KFLX(NREG)) + CALL LCMGET(IPTRK,'MATCOD',MAT) + CALL LCMGET(IPTRK,'KEYFLX',KFLX) + ALLOCATE(MXD(NXD+1),MYD(NYD+1),MZD(NZD+1)) + ALLOCATE(XX(NREG),YY(NREG),ZZ(NREG)) + CALL LCMGET(IPTRK,'XX',XX) + IF(L2D) CALL LCMGET(IPTRK,'YY',YY) + IF(L3D) CALL LCMGET(IPTRK,'ZZ',ZZ) +*---- +* Compute X and Y mesh from L_TRACK +*---- + ALLOCATE(XXX(NXD),YYY(NYD)) + XXX(:NXD)=0.0 + YYY(:NYD)=0.0 + IREG=0 + IF(L3D) THEN + ALLOCATE(ZZZ(NZD)) + ZZZ(:NZD)=0.0 + DO K=1,NZD + DO J=1,NYD + DO I=1,NXD + IREG=IREG+1 + IF(XX(IREG).NE.0.0) THEN + IF(XXX(I).EQ.0.0) THEN + XXX(I)=XX(IREG) + ELSE IF(ABS(XXX(I)-XX(IREG)).GT.1.0E-6) THEN + CALL XABORT('VAL: inconsistent tracking in X') + ENDIF + ENDIF + IF(YY(IREG).NE.0.0) THEN + IF(YYY(J).EQ.0.0) THEN + YYY(J)=YY(IREG) + ELSE IF(ABS(YYY(J)-YY(IREG)).GT.1.0E-6) THEN + CALL XABORT('VAL: inconsistent tracking in Y') + ENDIF + ENDIF + IF(ZZ(IREG).NE.0.0) THEN + IF(ZZZ(K).EQ.0.0) THEN + ZZZ(K)=ZZ(IREG) + ELSE IF(ABS(ZZZ(K)-ZZ(IREG)).GT.1.0E-6) THEN + CALL XABORT('VAL: inconsistent tracking in Z') + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + ELSE IF(L2D) THEN + DO J=1,NYD + DO I=1,NXD + IREG=IREG+1 + IF(XX(IREG).NE.0.0) THEN + IF(XXX(I).EQ.0.0) THEN + XXX(I)=XX(IREG) + ELSE IF(ABS(XXX(I)-XX(IREG)).GT.1.0E-6) THEN + CALL XABORT('VAL: inconsistent tracking in X') + ENDIF + ENDIF + IF(YY(IREG).NE.0.0) THEN + IF(YYY(J).EQ.0.0) THEN + YYY(J)=YY(IREG) + ELSE IF(ABS(YYY(J)-YY(IREG)).GT.1.0E-6) THEN + CALL XABORT('VAL: inconsistent tracking in Y') + ENDIF + ENDIF + ENDDO + ENDDO + ELSE + DO I=1,NXD + IREG=IREG+1 + IF(XX(IREG).NE.0.0) THEN + IF(XXX(I).EQ.0.0) THEN + XXX(I)=XX(IREG) + ELSE IF(ABS(XXX(I)-XX(IREG)).GT.1.0E-6) THEN + CALL XABORT('VAL: inconsistent tracking in X') + ENDIF + ENDIF + ENDDO + ENDIF + IF(IREG.NE.NREG) CALL XABORT('VAL: invalid tracking') + MXD(1)=0.0 + MYD(1)=0.0 + MZD(1)=0.0 + DO I=1,NXD + MXD(I+1)=MXD(I)+XXX(I) + ENDDO + IF(L2D) THEN + MYD(1)=0.0 + DO I=1,NYD + MYD(I+1)=MYD(I)+YYY(I) + ENDDO + ELSE + MYD(2)=0.0 + ENDIF + MZD(1)=0.0 + IF(L3D) THEN + DO I=1,NZD + MZD(I+1)=MZD(I)+ZZZ(I) + ENDDO + DEALLOCATE(ZZZ) + ELSE + MZD(2)=0.0 + ENDIF + DEALLOCATE(YYY,XXX) +*---- +* Perform interpolation +*---- +* Compute points to interpolate + NXI=INT((MXD(NXD+1)-MXD(1))/DX)+1 + NYI=INT((MYD(NYD+1)-MYD(1))/DY)+1 + NZI=INT((MZD(NZD+1)-MZD(1))/DZ)+1 + ALLOCATE(MXI(NXI),MYI(NYI),MZI(NZI)) + ALLOCATE(FXYZ(NXI*NYI*NZI,NG)) + DO I=1,NXI + MXI(I)=MXD(1)+DX*REAL(I-1) + ENDDO + DO I=1,NYI + MYI(I)=MYD(1)+DY*REAL(I-1) + ENDDO + DO I=1,NZI + MZI(I)=MZD(1)+DZ*REAL(I-1) + ENDDO + JPFLU=LCMGID(IPFLU,'FLUX') +* Get Data in L_FLUX + ALLOCATE(FLXD(NUN)) + IF((ICHX.EQ.4).OR.(ICHX.EQ.5).OR.(ICHX.EQ.6)) THEN +* recover removal xs and diffusion coefficients in JPMAC + IF(.NOT.C_ASSOCIATED(IPMAC)) CALL XABORT('VAL: MISSING RHS MAC' + 1 //'ROLIB.') + CALL LCMGET(IPMAC,'STATE-VECTOR',IMV) + NMIX=IMV(2) + JPMAC=LCMGID(IPMAC,'GROUP') + ENDIF + DO IG=1,NG + CALL LCMGDL(JPFLU,IG,FLXD) +* Perform normalization + DO I=1,NUN + FLXD(I)=FLXD(I)*REAL(ZNORM) + ENDDO +* Perform interpolation + IF(L3D) THEN + IF(ICHX.EQ.1) THEN +* Variational collocation method + CALL LCMLEN(IPTRK,'KN',MAXKN,ITYLCM) + MKN=MAXKN/(NXD*NYD*NZD) + ALLOCATE(KN(MAXKN)) + CALL LCMGET(IPTRK,'KN',KN) + CALL LCMSIX(IPTRK,'BIVCOL',1) + CALL LCMLEN(IPTRK,'T',LC,ITYLCM) + CALL LCMGET(IPTRK,'E',E) + CALL LCMSIX(IPTRK,' ',2) + CALL VALUE2(LC,MKN,NXD,NYD,NZD,L4,MXI,MYI,MZI,MXD,MYD,MZD, + 1 FLXD,MAT,KN,NXI,NYI,NZI,E,FXYZ(1,IG)) + DEALLOCATE(KN) + ELSE IF(ICHX.EQ.2) THEN +* Raviart-Thomas finite element method + CALL VALUE4(IELEM,NUN,NXD,NYD,NZD,MXI,MYI,MZI,MXD,MYD,MZD, + 1 FLXD,MAT,KFLX,NXI,NYI,NZI,FXYZ(1,IG)) + ELSE IF(ICHX.EQ.3) THEN +* Nodal collocation method (MCFD) + CALL VALUE1(IDIM,NXD,NYD,NZD,L4,MXI,MYI,MZI,MXD,MYD,MZD, + 1 FLXD,MAT,IELEM,NXI,NYI,NZI,FXYZ(1,IG)) + ELSE IF(ICHX.EQ.6) THEN +* Analytic nodal method (ANM) + IF(IMPX.GT.0) WRITE(6,320) ICORN + CALL LCMLEN(IPTRK,'KN',MAXKN,ITYLCM) + ALLOCATE(KN(MAXKN)) + CALL LCMGET(IPTRK,'KN',KN) + KPMAC=LCMGIL(JPMAC,IG) + CALL VALU5(KPMAC,NXD,NYD,NZD,LL4F,LL4X,LL4Y,NUN,NMIX,MXI, + 1 MYI,MZI,MXD,MYD,MZD,FLXD,MAT,KFLX,KN,NXI,NYI,NZI,ICORN, + 2 FXYZ(1,IG)) + DEALLOCATE(KN) + ELSE + CALL XABORT('VAL: INTERPOLATION NOT IMPLEMENTED(1).') + ENDIF + ELSE IF(L2D) THEN + IF(ICHX.EQ.1) THEN +* Variational collocation method + CALL LCMLEN(IPTRK,'KN',MAXKN,ITYLCM) + MKN=MAXKN/(NXD*NYD) + ALLOCATE(KN(MAXKN)) + CALL LCMGET(IPTRK,'KN',KN) + CALL LCMSIX(IPTRK,'BIVCOL',1) + CALL LCMLEN(IPTRK,'T',LC,ITYLCM) + CALL LCMGET(IPTRK,'E',E) + CALL LCMSIX(IPTRK,' ',2) + CALL VALU2B(LC,MKN,NXD,NYD,L4,MXI,MYI,MXD,MYD,FLXD,MAT,KN, + 1 NXI,NYI,E,FXYZ(1,IG)) + ELSE IF(ICHX.EQ.2) THEN +* Raviart-Thomas finite element method + CALL VALU4B(IELEM,NUN,NXD,NYD,MXI,MYI,MXD,MYD,FLXD,MAT, + 1 KFLX,NXI,NYI,FXYZ(1,IG)) + ELSE IF(ICHX.EQ.3) THEN +* Nodal collocation method (MCFD) + CALL VALU1B(IDIM,NXD,NYD,L4,MXI,MYI,MXD,MYD,FLXD,MAT,IELEM, + 1 NXI,NYI,FXYZ(1,IG)) + ELSE IF(ICHX.EQ.6) THEN +* Analytic nodal method (ANM) + IF(IMPX.GT.0) WRITE(6,320) ICORN + CALL LCMLEN(IPTRK,'KN',MAXKN,ITYLCM) + ALLOCATE(KN(MAXKN)) + CALL LCMGET(IPTRK,'KN',KN) + KPMAC=LCMGIL(JPMAC,IG) + CALL VALU5B(KPMAC,NXD,NYD,LL4F,LL4X,NUN,NMIX,MXI,MYI,MXD, + 1 MYD,FLXD,MAT,KFLX,KN,NXI,NYI,ICORN,FXYZ(1,IG)) + DEALLOCATE(KN) + ELSE + CALL XABORT('VAL: INTERPOLATION NOT IMPLEMENTED(2).') + ENDIF + ELSE + IF(ICHX.EQ.4) THEN +* Coarse mesh finite differences + KPMAC=LCMGIL(JPMAC,IG) + ITRIAL=0 + CALL VALU5C(KPMAC,NXD,L4,NMIX,MXI,MXD,FLXD,MAT,NXI,ITRIAL, + 1 FXYZ(1,IG)) + ELSE IF((ICHX.EQ.5).OR.(ICHX.EQ.6)) THEN +* Nodal expansion method (NEM) or analytic nodal method (ANM) + KPMAC=LCMGIL(JPMAC,IG) + ITRIAL=1 + IF((ICHX.EQ.5).AND.(IG.GE.IGMAX)) ITRIAL=2 + CALL VALU5C(KPMAC,NXD,NUN,NMIX,MXI,MXD,FLXD,MAT,NXI,ITRIAL, + 1 FXYZ(1,IG)) + ELSE + CALL XABORT('VAL: INTERPOLATION NOT IMPLEMENTED(3).') + ENDIF + ENDIF + ENDDO +*---- +* Save results +*---- + CALL LCMPUT(IPFVW,'MXI',NXI,2,MXI) + IF(L2D) CALL LCMPUT(IPFVW,'MYI',NYI,2,MYI) + IF(L3D) CALL LCMPUT(IPFVW,'MZI',NZI,2,MZI) + IFV(:NSTATE)=0 + IFV(1)=NG + IFV(2)=NXI + IFV(3)=NYI + IFV(4)=NZI + CALL LCMPUT(IPFVW,'STATE-VECTOR',NSTATE,1,IFV) + JPFVW=LCMLID(IPFVW,'FLUX',NG) + DO IG=1,NG + CALL LCMPDL(JPFVW,IG,NXI*NYI*NZI,2,FXYZ(1,IG)) + ENDDO +*---- +* Save results +*---- + IF(IMPX.GE.1)THEN + WRITE(6,*) 'Mesh along X-direction' + WRITE(6,310) (MXI(I),I=1,NXI) + WRITE(6,*) 'Mesh along Y-direction' + WRITE(6,310) (MYI(I),I=1,NYI) + WRITE(6,*) 'Mesh along Z-direction' + WRITE(6,310) (MZI(I),I=1,NZI) + IF(IMPX.GE.2)THEN + WRITE(6,*) 'Flux distribution:' + DO IG=1,NG + WRITE(6,*) 'Group',IG + DO K=1,NZI + WRITE(6,*) 'Plane',K + DO J=1,NYI + WRITE(6,310) (FXYZ(I+(J-1+(K-1)*NYI)*NXI,IG),I=1,NXI) + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF +*---- +* RELEASE GENERAL TRACKING INFORMATION +*---- + DEALLOCATE(FLXD) + DEALLOCATE(FXYZ) + DEALLOCATE(MXI,MYI,MZI) + DEALLOCATE(MXD,MYD,MZD) + DEALLOCATE(XX,YY,ZZ) + DEALLOCATE(KFLX,MAT) + RETURN + 300 FORMAT(/6H VAL: ,A7,28H FLUX NORMALIZATION FACTOR =,1P,E13.5) + 310 FORMAT(1X,1P,12E12.4) + 320 FORMAT(/43H VAL: CORNER FLUX CORRECTION (0/1: OFF/ON)=,I3) + END diff --git a/Trivac/src/VALPL.f b/Trivac/src/VALPL.f new file mode 100755 index 0000000..b66cb78 --- /dev/null +++ b/Trivac/src/VALPL.f @@ -0,0 +1,35 @@ +*DECK VALPL + FUNCTION VALPL(L,U) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Return the Legendre function coefficients for the nodal collocation +* method. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* L order of the Legendre polynomial. +* U indemendent variable. +* +*---------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + IF (L.EQ.0) P=1.0 + IF (L.EQ.1) P=2.0*U + IF (L.EQ.2) P=(6.0*U*U-0.5) + IF (L.EQ.3) P=(20.0*U*U-3.0)*U + IF (L.EQ.4) P=(U*U*(70.0*U*U-15.0)+0.375) + VALPL=SQRT(REAL(2*L+1))*P + RETURN + END diff --git a/Trivac/src/VALU1B.f b/Trivac/src/VALU1B.f new file mode 100755 index 0000000..c5f7bd9 --- /dev/null +++ b/Trivac/src/VALU1B.f @@ -0,0 +1,102 @@ +*DECK VALU1B + SUBROUTINE VALU1B (IDIM,LX,LY,L4,X,Y,XXX,YYY,EVT,ISS,IELEM,IXLG, + + IYLG,AXY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Interpolate the flux distribution for MCFD method in 2D. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IDIM number of dimensions (1 or 2). +* LX number of elements along the X axis. +* LY number of elements along the Y axis. +* L4 dimension of unknown array EVT. +* X Cartesian coordinates along the X axis where the flux is +* interpolated. +* Y Cartesian coordinates along the Y axis where the flux is +* interpolated. +* XXX Cartesian coordinates along the X axis. +* YYY Cartesian coordinates along the Y axis. +* EVT variational coefficients of the flux. +* ISS mixture index assigned to each element. +* IELEM MCFD polynomial order (IELEM=1 is the mesh centered finite +* difference method). +* IXLG number of interpolated points according to X. +* IYLG number of interpolated points according to Y. +* +*Parameters: output +* AXY interpolated fluxes. +* +*---------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IDIM,LX,LY,L4,ISS(LX*LY),IELEM,IXLG,IYLG + REAL X(IXLG),Y(IYLG),XXX(LX+1),YYY(LY+1),EVT(L4),AXY(IXLG,IYLG) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IWRK +*---- +* Scratch storage allocation +*---- + ALLOCATE(IWRK(LX*LY)) +* + NUM=0 + DO 10 K=1,LX*LY + IF (ISS(K).EQ.0) GO TO 10 + NUM=NUM+1 + IWRK(K)=NUM + 10 CONTINUE +* + LL4=L4/IELEM**(IDIM-1) + DO 120 J=1,IYLG + ORDO=Y(J) + DO 110 I=1,IXLG + ABSC=X(I) + GAR=0.0 +* +* Find the finite element index containing the interpolation point + IS=0 + JS=0 + DO 20 L=1,LX + IS=L + IF((ABSC.GE.XXX(L)).AND.(ABSC.LE.XXX(L+1))) GO TO 30 + 20 CONTINUE + CALL XABORT('VALU1B: WRONG INTERPOLATION(1).') + 30 DO 40 L=1,LY + JS=L + IF((ORDO.GE.YYY(L)).AND.(ORDO.LE.YYY(L+1))) GO TO 70 + 40 CONTINUE + CALL XABORT('VALU1B: WRONG INTERPOLATION(2).') + 70 IEL=(JS-1)*LX+IS + IF(ISS(IEL).EQ.0) GO TO 100 + U=(ABSC-0.5*(XXX(IS)+XXX(IS+1)))/(XXX(IS+1)-XXX(IS)) + V=(ORDO-0.5*(YYY(JS)+YYY(JS+1)))/(YYY(JS+1)-YYY(JS)) + L=1+IELEM*(IWRK(IEL)-1) + DO 90 N2=0,IELEM-1 + DO 80 N1=0,IELEM-1 + GAR=GAR+VALPL(N1,U)*VALPL(N2,V)*EVT(LL4*N2+N1+L) + 80 CONTINUE + IF ((IDIM.EQ.1).AND.(N2.EQ.0)) GO TO 100 + 90 CONTINUE + 100 AXY(I,J)=GAR + 110 CONTINUE + 120 CONTINUE +*---- +* Scratch storage deallocation +*---- + DEALLOCATE(IWRK) + RETURN + END diff --git a/Trivac/src/VALU2B.f b/Trivac/src/VALU2B.f new file mode 100755 index 0000000..a14d1b6 --- /dev/null +++ b/Trivac/src/VALU2B.f @@ -0,0 +1,148 @@ +*DECK VALU2B + SUBROUTINE VALU2B (LC,MKN,LX,LY,L4,X,Y,XXX,YYY,EVECT,ISS,KN,IXLG, + + IYLG,E,AXY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Interpolate the flux distribution for PRIM method in 2D. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* LC order of the unit matrices. +* MKN second dimension for matrix KN. +* LX number of elements along the X axis. +* LY number of elements along the Y axis. +* L4 dimension of unknown array EVECT. +* X Cartesian coordinates along the X axis where the flux is +* interpolated. +* Y Cartesian coordinates along the Y axis where the flux is +* interpolated. +* XXX Cartesian coordinates along the X axis. +* YYY Cartesian coordinates along the Y axis. +* EVECT variational coefficients of the flux. +* ISS mixture index assigned to each element. +* KN element-ordered unknown list. +* IELEM MCFD polynomial order (IELEM=1 is the mesh centered finite +* difference method). +* IXLG number of interpolated points according to X. +* IYLG number of interpolated points according to Y. +* E Lagrange polynomial coefficients. +* +*Parameters: output +* AXY interpolated fluxes. +* +*---------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER LC,MKN,LX,LY,L4,ISS(LX*LY),KN(LX*LY*MKN),IXLG,IYLG + REAL X(IXLG),Y(IYLG),XXX(LX+1),YYY(LY+1),EVECT(L4),AXY(IXLG,IYLG), + 1 E(LC,LC) +*---- +* LOCAL VARIABLES +*---- + INTEGER IJ1(125),IJ2(125) + REAL FLX(5),FLY(5) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IWRK + REAL, ALLOCATABLE, DIMENSION(:,:) ::COEF +*---- +* Scratch storage allocation +*---- + ALLOCATE(IWRK(LX*LY),COEF(LX*LY,MKN)) +*---- +* Calculation of IJ integer arrays +*---- + LL=LC*LC + DO 5 L=1,LL + L1=1+MOD(L-1,LC) + L2=1+(L-L1)/LC + L3=1+MOD(L2-1,LC) + IJ1(L)=L1 + IJ2(L)=L3 + 5 CONTINUE +* + NUM=0 + DO 10 I=1,LX*LY + IWRK(I)=0 + IF (ISS(I).EQ.0) GO TO 10 + IWRK(I)=NUM + NUM=NUM+1 + 10 CONTINUE +* + DO 110 J=1,IYLG + ORDO=Y(J) + DO 100 I=1,IXLG + ABSC=X(I) + AXY(I,J)=0.0 +* +* Find the finite element index containing the interpolation point + IS=0 + JS=0 + DO 20 L=1,LX + IS=L + IF((ABSC.GE.XXX(L)).AND.(ABSC.LE.XXX(L+1))) GO TO 30 + 20 CONTINUE + CALL XABORT('VALU2B: WRONG INTERPOLATION(1).') + 30 DO 40 L=1,LY + JS=L + IF((ORDO.GE.YYY(L)).AND.(ORDO.LE.YYY(L+1))) GO TO 70 + 40 CONTINUE + CALL XABORT('VALU2B: WRONG INTERPOLATION(2).') + 70 IEL=(JS-1)*LX+IS +* + IF(ISS(IEL).EQ.0) GO TO 100 + NUM=IWRK(IEL) + IF (NUM.NE.-1) THEN + DO 85 M=1,LL + I1=IJ1(M) + I2=IJ2(M) + COEF(IEL,M)=0.0 + DO 80 N=1,LL + IND2=KN(LL*NUM+N) + IF (IND2.EQ.0) GO TO 80 + J1=IJ1(N) + J2=IJ2(N) + COEF(IEL,M)=COEF(IEL,M)+E(I1,J1)*E(I2,J2)*EVECT(IND2) + 80 CONTINUE + 85 CONTINUE + IWRK(IEL)=-1 + ENDIF +* + U=(ABSC-0.5*(XXX(IS)+XXX(IS+1)))/(XXX(IS+1)-XXX(IS)) + FLX(1)=1.0 + FLX(2)=FLX(1)*U + FLX(3)=FLX(2)*U + FLX(4)=FLX(3)*U + FLX(5)=FLX(4)*U + V=(ORDO-0.5*(YYY(JS)+YYY(JS+1)))/(YYY(JS+1)-YYY(JS)) + FLY(1)=1.0 + FLY(2)=FLY(1)*V + FLY(3)=FLY(2)*V + FLY(4)=FLY(3)*V + FLY(5)=FLY(4)*V + DO 90 L=1,LL + I1=IJ1(L) + I2=IJ2(L) + AXY(I,J)=AXY(I,J)+COEF(IEL,L)*FLX(I1)*FLY(I2) + 90 CONTINUE + 100 CONTINUE + 110 CONTINUE +*---- +* Scratch storage deallocation +*---- + DEALLOCATE(COEF,IWRK) + RETURN + END diff --git a/Trivac/src/VALU4B.f b/Trivac/src/VALU4B.f new file mode 100755 index 0000000..f2e4edf --- /dev/null +++ b/Trivac/src/VALU4B.f @@ -0,0 +1,115 @@ +*DECK VALU4B + SUBROUTINE VALU4B(IELEM,NUN,LX,LY,X,Y,XXX,YYY,EVECT,ISS,KFLX, + + IXLG,IYLG,AXY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Interpolate the flux distribution for DUAL method in 2D. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Chambon +* +*Parameters: input +* IELEM finite element order +* =1 : linear Raviart-Thomas +* =2 : parabolic Raviart-Thomas +* =3 : cubic Raviart-Thomas +* =4 : quartic Raviart-Thomas +* NUN number of unknowns +* LX number of elements along the X axis. +* LY number of elements along the Y axis. +* X Cartesian coordinates along the X axis where the flux is +* interpolated. +* Y Cartesian coordinates along the Y axis where the flux is +* interpolated. +* XXX Cartesian coordinates along the X axis. +* YYY Cartesian coordinates along the Y axis. +* EVECT variational coefficients of the flux. +* ISS mixture index assigned to each element. +* KFLX correspondence between local and global numbering. +* IXLG number of interpolated points according to X. +* IYLG number of interpolated points according to Y. +* +*Parameters: output +* AXY interpolated fluxes. +* +*---------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IELEM,NUN,LX,LY,IXLG,IYLG,ISS(LX*LY),KFLX(LX*LY) + REAL X(IXLG),Y(IYLG),XXX(LX+1),YYY(LY+1),EVECT(NUN),AXY(IXLG,IYLG) +*---- +* LOCAL VARIABLES +*---- + INTEGER I,J,L,IS,JS,IEL,I1,I2,IE + REAL ORDO,ABSC,COEF(2,5),FLX(5),FLY(5) + REAL U,V +*---- +* compute coefficient for legendre polynomials +*---- + COEF(:2,:5)=0.0 + COEF(1,1)=1.0 + COEF(1,2)=2.*3.**0.5 + DO IE=1,3 + COEF(1,IE+2)=2.0*REAL(2*IE+1)/REAL(IE+1) + 1 *(REAL(2*IE+3)/REAL(2*IE+1))**0.5 + COEF(2,IE+2)=REAL(IE)/REAL(IE+1) + 1 *(REAL(2*IE+3)/REAL(2*IE-1))**0.5 + ENDDO +*---- +* perform interpolation +*---- + DO 105 J=1,IYLG + ORDO=Y(J) + DO 100 I=1,IXLG + ABSC=X(I) + AXY(I,J)=0.0 +* +* Find the finite element index containing the interpolation point + IS=0 + JS=0 + DO 20 L=1,LX + IS=L + IF((ABSC.GE.XXX(L)).AND.(ABSC.LE.XXX(L+1))) GO TO 30 + 20 CONTINUE + CALL XABORT('VALU4B: WRONG INTERPOLATION(1).') + 30 DO 40 L=1,LY + JS=L + IF((ORDO.GE.YYY(L)).AND.(ORDO.LE.YYY(L+1))) GO TO 70 + 40 CONTINUE + CALL XABORT('VALU4B: WRONG INTERPOLATION(2).') + 70 IEL=(JS-1)*LX+IS +* + IF(ISS(IEL).EQ.0) GO TO 100 + U=(ABSC-0.5*(XXX(IS)+XXX(IS+1)))/(XXX(IS+1)-XXX(IS)) + FLX(1)=COEF(1,1) + FLX(2)=COEF(1,2)*U + V=(ORDO-0.5*(YYY(JS)+YYY(JS+1)))/(YYY(JS+1)-YYY(JS)) + FLY(1)=COEF(1,1) + FLY(2)=COEF(1,2)*V + IF(IELEM.GE.2) THEN + DO IE=2,IELEM + FLX(IE+1)=FLX(IE)*U*COEF(1,IE+1)-FLX(IE-1)*COEF(2,IE+1) + FLY(IE+1)=FLY(IE)*V*COEF(1,IE+1)-FLY(IE-1)*COEF(2,IE+1) + ENDDO + ENDIF + DO 92 I2=1,IELEM + DO 91 I1=1,IELEM + L=(I2-1)*(IELEM)+I1 + AXY(I,J)=AXY(I,J)+EVECT(KFLX(IEL)+L-1)*FLX(I1)*FLY(I2) + 91 CONTINUE + 92 CONTINUE + 100 CONTINUE + 105 CONTINUE + RETURN + END diff --git a/Trivac/src/VALU5.f b/Trivac/src/VALU5.f new file mode 100755 index 0000000..aae6f7a --- /dev/null +++ b/Trivac/src/VALU5.f @@ -0,0 +1,672 @@ +*DECK VALU5 + SUBROUTINE VALU5 (KPMAC,NX,NY,NZ,LL4F,LL4X,LL4Y,NUN,NMIX,X,Y,Z, + 1 XXX,YYY,ZZZ,EVT,ISS,KFLX,KN,IXLG,IYLG,IZLG,ICORN,AXYZ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Interpolation of the flux distribution for nodal method in 3D. +* +*Copyright: +* Copyright (C) 2021 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* KPMAC group directory in the macrolib. +* NX number of elements along the X axis. +* NY number of elements along the Y axis. +* NY number of elements along the Z axis. +* LL4F number of averaged flux unknowns. +* LL4X number of X-directed net currents. +* LL4Y number of Y-directed net currents. +* NUN dimension of unknown array EVT. +* NMIX number of mixtures. +* X Cartesian coordinates along the X axis where the flux is +* interpolated. +* Y Cartesian coordinates along the Y axis where the flux is +* interpolated. +* Z Cartesian coordinates along the Z axis where the flux is +* interpolated. +* XXX Cartesian coordinates along the X axis. +* YYY Cartesian coordinates along the Y axis. +* ZZZ Cartesian coordinates along the Z axis. +* EVT reconstruction coefficients of the flux. +* ISS mixture index assigned to each element. +* KFLX correspondence between local and global numbering. +* KN element-ordered interface net current unknown list. +* IXLG number of interpolated points according to X. +* IYLG number of interpolated points according to Y. +* IZLG number of interpolated points according to Z. +* ICORN flag to activate corner flux correction (0/1: ON/OFF). +* +*Parameters: output +* AXYZ interpolated fluxes. +* +*---------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) KPMAC + INTEGER NX,NY,NZ,LL4F,LL4X,LL4Y,NUN,NMIX,ISS(NX*NY*NZ), + 1 KFLX(NX*NY*NZ),KN(6,NX,NY,NZ),IXLG,IYLG,IZLG,ICORN + REAL X(IXLG),Y(IYLG),Z(IZLG),XXX(NX+1),YYY(NY+1),ZZZ(NZ+1), + 1 EVT(NUN),AXYZ(IXLG,IYLG,IZLG) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION WORK1(4,5),FC2(8) + DOUBLE PRECISION GAR,COEFX,COEFY,COEFZ,U,V,W,P2U,P2V,P2W + LOGICAL LOGC1,LOGC2,LOGC3 +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: DIFF + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:) :: FCORN,DELC +*---- +* RECOVER DIFFUSION COEFFICIENTS +*---- + ALLOCATE(DIFF(NMIX)) + CALL LCMGET(KPMAC,'DIFF',DIFF) +*---- +* COMPUTE CORNER FLUXES +*---- + ALLOCATE(DELC(8,NX,NY,NZ)) + DELC(:8,:NX,:NY,:NZ)=0.D0 + IOFY=7*LL4F+LL4X + IOFZ=7*LL4F+LL4X+LL4Y + IF(ICORN==1) THEN + ALLOCATE(FCORN(8,NX,NY,NZ)) + FCORN(:8,:NX,:NY,:NZ)=0.D0 + DO KS=1,NZ + DO JS=1,NY + DO IS=1,NX + IEL=(KS-1)*NX*NY+(JS-1)*NX+IS + IND1=KFLX(IEL) + IF(IND1.EQ.0) CYCLE + IBM=ISS(IEL) + IF(IBM.LE.0) CYCLE + JXM=KN(1,IS,JS,KS) ; JXP=KN(2,IS,JS,KS) + JYM=KN(3,IS,JS,KS) ; JYP=KN(4,IS,JS,KS) + JZM=KN(5,IS,JS,KS) ; JZP=KN(6,IS,JS,KS) + COEFX=DIFF(IBM)/(XXX(IS+1)-XXX(IS)) + COEFY=DIFF(IBM)/(YYY(JS+1)-YYY(JS)) + COEFZ=DIFF(IBM)/(ZZZ(KS+1)-ZZZ(KS)) +* + WORK1(:,:)=0.0 + WORK1(1,1)=-0.5 + WORK1(1,2)=0.5 + WORK1(1,5)=EVT(LL4F+IND1)-EVT(IND1) + WORK1(2,1)=0.5 + WORK1(2,2)=0.5 + WORK1(2,5)=EVT(2*LL4F+IND1)-EVT(IND1) + WORK1(3,1)=-COEFX + WORK1(3,2)=3.0*COEFX + IF(JXM.NE.0) WORK1(3,5)=EVT(7*LL4F+JXM) + WORK1(4,1)=-COEFX + WORK1(4,2)=-3.0*COEFX + IF(JXP.NE.0) WORK1(4,5)=EVT(7*LL4F+JXP) + WORK1(3,3)=-0.5*COEFX + WORK1(3,4)=0.2*COEFX + WORK1(4,3)=-0.5*COEFX + WORK1(4,4)=-0.2*COEFX + CALL ALSBD(4,1,WORK1,IER,4) + IF(IER.NE.0) CALL XABORT('VALU5: SINGULAR MATRIX(1).') + DO IC=1,8 + SELECT CASE(IC) + CASE(1,3,5,7) + U=-0.5 + CASE DEFAULT + U=0.5 + END SELECT + GAR=EVT(IND1)+WORK1(1,5)*U+WORK1(2,5)*(3.0*U**2-0.25) + GAR=GAR+WORK1(3,5)*(U**2-0.25)*U+WORK1(4,5)*(U**2-0.25)* + 1 (U**2-0.05) + FCORN(IC,IS,JS,KS)=GAR + ENDDO +* + WORK1(:,:)=0.0 + WORK1(1,1)=-0.5 + WORK1(1,2)=0.5 + WORK1(1,5)=EVT(3*LL4F+IND1)-EVT(IND1) + WORK1(2,1)=0.5 + WORK1(2,2)=0.5 + WORK1(2,5)=EVT(4*LL4F+IND1)-EVT(IND1) + WORK1(3,1)=-COEFY + WORK1(3,2)=3.0*COEFY + IF(JYM.NE.0) WORK1(3,5)=EVT(IOFY+JYM) + WORK1(4,1)=-COEFY + WORK1(4,2)=-3.0*COEFY + IF(JYP.NE.0) WORK1(4,5)=EVT(IOFY+JYP) + WORK1(3,3)=-0.5*COEFY + WORK1(3,4)=0.2*COEFY + WORK1(4,3)=-0.5*COEFY + WORK1(4,4)=-0.2*COEFY + CALL ALSBD(4,1,WORK1,IER,4) + IF(IER.NE.0) CALL XABORT('VALU5: SINGULAR MATRIX(2).') + DO IC=1,8 + SELECT CASE(IC) + CASE(1,2,5,6) + V=-0.5 + CASE DEFAULT + V=0.5 + END SELECT + GAR=FCORN(IC,IS,JS,KS)+WORK1(1,5)*V+WORK1(2,5)* + 1 (3.0*V**2-0.25) + GAR=GAR+WORK1(3,5)*(V**2-0.25)*V+WORK1(4,5)*(V**2-0.25)* + 1 (V**2-0.05) + FCORN(IC,IS,JS,KS)=GAR + ENDDO +* + WORK1(:,:)=0.0 + WORK1(1,1)=-0.5 + WORK1(1,2)=0.5 + WORK1(1,5)=EVT(7*LL4F+IND1)-EVT(IND1) + WORK1(2,1)=0.5 + WORK1(2,2)=0.5 + WORK1(2,5)=EVT(6*LL4F+IND1)-EVT(IND1) + WORK1(3,1)=-COEFZ + WORK1(3,2)=3.0*COEFZ + IF(JZM.NE.0) WORK1(3,5)=EVT(IOFZ+JZM) + WORK1(4,1)=-COEFZ + WORK1(4,2)=-3.0*COEFZ + IF(JZP.NE.0) WORK1(4,5)=EVT(IOFZ+JZP) + WORK1(3,3)=-0.5*COEFZ + WORK1(3,4)=0.2*COEFZ + WORK1(4,3)=-0.5*COEFZ + WORK1(4,4)=-0.2*COEFZ + CALL ALSBD(4,1,WORK1,IER,4) + IF(IER.NE.0) CALL XABORT('VALU5: SINGULAR MATRIX(3).') + DO IC=1,8 + SELECT CASE(IC) + CASE(1,2,3,4) + W=-0.5 + CASE DEFAULT + W=0.5 + END SELECT + GAR=FCORN(IC,IS,JS,KS)+WORK1(1,5)*W+WORK1(2,5)* + 1 (3.0*W**2-0.25) + GAR=GAR+WORK1(3,5)*(W**2-0.25)*W+WORK1(4,5)*(W**2-0.25)* + 1 (W**2-0.05) + FCORN(IC,IS,JS,KS)=GAR + ENDDO + ENDDO + ENDDO + ENDDO + DO KS=1,NZ + DO JS=1,NY + DO IS=1,NX + IEL=(KS-1)*NX*NY+(JS-1)*NX+IS + IND1=KFLX(IEL) + IF(IND1.EQ.0) CYCLE + ! corner 1 + NB=1 ; GAR=FCORN(1,IS,JS,KS) + LOGC1=(IS>1) ; LOGC2=(JS>1) ; LOGC3=(KS>1) + IF(LOGC1) THEN + IF(KFLX((KS-1)*NX*NY+(JS-1)*NX+IS-1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(2,IS-1,JS,KS) + ENDIF + ENDIF + IF(LOGC2) THEN + IF(KFLX((KS-1)*NX*NY+(JS-2)*NX+IS)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(3,IS,JS-1,KS) + ENDIF + ENDIF + IF(LOGC1.AND.LOGC2) THEN + IF(KFLX((KS-1)*NX*NY+(JS-2)*NX+IS-1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(4,IS-1,JS-1,KS) + ENDIF + ENDIF + IF(LOGC3) THEN + IF(KFLX((KS-2)*NX*NY+(JS-1)*NX+IS)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(5,IS,JS,KS-1) + ENDIF + ENDIF + IF(LOGC1.AND.LOGC3) THEN + IF(KFLX((KS-2)*NX*NY+(JS-1)*NX+IS-1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(6,IS-1,JS,KS-1) + ENDIF + ENDIF + IF(LOGC2.AND.LOGC3) THEN + IF(KFLX((KS-2)*NX*NY+(JS-2)*NX+IS)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(7,IS,JS-1,KS-1) + ENDIF + ENDIF + IF(LOGC1.AND.LOGC2.AND.LOGC3) THEN + IF(KFLX((KS-2)*NX*NY+(JS-2)*NX+IS-1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(8,IS-1,JS-1,KS-1) + ENDIF + ENDIF + FC2(1)=GAR/REAL(NB)-FCORN(1,IS,JS,KS) + ! corner 2 + NB=1 ; GAR=FCORN(2,IS,JS,KS) + LOGC1=(IS<NX); LOGC2=(JS>1) ; LOGC3=(KS>1) + IF(LOGC1) THEN + IF(KFLX((KS-1)*NX*NY+(JS-1)*NX+IS+1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(1,IS+1,JS,KS) + ENDIF + ENDIF + IF(LOGC2) THEN + IF(KFLX((KS-1)*NX*NY+(JS-2)*NX+IS)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(4,IS,JS-1,KS) + ENDIF + ENDIF + IF(LOGC1.AND.LOGC2) THEN + IF(KFLX((KS-1)*NX*NY+(JS-2)*NX+IS+1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(3,IS+1,JS-1,KS) + ENDIF + ENDIF + IF(LOGC3) THEN + IF(KFLX((KS-2)*NX*NY+(JS-1)*NX+IS)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(6,IS,JS,KS-1) + ENDIF + ENDIF + IF(LOGC1.AND.LOGC3) THEN + IF(KFLX((KS-2)*NX*NY+(JS-1)*NX+IS+1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(5,IS+1,JS,KS-1) + ENDIF + ENDIF + IF(LOGC2.AND.LOGC3) THEN + IF(KFLX((KS-2)*NX*NY+(JS-2)*NX+IS)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(8,IS,JS-1,KS-1) + ENDIF + ENDIF + IF(LOGC1.AND.LOGC2.AND.LOGC3) THEN + IF(KFLX((KS-2)*NX*NY+(JS-2)*NX+IS+1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(7,IS+1,JS-1,KS-1) + ENDIF + ENDIF + FC2(2)=GAR/REAL(NB)-FCORN(2,IS,JS,KS) + ! corner 3 + NB=1 ; GAR=FCORN(3,IS,JS,KS) + LOGC1=(IS>1) ; LOGC2=(JS<NY) ; LOGC3=(KS>1) + IF(LOGC1) THEN + IF(KFLX((KS-1)*NX*NY+(JS-1)*NX+IS-1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(4,IS-1,JS,KS) + ENDIF + ENDIF + IF(LOGC2) THEN + IF(KFLX((KS-1)*NX*NY+JS*NX+IS)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(1,IS,JS+1,KS) + ENDIF + ENDIF + IF(LOGC1.AND.LOGC2) THEN + IF(KFLX((KS-1)*NX*NY+JS*NX+IS-1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(2,IS-1,JS+1,KS) + ENDIF + ENDIF + IF(LOGC3) THEN + IF(KFLX((KS-2)*NX*NY+(JS-1)*NX+IS)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(7,IS,JS,KS-1) + ENDIF + ENDIF + IF(LOGC1.AND.LOGC3) THEN + IF(KFLX((KS-2)*NX*NY+(JS-1)*NX+IS-1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(8,IS-1,JS,KS-1) + ENDIF + ENDIF + IF(LOGC2.AND.LOGC3) THEN + IF(KFLX((KS-2)*NX*NY+JS*NX+IS)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(5,IS,JS+1,KS-1) + ENDIF + ENDIF + IF(LOGC1.AND.LOGC2.AND.LOGC3) THEN + IF(KFLX((KS-2)*NX*NY+JS*NX+IS-1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(6,IS-1,JS+1,KS-1) + ENDIF + ENDIF + FC2(3)=GAR/REAL(NB)-FCORN(3,IS,JS,KS) + ! corner 4 + NB=1 ; GAR=FCORN(4,IS,JS,KS) + LOGC1=(IS<NX) ; LOGC2=(JS<NY) ; LOGC3=(KS>1) + IF(LOGC1) THEN + IF(KFLX((KS-1)*NX*NY+(JS-1)*NX+IS+1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(3,IS+1,JS,KS) + ENDIF + ENDIF + IF(LOGC2) THEN + IF(KFLX((KS-1)*NX*NY+JS*NX+IS)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(2,IS,JS+1,KS) + ENDIF + ENDIF + IF(LOGC1.AND.LOGC2) THEN + IF(KFLX((KS-1)*NX*NY+JS*NX+IS+1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(1,IS+1,JS+1,KS) + ENDIF + ENDIF + IF(LOGC3) THEN + IF(KFLX((KS-2)*NX*NY+(JS-1)*NX+IS)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(8,IS,JS,KS-1) + ENDIF + ENDIF + IF(LOGC1.AND.LOGC3) THEN + IF(KFLX((KS-2)*NX*NY+(JS-1)*NX+IS+1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(7,IS+1,JS,KS-1) + ENDIF + ENDIF + IF(LOGC2.AND.LOGC3) THEN + IF(KFLX((KS-2)*NX*NY+JS*NX+IS)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(6,IS,JS+1,KS-1) + ENDIF + ENDIF + IF(LOGC1.AND.LOGC2.AND.LOGC3) THEN + IF(KFLX((KS-2)*NX*NY+JS*NX+IS+1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(5,IS+1,JS+1,KS-1) + ENDIF + ENDIF + FC2(4)=GAR/REAL(NB)-FCORN(4,IS,JS,KS) + ! corner 5 + NB=1 ; GAR=FCORN(5,IS,JS,KS) + LOGC1=(IS>1) ; LOGC2=(JS>1) ; LOGC3=(KS<NZ) + IF(LOGC1) THEN + IF(KFLX((KS-1)*NX*NY+(JS-1)*NX+IS-1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(6,IS-1,JS,KS) + ENDIF + ENDIF + IF(LOGC2) THEN + IF(KFLX((KS-1)*NX*NY+(JS-2)*NX+IS)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(7,IS,JS-1,KS) + ENDIF + ENDIF + IF(LOGC1.AND.LOGC2) THEN + IF(KFLX((KS-1)*NX*NY+(JS-2)*NX+IS-1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(8,IS-1,JS-1,KS) + ENDIF + ENDIF + IF(LOGC3) THEN + IF(KFLX(KS*NX*NY+(JS-1)*NX+IS)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(1,IS,JS,KS+1) + ENDIF + ENDIF + IF(LOGC1.AND.LOGC3) THEN + IF(KFLX(KS*NX*NY+(JS-1)*NX+IS-1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(2,IS-1,JS,KS+1) + ENDIF + ENDIF + IF(LOGC2.AND.LOGC3) THEN + IF(KFLX(KS*NX*NY+(JS-2)*NX+IS)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(3,IS,JS-1,KS+1) + ENDIF + ENDIF + IF(LOGC1.AND.LOGC2.AND.LOGC3) THEN + IF(KFLX(KS*NX*NY+(JS-2)*NX+IS-1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(4,IS-1,JS-1,KS+1) + ENDIF + ENDIF + FC2(5)=GAR/REAL(NB)-FCORN(5,IS,JS,KS) + ! corner 6 + NB=1 ; GAR=FCORN(6,IS,JS,KS) + LOGC1=(IS<NX); LOGC2=(JS>1) ; LOGC3=(KS<NZ) + IF(LOGC1) THEN + IF(KFLX((KS-1)*NX*NY+(JS-1)*NX+IS+1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(5,IS+1,JS,KS) + ENDIF + ENDIF + IF(LOGC2) THEN + IF(KFLX((KS-1)*NX*NY+(JS-2)*NX+IS)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(8,IS,JS-1,KS) + ENDIF + ENDIF + IF(LOGC1.AND.LOGC2) THEN + IF(KFLX((KS-1)*NX*NY+(JS-2)*NX+IS+1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(7,IS+1,JS-1,KS) + ENDIF + ENDIF + IF(LOGC3) THEN + IF(KFLX(KS*NX*NY+(JS-1)*NX+IS)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(2,IS,JS,KS+1) + ENDIF + ENDIF + IF(LOGC1.AND.LOGC3) THEN + IF(KFLX(KS*NX*NY+(JS-1)*NX+IS+1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(1,IS+1,JS,KS+1) + ENDIF + ENDIF + IF(LOGC2.AND.LOGC3) THEN + IF(KFLX(KS*NX*NY+(JS-2)*NX+IS)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(4,IS,JS-1,KS+1) + ENDIF + ENDIF + IF(LOGC1.AND.LOGC2.AND.LOGC3) THEN + IF(KFLX(KS*NX*NY+(JS-2)*NX+IS+1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(3,IS+1,JS-1,KS+1) + ENDIF + ENDIF + FC2(6)=GAR/REAL(NB)-FCORN(6,IS,JS,KS) + ! corner 7 + NB=1 ; GAR=FCORN(7,IS,JS,KS) + LOGC1=(IS>1) ; LOGC2=(JS<NY) ; LOGC3=(KS<NZ) + IF(LOGC1) THEN + IF(KFLX((KS-1)*NX*NY+(JS-1)*NX+IS-1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(8,IS-1,JS,KS) + ENDIF + ENDIF + IF(LOGC2) THEN + IF(KFLX((KS-1)*NX*NY+JS*NX+IS)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(5,IS,JS+1,KS) + ENDIF + ENDIF + IF(LOGC1.AND.LOGC2) THEN + IF(KFLX((KS-1)*NX*NY+JS*NX+IS-1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(6,IS-1,JS+1,KS) + ENDIF + ENDIF + IF(LOGC3) THEN + IF(KFLX(KS*NX*NY+(JS-1)*NX+IS)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(3,IS,JS,KS+1) + ENDIF + ENDIF + IF(LOGC1.AND.LOGC3) THEN + IF(KFLX(KS*NX*NY+(JS-1)*NX+IS-1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(4,IS-1,JS,KS+1) + ENDIF + ENDIF + IF(LOGC2.AND.LOGC3) THEN + IF(KFLX(KS*NX*NY+JS*NX+IS)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(1,IS,JS+1,KS+1) + ENDIF + ENDIF + IF(LOGC1.AND.LOGC2.AND.LOGC3) THEN + IF(KFLX(KS*NX*NY+JS*NX+IS-1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(2,IS-1,JS+1,KS+1) + ENDIF + ENDIF + FC2(7)=GAR/REAL(NB)-FCORN(7,IS,JS,KS) + ! corner 8 + NB=1 ; GAR=FCORN(8,IS,JS,KS) + LOGC1=(IS<NX) ; LOGC2=(JS<NY) ; LOGC3=(KS<NZ) + IF(LOGC1) THEN + IF(KFLX((KS-1)*NX*NY+(JS-1)*NX+IS+1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(7,IS+1,JS,KS) + ENDIF + ENDIF + IF(LOGC2) THEN + IF(KFLX((KS-1)*NX*NY+JS*NX+IS)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(6,IS,JS+1,KS) + ENDIF + ENDIF + IF(LOGC1.AND.LOGC2) THEN + IF(KFLX((KS-1)*NX*NY+JS*NX+IS+1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(5,IS+1,JS+1,KS) + ENDIF + ENDIF + IF(LOGC3) THEN + IF(KFLX(KS*NX*NY+(JS-1)*NX+IS)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(4,IS,JS,KS+1) + ENDIF + ENDIF + IF(LOGC1.AND.LOGC3) THEN + IF(KFLX(KS*NX*NY+(JS-1)*NX+IS+1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(3,IS+1,JS,KS+1) + ENDIF + ENDIF + IF(LOGC2.AND.LOGC3) THEN + IF(KFLX(KS*NX*NY+JS*NX+IS)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(2,IS,JS+1,KS+1) + ENDIF + ENDIF + IF(LOGC1.AND.LOGC2.AND.LOGC3) THEN + IF(KFLX(KS*NX*NY+JS*NX+IS+1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(1,IS+1,JS+1,KS+1) + ENDIF + ENDIF + FC2(8)=GAR/REAL(NB)-FCORN(8,IS,JS,KS) + ! polynomial coefficients of correction terms + DELC(1,IS,JS,KS)=-FC2(1)+FC2(2)+FC2(3)-FC2(4)+FC2(5)- + 1 FC2(6)-FC2(7)+FC2(8) + DELC(2,IS,JS,KS)= FC2(1)+FC2(2)-FC2(3)-FC2(4)-FC2(5)- + 1 FC2(6)+FC2(7)+FC2(8) + DELC(3,IS,JS,KS)= FC2(1)-FC2(2)+FC2(3)-FC2(4)-FC2(5)+ + 1 FC2(6)-FC2(7)+FC2(8) + DELC(4,IS,JS,KS)=-FC2(1)-FC2(2)-FC2(3)-FC2(4)+FC2(5)+ + 1 FC2(6)+FC2(7)+FC2(8) + DELC(5,IS,JS,KS)= FC2(1)-FC2(2)-FC2(3)+FC2(4)+FC2(5)- + 1 FC2(6)-FC2(7)+FC2(8) + DELC(6,IS,JS,KS)=-FC2(1)-FC2(2)+FC2(3)+FC2(4)-FC2(5)- + 1 FC2(6)+FC2(7)+FC2(8) + DELC(7,IS,JS,KS)=-FC2(1)+FC2(2)-FC2(3)+FC2(4)-FC2(5)+ + 1 FC2(6)-FC2(7)+FC2(8) + DELC(8,IS,JS,KS)= FC2(1)+FC2(2)+FC2(3)+FC2(4)+FC2(5)+ + 1 FC2(6)+FC2(7)+FC2(8) + ENDDO + ENDDO + ENDDO + DEALLOCATE(FCORN) + ENDIF +*---- +* PERFORM INTERPOLATION +*---- + DO K=1,IZLG + COTE=Z(K) + DO J=1,IYLG + ORDO=Y(J) + DO I=1,IXLG + ABSC=X(I) + GAR=0.0D0 + AXYZ(I,J,K)=REAL(GAR) +* +* Find the node index containing the interpolation point + IS=0 + JS=0 + KS=0 + DO L=1,NX + IS=L + IF((ABSC.GE.XXX(L)).AND.(ABSC.LE.XXX(L+1))) GO TO 10 + ENDDO + CALL XABORT('VALU5: WRONG INTERPOLATION(1).') + 10 DO L=1,NY + JS=L + IF((ORDO.GE.YYY(L)).AND.(ORDO.LE.YYY(L+1))) GO TO 20 + ENDDO + CALL XABORT('VALU5: WRONG INTERPOLATION(2).') + 20 DO L=1,NZ + KS=L + IF((COTE.GE.ZZZ(L)).AND.(COTE.LE.ZZZ(L+1))) GO TO 30 + ENDDO + CALL XABORT('VALU5: WRONG INTERPOLATION(3).') + 30 IEL=(KS-1)*NX*NY+(JS-1)*NX+IS + IND1=KFLX(IEL) + IF(IND1.EQ.0) GO TO 40 + IBM=ISS(IEL) + IF(IBM.LE.0) GO TO 40 + JXM=KN(1,IS,JS,KS) ; JXP=KN(2,IS,JS,KS) + JYM=KN(3,IS,JS,KS) ; JYP=KN(4,IS,JS,KS) + JZM=KN(5,IS,JS,KS) ; JZP=KN(6,IS,JS,KS) + COEFX=DIFF(IBM)/(XXX(IS+1)-XXX(IS)) + COEFY=DIFF(IBM)/(YYY(JS+1)-YYY(JS)) + COEFZ=DIFF(IBM)/(ZZZ(KS+1)-ZZZ(KS)) + U=(ABSC-XXX(IS))/(XXX(IS+1)-XXX(IS))-0.5 + V=(ORDO-YYY(JS))/(YYY(JS+1)-YYY(JS))-0.5 + W=(COTE-ZZZ(KS))/(ZZZ(KS+1)-ZZZ(KS))-0.5 + GAR=EVT(IND1) +* + WORK1(:,:)=0.0 + WORK1(1,1)=-0.5 + WORK1(1,2)=0.5 + WORK1(1,5)=EVT(LL4F+IND1)-EVT(IND1) + WORK1(2,1)=0.5 + WORK1(2,2)=0.5 + WORK1(2,5)=EVT(2*LL4F+IND1)-EVT(IND1) + WORK1(3,1)=-COEFX + WORK1(3,2)=3.0*COEFX + IF(JXM.NE.0) WORK1(3,5)=EVT(7*LL4F+JXM) + WORK1(4,1)=-COEFX + WORK1(4,2)=-3.0*COEFX + IF(JXP.NE.0) WORK1(4,5)=EVT(7*LL4F+JXP) + WORK1(3,3)=-0.5*COEFX + WORK1(3,4)=0.2*COEFX + WORK1(4,3)=-0.5*COEFX + WORK1(4,4)=-0.2*COEFX + CALL ALSBD(4,1,WORK1,IER,4) + IF(IER.NE.0) CALL XABORT('VALU5: SINGULAR MATRIX(4).') + GAR=GAR+WORK1(1,5)*U+WORK1(2,5)*(3.0*U**2-0.25) + GAR=GAR+WORK1(3,5)*(U**2-0.25)*U+WORK1(4,5)*(U**2-0.25)* + 1 (U**2-0.05) +* + WORK1(:,:)=0.0 + WORK1(1,1)=-0.5 + WORK1(1,2)=0.5 + WORK1(1,5)=EVT(3*LL4F+IND1)-EVT(IND1) + WORK1(2,1)=0.5 + WORK1(2,2)=0.5 + WORK1(2,5)=EVT(4*LL4F+IND1)-EVT(IND1) + WORK1(3,1)=-COEFY + WORK1(3,2)=3.0*COEFY + IF(JYM.NE.0) WORK1(3,5)=EVT(IOFY+JYM) + WORK1(4,1)=-COEFY + WORK1(4,2)=-3.0*COEFY + IF(JYP.NE.0) WORK1(4,5)=EVT(IOFY+JYP) + WORK1(3,3)=-0.5*COEFY + WORK1(3,4)=0.2*COEFY + WORK1(4,3)=-0.5*COEFY + WORK1(4,4)=-0.2*COEFY + CALL ALSBD(4,1,WORK1,IER,4) + IF(IER.NE.0) CALL XABORT('VALU5: SINGULAR MATRIX(5).') + GAR=GAR+WORK1(1,5)*V+WORK1(2,5)*(3.0*V**2-0.25) + GAR=GAR+WORK1(3,5)*(V**2-0.25)*V+WORK1(4,5)*(V**2-0.25)* + 1 (V**2-0.05) +* + WORK1(:,:)=0.0 + WORK1(1,1)=-0.5 + WORK1(1,2)=0.5 + WORK1(1,5)=EVT(5*LL4F+IND1)-EVT(IND1) + WORK1(2,1)=0.5 + WORK1(2,2)=0.5 + WORK1(2,5)=EVT(6*LL4F+IND1)-EVT(IND1) + WORK1(3,1)=-COEFZ + WORK1(3,2)=3.0*COEFZ + IF(JZM.NE.0) WORK1(3,5)=EVT(IOFZ+JZM) + WORK1(4,1)=-COEFZ + WORK1(4,2)=-3.0*COEFZ + IF(JZP.NE.0) WORK1(4,5)=EVT(IOFZ+JZP) + WORK1(3,3)=-0.5*COEFZ + WORK1(3,4)=0.2*COEFZ + WORK1(4,3)=-0.5*COEFZ + WORK1(4,4)=-0.2*COEFZ + CALL ALSBD(4,1,WORK1,IER,4) + IF(IER.NE.0) CALL XABORT('VALU5: SINGULAR MATRIX(6).') + GAR=GAR+WORK1(1,5)*W+WORK1(2,5)*(3.0*W**2-0.25) + GAR=GAR+WORK1(3,5)*(W**2-0.25)*W+WORK1(4,5)*(W**2-0.25)* + 1 (W**2-0.05) +* + IF(ICORN==1) THEN + ! perform interpolation of corner flux correction + P2U=3.0*U**2-0.25 ; P2V=3.0*V**2-0.25 ; P2W=3.0*W**2-0.25 + GAR=GAR+DELC(1,IS,JS,KS)*U*V*W + DELC(2,IS,JS,KS)*P2U*V*W+ + 1 DELC(3,IS,JS,KS)*U*P2V*W + DELC(4,IS,JS,KS)*P2U*P2V*W+ + 2 DELC(5,IS,JS,KS)*U*V*P2W + DELC(6,IS,JS,KS)*P2U*V*P2W+ + 3 DELC(7,IS,JS,KS)*U*P2V*P2W + DELC(8,IS,JS,KS)*P2U*P2V*P2W + ENDIF + 40 AXYZ(I,J,K)=REAL(GAR) + ENDDO + ENDDO + ENDDO + DEALLOCATE(DELC,DIFF) + RETURN + END diff --git a/Trivac/src/VALU5B.f b/Trivac/src/VALU5B.f new file mode 100755 index 0000000..fe61753 --- /dev/null +++ b/Trivac/src/VALU5B.f @@ -0,0 +1,342 @@ +*DECK VALU5B + SUBROUTINE VALU5B (KPMAC,NX,NY,LL4F,LL4X,NUN,NMIX,X,Y,XXX,YYY, + 1 EVT,ISS,KFLX,KN,IXLG,IYLG,ICORN,AXY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Interpolation of the flux distribution for nodal method in 2D. +* +*Copyright: +* Copyright (C) 2021 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* KPMAC group directory in the macrolib. +* NX number of elements along the X axis. +* NY number of elements along the Y axis. +* LL4F number of averaged flux unknowns. +* LL4X number of X-directed net currents. +* NUN dimension of unknown array EVT. +* NMIX number of mixtures. +* X Cartesian coordinates along the X axis where the flux is +* interpolated. +* Y Cartesian coordinates along the Y axis where the flux is +* interpolated. +* XXX Cartesian coordinates along the X axis. +* YYY Cartesian coordinates along the Y axis. +* EVT reconstruction coefficients of the flux. +* ISS mixture index assigned to each element. +* KFLX correspondence between local and global numbering. +* KN element-ordered interface net current unknown list. +* IXLG number of interpolated points according to X. +* IYLG number of interpolated points according to Y. +* ICORN flag to activate corner flux correction (0/1: OFF/ON). +* +*Parameters: output +* AXY interpolated fluxes. +* +*---------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) KPMAC + INTEGER NX,NY,LL4F,LL4X,NUN,NMIX,ISS(NX*NY),KFLX(NX*NY), + 1 KN(6,NX,NY),IXLG,IYLG,ICORN + REAL X(IXLG),Y(IYLG),XXX(NX+1),YYY(NY+1),EVT(NUN),AXY(IXLG,IYLG) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION WORK1(4,5),FC2(4) + DOUBLE PRECISION GAR,COEFX,COEFY,U,V,P2U,P2V + LOGICAL LOGC1,LOGC2 +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: DIFF + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: FCORN,DELC +*---- +* RECOVER DIFFUSION COEFFICIENTS +*---- + ALLOCATE(DIFF(NMIX)) + CALL LCMGET(KPMAC,'DIFF',DIFF) +*---- +* COMPUTE CORNER FLUXES +*---- + ALLOCATE(DELC(4,NX,NY)) + DELC(:4,:NX,:NY)=0.D0 + IF(ICORN==1) THEN + ALLOCATE(FCORN(4,NX,NY)) + FCORN(:4,:NX,:NY)=0.D0 + DO JS=1,NY + DO IS=1,NX + IEL=(JS-1)*NX+IS + IND1=KFLX(IEL) + IF(IND1.EQ.0) CYCLE + IBM=ISS(IEL) + IF(IBM.LE.0) CYCLE + JXM=KN(1,IS,JS) ; JXP=KN(2,IS,JS) + JYM=KN(3,IS,JS) ; JYP=KN(4,IS,JS) + COEFX=DIFF(IBM)/(XXX(IS+1)-XXX(IS)) + COEFY=DIFF(IBM)/(YYY(JS+1)-YYY(JS)) +* + WORK1(:,:)=0.0 + WORK1(1,1)=-0.5 + WORK1(1,2)=0.5 + WORK1(1,5)=EVT(LL4F+IND1)-EVT(IND1) + WORK1(2,1)=0.5 + WORK1(2,2)=0.5 + WORK1(2,5)=EVT(2*LL4F+IND1)-EVT(IND1) + WORK1(3,1)=-COEFX + WORK1(3,2)=3.0*COEFX + IF(JXM.NE.0) WORK1(3,5)=EVT(5*LL4F+JXM) + WORK1(4,1)=-COEFX + WORK1(4,2)=-3.0*COEFX + IF(JXP.NE.0) WORK1(4,5)=EVT(5*LL4F+JXP) + WORK1(3,3)=-0.5*COEFX + WORK1(3,4)=0.2*COEFX + WORK1(4,3)=-0.5*COEFX + WORK1(4,4)=-0.2*COEFX + CALL ALSBD(4,1,WORK1,IER,4) + IF(IER.NE.0) CALL XABORT('VALU5B: SINGULAR MATRIX(1).') + DO IC=1,4 + SELECT CASE(IC) + CASE(1,3) + U=-0.5 + CASE DEFAULT + U=0.5 + END SELECT + GAR=EVT(IND1)+WORK1(1,5)*U+WORK1(2,5)*(3.0*U**2-0.25) + GAR=GAR+WORK1(3,5)*(U**2-0.25)*U+WORK1(4,5)*(U**2-0.25)* + 1 (U**2-0.05) + FCORN(IC,IS,JS)=GAR + ENDDO +* + WORK1(:,:)=0.0 + WORK1(1,1)=-0.5 + WORK1(1,2)=0.5 + WORK1(1,5)=EVT(3*LL4F+IND1)-EVT(IND1) + WORK1(2,1)=0.5 + WORK1(2,2)=0.5 + WORK1(2,5)=EVT(4*LL4F+IND1)-EVT(IND1) + WORK1(3,1)=-COEFY + WORK1(3,2)=3.0*COEFY + IF(JYM.NE.0) WORK1(3,5)=EVT(5*LL4F+LL4X+JYM) + WORK1(4,1)=-COEFY + WORK1(4,2)=-3.0*COEFY + IF(JYP.NE.0) WORK1(4,5)=EVT(5*LL4F+LL4X+JYP) + WORK1(3,3)=-0.5*COEFY + WORK1(3,4)=0.2*COEFY + WORK1(4,3)=-0.5*COEFY + WORK1(4,4)=-0.2*COEFY + CALL ALSBD(4,1,WORK1,IER,4) + IF(IER.NE.0) CALL XABORT('VALU5B: SINGULAR MATRIX(2).') + DO IC=1,4 + SELECT CASE(IC) + CASE(1,2) + V=-0.5 + CASE DEFAULT + V=0.5 + END SELECT + GAR=FCORN(IC,IS,JS)+WORK1(1,5)*V+WORK1(2,5)* + 1 (3.0*V**2-0.25) + GAR=GAR+WORK1(3,5)*(V**2-0.25)*V+WORK1(4,5)*(V**2-0.25)* + 1 (V**2-0.05) + FCORN(IC,IS,JS)=GAR + ENDDO + ENDDO + ENDDO + DO JS=1,NY + DO IS=1,NX + IEL=(JS-1)*NX+IS + IND1=KFLX(IEL) + IF(IND1.EQ.0) CYCLE + ! corner 1 + NB=1; GAR=FCORN(1,IS,JS) + LOGC1=(IS>1) ; LOGC2=(JS>1) + IF(LOGC2) LOGC2=(KFLX((JS-2)*NX+IS)>0) + IF(LOGC1) THEN + IF(KFLX((JS-1)*NX+IS-1)>0) THEN + NB=NB+1 ;GAR=GAR+FCORN(2,IS-1,JS) + ENDIF + ENDIF + IF(LOGC2) THEN + IF(KFLX((JS-2)*NX+IS)>0) THEN + NB=NB+1 ;GAR=GAR+FCORN(3,IS,JS-1) + ENDIF + ENDIF + IF(LOGC1.AND.LOGC2) THEN + IF(KFLX((JS-2)*NX+IS-1)>0) THEN + NB=NB+1 ;GAR=GAR+FCORN(4,IS-1,JS-1) + ENDIF + ENDIF + FC2(1)=GAR/REAL(NB)-FCORN(1,IS,JS) + ! corner 2 + NB=1 ;GAR=FCORN(2,IS,JS) + LOGC1=(IS<NX) ; LOGC2=(JS>1) + IF(LOGC1) THEN + IF(KFLX((JS-1)*NX+IS+1)>0) THEN + NB=NB+1 ;GAR=GAR+FCORN(1,IS+1,JS) + ENDIF + ENDIF + IF(LOGC2) THEN + IF(KFLX((JS-2)*NX+IS)>0) THEN + NB=NB+1 ;GAR=GAR+FCORN(4,IS,JS-1) + ENDIF + ENDIF + IF(LOGC1.AND.LOGC2) THEN + IF(KFLX((JS-2)*NX+IS+1)>0) THEN + NB=NB+1 ;GAR=GAR+FCORN(3,IS+1,JS-1) + ENDIF + ENDIF + FC2(2)=GAR/REAL(NB)-FCORN(2,IS,JS) + ! corner 3 + NB=1 ; GAR=FCORN(3,IS,JS) + LOGC1=(IS>1) ; LOGC2=(JS<NY) + IF(LOGC1) THEN + IF(KFLX((JS-1)*NX+IS-1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(4,IS-1,JS) + ENDIF + ENDIF + IF(LOGC2) THEN + IF(KFLX(JS*NX+IS)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(1,IS,JS+1) + ENDIF + ENDIF + IF(LOGC1.AND.LOGC2) THEN + IF(KFLX(JS*NX+IS-1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(2,IS-1,JS+1) + ENDIF + ENDIF + FC2(3)=GAR/REAL(NB)-FCORN(3,IS,JS) + ! corner 4 + NB=1 + GAR=FCORN(4,IS,JS) + LOGC1=(IS<NX) + IF(LOGC1) LOGC1=(KFLX((JS-1)*NX+IS+1)>0) + LOGC2=(JS<NY) + IF(LOGC2) LOGC2=(KFLX(JS*NX+IS)>0) + IF(LOGC1) THEN + IF(KFLX((JS-1)*NX+IS+1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(3,IS+1,JS) + ENDIF + ENDIF + IF(LOGC2) THEN + IF(KFLX(JS*NX+IS)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(2,IS,JS+1) + ENDIF + ENDIF + IF(LOGC1.AND.LOGC2) THEN + IF(KFLX(JS*NX+IS+1)>0) THEN + NB=NB+1 ; GAR=GAR+FCORN(1,IS+1,JS+1) + ENDIF + ENDIF + FC2(4)=GAR/REAL(NB)-FCORN(4,IS,JS) + ! polynomial coefficients of correction terms + DELC(1,IS,JS)= FC2(1)-FC2(2)-FC2(3)+FC2(4) + DELC(2,IS,JS)=-FC2(1)-FC2(2)+FC2(3)+FC2(4) + DELC(3,IS,JS)=-FC2(1)+FC2(2)-FC2(3)+FC2(4) + DELC(4,IS,JS)= FC2(1)+FC2(2)+FC2(3)+FC2(4) + ENDDO + ENDDO + DEALLOCATE(FCORN) + ENDIF +*---- +* PERFORM INTERPOLATION +*---- + DO J=1,IYLG + ORDO=Y(J) + DO I=1,IXLG + ABSC=X(I) + GAR=0.0D0 +* +* Find the node index containing the interpolation point + IS=0; JS=0 + DO L=1,NX + IS=L + IF((ABSC.GE.XXX(L)).AND.(ABSC.LE.XXX(L+1))) GO TO 10 + ENDDO + CALL XABORT('VALU5B: WRONG INTERPOLATION(1).') + 10 DO L=1,NY + JS=L + IF((ORDO.GE.YYY(L)).AND.(ORDO.LE.YYY(L+1))) GO TO 20 + ENDDO + CALL XABORT('VALU5B: WRONG INTERPOLATION(2).') + 20 IEL=(JS-1)*NX+IS + IND1=KFLX(IEL) + IF(IND1.EQ.0) GO TO 30 + IBM=ISS(IEL) + IF(IBM.LE.0) GO TO 30 + JXM=KN(1,IS,JS) ; JXP=KN(2,IS,JS) + JYM=KN(3,IS,JS) ; JYP=KN(4,IS,JS) + COEFX=DIFF(IBM)/(XXX(IS+1)-XXX(IS)) + COEFY=DIFF(IBM)/(YYY(JS+1)-YYY(JS)) + U=(ABSC-XXX(IS))/(XXX(IS+1)-XXX(IS))-0.5 + V=(ORDO-YYY(JS))/(YYY(JS+1)-YYY(JS))-0.5 + GAR=EVT(IND1) +* + WORK1(:,:)=0.0 + WORK1(1,1)=-0.5 + WORK1(1,2)=0.5 + WORK1(1,5)=EVT(LL4F+IND1)-EVT(IND1) + WORK1(2,1)=0.5 + WORK1(2,2)=0.5 + WORK1(2,5)=EVT(2*LL4F+IND1)-EVT(IND1) + WORK1(3,1)=-COEFX + WORK1(3,2)=3.0*COEFX + IF(JXM.NE.0) WORK1(3,5)=EVT(5*LL4F+JXM) + WORK1(4,1)=-COEFX + WORK1(4,2)=-3.0*COEFX + IF(JXP.NE.0) WORK1(4,5)=EVT(5*LL4F+JXP) + WORK1(3,3)=-0.5*COEFX + WORK1(3,4)=0.2*COEFX + WORK1(4,3)=-0.5*COEFX + WORK1(4,4)=-0.2*COEFX + CALL ALSBD(4,1,WORK1,IER,4) + IF(IER.NE.0) CALL XABORT('VALU5B: SINGULAR MATRIX(3).') + GAR=GAR+WORK1(1,5)*U+WORK1(2,5)*(3.0*U**2-0.25) + GAR=GAR+WORK1(3,5)*(U**2-0.25)*U+WORK1(4,5)*(U**2-0.25)* + 1 (U**2-0.05) +* + WORK1(:,:)=0.0 + WORK1(1,1)=-0.5 + WORK1(1,2)=0.5 + WORK1(1,5)=EVT(3*LL4F+IND1)-EVT(IND1) + WORK1(2,1)=0.5 + WORK1(2,2)=0.5 + WORK1(2,5)=EVT(4*LL4F+IND1)-EVT(IND1) + WORK1(3,1)=-COEFY + WORK1(3,2)=3.0*COEFY + IF(JYM.NE.0) WORK1(3,5)=EVT(5*LL4F+LL4X+JYM) + WORK1(4,1)=-COEFY + WORK1(4,2)=-3.0*COEFY + IF(JYP.NE.0) WORK1(4,5)=EVT(5*LL4F+LL4X+JYP) + WORK1(3,3)=-0.5*COEFY + WORK1(3,4)=0.2*COEFY + WORK1(4,3)=-0.5*COEFY + WORK1(4,4)=-0.2*COEFY + CALL ALSBD(4,1,WORK1,IER,4) + IF(IER.NE.0) CALL XABORT('VALU5B: SINGULAR MATRIX(4).') + GAR=GAR+WORK1(1,5)*V+WORK1(2,5)*(3.0*V**2-0.25) + GAR=GAR+WORK1(3,5)*(V**2-0.25)*V+WORK1(4,5)*(V**2-0.25)* + 1 (V**2-0.05) +* + IF(ICORN==1) THEN + ! perform interpolation of corner flux correction + P2U=3.0*U**2-0.25 ; P2V=3.0*V**2-0.25 + GAR=GAR+DELC(1,IS,JS)*U*V + DELC(2,IS,JS)*P2U*V+ + 1 DELC(3,IS,JS)*U*P2V + DELC(4,IS,JS)*P2U*P2V + ENDIF + 30 AXY(I,J)=REAL(GAR) + ENDDO + ENDDO + DEALLOCATE(DELC,DIFF) + RETURN + END diff --git a/Trivac/src/VALU5C.f b/Trivac/src/VALU5C.f new file mode 100755 index 0000000..53539a8 --- /dev/null +++ b/Trivac/src/VALU5C.f @@ -0,0 +1,133 @@ +*DECK VALU5C + SUBROUTINE VALU5C (KPMAC,NX,NUN,NMIX,X,XXX,EVT,ISS,IXLG,ITRIAL, + 1 AXY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Interpolation of the flux distribution for nodal method in 1D. +* +*Copyright: +* Copyright (C) 2021 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* KPMAC group directory in the macrolib. +* NX number of elements along the X axis. +* NUN dimension of unknown array EVT. +* NMIX number of mixtures. +* X Cartesian coordinates along the X axis where the flux is +* interpolated. +* XXX Cartesian coordinates along the X axis. +* EVT reconstruction coefficients of the flux. +* ISS mixture index assigned to each element. +* IXLG number of interpolated points according to X. +* ITRIAL type of expansion functions in the nodal calculation +* (=0: CMFD; =1: polynomial NEM; =2: hyperbolic NEM). +* +*Parameters: output +* AXY interpolated fluxes. +* +*---------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) KPMAC + INTEGER NX,NUN,NMIX,ISS(NX),IXLG,ITRIAL + REAL X(IXLG),XXX(NX+1),EVT(NUN),AXY(IXLG) +*---- +* LOCAL VARIABLES +*---- + DOUBLE PRECISION WORK1(4,5),WORK2(2,3) + DOUBLE PRECISION GAR,ETA,ALP1,COEF,U + REAL, ALLOCATABLE, DIMENSION(:) :: DIFF,SIGR,SIGW +*---- +* RECOVER REMOVAL CROSS SECTIONS AND DIFFUSION COEFFICIENTS +*---- + ALLOCATE(DIFF(NMIX),SIGR(NMIX),SIGW(NMIX)) + CALL LCMGET(KPMAC,'NTOT0',SIGR) + CALL LCMGET(KPMAC,'SIGW00',SIGW) + CALL LCMGET(KPMAC,'DIFF',DIFF) + SIGR(:)=SIGR(:)-SIGW(:) +*---- +* PERFORM INTERPOLATION +*---- + DO I=1,IXLG + ABSC=X(I) + GAR=0.0D0 +* +* Find the node index containing the interpolation point + IS=0 + DO KEL=1,NX + IS=KEL + IF((ABSC.GE.XXX(KEL)).AND.(ABSC.LE.XXX(KEL+1))) GO TO 10 + ENDDO + CALL XABORT('VALU5C: WRONG INTERPOLATION.') + 10 IBM=ISS(IS) + IF(IBM.EQ.0) GO TO 100 + ETA=(XXX(IS+1)-XXX(IS))*SQRT(SIGR(IBM)/DIFF(IBM)) + ALP1=ETA*COSH(ETA/2.0)-2.0*SINH(ETA/2.0) + COEF=DIFF(IBM)/(XXX(IS+1)-XXX(IS)) + U=(ABSC-XXX(IS))/(XXX(IS+1)-XXX(IS))-0.5 + IF(ITRIAL.EQ.0) THEN + WORK2(1,1)=COEF + WORK2(1,2)=-3.0*COEF + WORK2(1,3)=EVT(3*NX+IS) + WORK2(2,1)=COEF + WORK2(2,2)=3.0*COEF + WORK2(2,3)=EVT(3*NX+IS+1) + CALL ALSBD(3,1,WORK2(1,1),IER,3) + IF(IER.NE.0) CALL XABORT('VALU5C: SINGULAR MATRIX(1).') + GAR=EVT(IS)+WORK2(1,3)*U+WORK2(2,3)*(3.0*U**2-1.0/4.0) + ELSE + WORK1(:,:)=0.0 + WORK1(1,1)=-0.5 + WORK1(1,2)=0.5 + WORK1(1,5)=EVT(NX+IS)-EVT(IS) + WORK1(2,1)=0.5 + WORK1(2,2)=0.5 + WORK1(2,5)=EVT(2*NX+IS)-EVT(IS) + WORK1(3,1)=-COEF + WORK1(3,2)=3.0*COEF + WORK1(3,5)=EVT(3*NX+IS) + WORK1(4,1)=-COEF + WORK1(4,2)=-3.0*COEF + WORK1(4,5)=EVT(3*NX+IS+1) + IF(ITRIAL.EQ.1) THEN + WORK1(3,3)=-0.5*COEF + WORK1(3,4)=0.2*COEF + WORK1(4,3)=-0.5*COEF + WORK1(4,4)=-0.2*COEF + ELSE + WORK1(1,3)=-SINH(ETA/2.0) + WORK1(1,4)=ALP1/ETA + WORK1(2,3)=SINH(ETA/2.0) + WORK1(2,4)=ALP1/ETA + WORK1(3,3)=-COEF*ETA*COSH(ETA/2.0) + WORK1(3,4)=COEF*ETA*SINH(ETA/2.0) + WORK1(4,3)=-COEF*ETA*COSH(ETA/2.0) + WORK1(4,4)=-COEF*ETA*SINH(ETA/2.0) + ENDIF + CALL ALSBD(4,1,WORK1(1,1),IER,4) + IF(IER.NE.0) CALL XABORT('VALU5C: SINGULAR MATRIX(2).') + GAR=EVT(IS)+WORK1(1,5)*U+WORK1(2,5)*(3.0*U**2-1.0/4.0) + IF(ITRIAL.EQ.1) THEN + GAR=GAR+WORK1(3,5)*(U**2-0.25)*U+ + 1 WORK1(4,5)*(U**2-0.25)*(U**2-0.05) + ELSE + GAR=GAR+WORK1(3,5)*SINH(ETA*U)+ + 1 WORK1(4,5)*(COSH(ETA*U)-2.0*SINH(ETA/2.0)/ETA) + ENDIF + ENDIF + 100 AXY(I)=REAL(GAR) + ENDDO + DEALLOCATE(SIGW,SIGR,DIFF) + RETURN + END diff --git a/Trivac/src/VALUE1.f b/Trivac/src/VALUE1.f new file mode 100755 index 0000000..ca1f445 --- /dev/null +++ b/Trivac/src/VALUE1.f @@ -0,0 +1,122 @@ +*DECK VALUE1 + SUBROUTINE VALUE1 (IDIM,LX,LY,LZ,L4,X,Y,Z,XXX,YYY,ZZZ,EVT,ISS, + 1 IELEM,IXLG,IYLG,IZLG,AXYZ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Interpolate the flux distribution for MCFD method in 3D. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* IDIM number of dimensions (1, 2 or 3). +* LX number of elements along the X axis. +* LY number of elements along the Y axis. +* LZ number of elements along the Z axis. +* L4 dimension of unknown array EVT. +* X Cartesian coordinates along the X axis where the flux is +* interpolated. +* Y Cartesian coordinates along the Y axis where the flux is +* interpolated. +* Z Cartesian coordinates along the Z axis where the flux is +* interpolated. +* XXX Cartesian coordinates along the X axis. +* YYY Cartesian coordinates along the Y axis. +* ZZZ Cartesian coordinates along the Z axis. +* EVT variational coefficients of the flux. +* ISS mixture index assigned to each element. +* IELEM MCFD polynomial order (IELEM=1 is the mesh centered finite +* difference method). +* IXLG number of interpolated points according to X. +* IYLG number of interpolated points according to Y. +* IZLG number of interpolated points according to Z. +* +*Parameters: output +* AXYZ interpolated fluxes. +* +*---------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IDIM,LX,LY,LZ,L4,ISS(LX*LY*LZ),IELEM,IXLG,IYLG,IZLG + REAL X(IXLG),Y(IYLG),Z(IZLG),XXX(LX+1),YYY(LY+1),ZZZ(LZ+1), + 1 EVT(L4),AXYZ(IXLG,IYLG,IZLG) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IWRK +*---- +* Scratch storage allocation +*---- + ALLOCATE(IWRK(LX*LY*LZ)) +* + NUM=0 + DO 10 K=1,LX*LY*LZ + IF (ISS(K).EQ.0) GO TO 10 + NUM=NUM+1 + IWRK(K)=NUM + 10 CONTINUE +* + LL4=L4/IELEM**(IDIM-1) + DO 130 K=1,IZLG + COTE=Z(K) + DO 120 J=1,IYLG + ORDO=Y(J) + DO 110 I=1,IXLG + ABSC=X(I) + GAR=0.0 +* +* Find the finite element index containing the interpolation point + IS=0 + JS=0 + KS=0 + DO 20 L=1,LX + IS=L + IF((ABSC.GE.XXX(L)).AND.(ABSC.LE.XXX(L+1))) GO TO 30 + 20 CONTINUE + CALL XABORT('VALUE1: WRONG INTERPOLATION(1).') + 30 DO 40 L=1,LY + JS=L + IF((ORDO.GE.YYY(L)).AND.(ORDO.LE.YYY(L+1))) GO TO 50 + 40 CONTINUE + CALL XABORT('VALUE1: WRONG INTERPOLATION(2).') + 50 DO 60 L=1,LZ + KS=L + IF((COTE.GE.ZZZ(L)).AND.(COTE.LE.ZZZ(L+1))) GO TO 70 + 60 CONTINUE + CALL XABORT('VALUE1: WRONG INTERPOLATION(3).') + 70 IEL=(KS-1)*LX*LY+(JS-1)*LX+IS + IF(ISS(IEL).EQ.0) GO TO 100 + U=(ABSC-0.5*(XXX(IS)+XXX(IS+1)))/(XXX(IS+1)-XXX(IS)) + V=(ORDO-0.5*(YYY(JS)+YYY(JS+1)))/(YYY(JS+1)-YYY(JS)) + W=(COTE-0.5*(ZZZ(KS)+ZZZ(KS+1)))/(ZZZ(KS+1)-ZZZ(KS)) + L=1+IELEM*(IWRK(IEL)-1) + DO 95 N3=0,IELEM-1 + DO 90 N2=0,IELEM-1 + DO 80 N1=0,IELEM-1 + GAR=GAR+VALPL(N1,U)*VALPL(N2,V)*VALPL(N3,W)* + 1 EVT(LL4*(IELEM*N3+N2)+N1+L) + 80 CONTINUE + IF ((IDIM.EQ.1).AND.(N2.EQ.0)) GO TO 100 + IF ((IDIM.EQ.2).AND.(N2.EQ.IELEM-1)) GO TO 100 + 90 CONTINUE + 95 CONTINUE + 100 AXYZ(I,J,K)=GAR + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE +*---- +* Scratch storage deallocation +*---- + DEALLOCATE(IWRK) + RETURN + END diff --git a/Trivac/src/VALUE2.f b/Trivac/src/VALUE2.f new file mode 100755 index 0000000..fb314ac --- /dev/null +++ b/Trivac/src/VALUE2.f @@ -0,0 +1,173 @@ +*DECK VALUE2 + SUBROUTINE VALUE2 (LC,MKN,LX,LY,LZ,L4,X,Y,Z,XXX,YYY,ZZZ,EVECT, + + ISS,KN,IXLG,IYLG,IZLG,E,AXYZ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Interpolate the flux distribution for PRIM method in 3D. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* LC order of the unit matrices. +* MKN second dimension for matrix KN. +* LX number of elements along the X axis. +* LY number of elements along the Y axis. +* LZ number of elements along the Z axis. +* L4 dimension of unknown array EVECT. +* X Cartesian coordinates along the X axis where the flux is +* interpolated. +* Y Cartesian coordinates along the Y axis where the flux is +* interpolated. +* Z Cartesian coordinates along the Z axis where the flux is +* interpolated. +* XXX Cartesian coordinates along the X axis. +* YYY Cartesian coordinates along the Y axis. +* ZZZ Cartesian coordinates along the Z axis. +* EVECT variational coefficients of the flux. +* ISS mixture index assigned to each element. +* KN element-ordered unknown list. +* IELEM MCFD polynomial order (IELEM=1 is the mesh centered finite +* difference method). +* IXLG number of interpolated points according to X. +* IYLG number of interpolated points according to Y. +* IZLG number of interpolated points according to Z. +* E Lagrange polynomial coefficients. +* +*Parameters: output +* AXYZ interpolated fluxes. +* +*---------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER LC,MKN,LX,LY,LZ,L4,ISS(LX*LY*LZ),KN(LX*LY*LZ*MKN),IXLG, + 1 IYLG,IZLG + REAL X(IXLG),Y(IYLG),Z(IZLG),XXX(LX+1),YYY(LY+1),ZZZ(LZ+1), + 1 EVECT(L4),AXYZ(IXLG,IYLG,IZLG),E(LC,LC) +*---- +* LOCAL VARIABLES +*---- + INTEGER IJ1(125),IJ2(125),IJ3(125) + REAL FLX(5),FLY(5),FLZ(5) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IWRK + REAL, ALLOCATABLE, DIMENSION(:,:) ::COEF +*---- +* Scratch storage allocation +*---- + ALLOCATE(IWRK(LX*LY*LZ),COEF(LX*LY*LZ,MKN)) +*---- +* Calculation of IJ integer arrays +*---- + LL=LC*LC*LC + DO 5 L=1,LL + L1=1+MOD(L-1,LC) + L2=1+(L-L1)/LC + L3=1+MOD(L2-1,LC) + IJ1(L)=L1 + IJ2(L)=L3 + IJ3(L)=1+(L2-L3)/LC + 5 CONTINUE +* + NUM=0 + DO 10 I=1,LX*LY*LZ + IWRK(I)=0 + IF (ISS(I).EQ.0) GO TO 10 + IWRK(I)=NUM + NUM=NUM+1 + 10 CONTINUE +* + DO 120 K=1,IZLG + COTE=Z(K) + DO 110 J=1,IYLG + ORDO=Y(J) + DO 100 I=1,IXLG + ABSC=X(I) + AXYZ(I,J,K)=0.0 +* +* Find the finite element index containing the interpolation point + IS=0 + JS=0 + KS=0 + DO 20 L=1,LX + IS=L + IF((ABSC.GE.XXX(L)).AND.(ABSC.LE.XXX(L+1))) GO TO 30 + 20 CONTINUE + CALL XABORT('VALUE2: WRONG INTERPOLATION(1).') + 30 DO 40 L=1,LY + JS=L + IF((ORDO.GE.YYY(L)).AND.(ORDO.LE.YYY(L+1))) GO TO 50 + 40 CONTINUE + CALL XABORT('VALUE2: WRONG INTERPOLATION(2).') + 50 DO 60 L=1,LZ + KS=L + IF((COTE.GE.ZZZ(L)).AND.(COTE.LE.ZZZ(L+1))) GO TO 70 + 60 CONTINUE + CALL XABORT('VALUE2: WRONG INTERPOLATION(3).') + 70 IEL=(KS-1)*LX*LY+(JS-1)*LX+IS +* + IF(ISS(IEL).EQ.0) GO TO 100 + NUM=IWRK(IEL) + IF (NUM.NE.-1) THEN + DO 85 M=1,LL + I1=IJ1(M) + I2=IJ2(M) + I3=IJ3(M) + COEF(IEL,M)=0.0 + DO 80 N=1,LL + IND2=KN(LL*NUM+N) + IF (IND2.EQ.0) GO TO 80 + J1=IJ1(N) + J2=IJ2(N) + J3=IJ3(N) + COEF(IEL,M)=COEF(IEL,M)+E(I1,J1)*E(I2,J2)*E(I3,J3)*EVECT(IND2) + 80 CONTINUE + 85 CONTINUE + IWRK(IEL)=-1 + ENDIF +* + U=(ABSC-0.5*(XXX(IS)+XXX(IS+1)))/(XXX(IS+1)-XXX(IS)) + FLX(1)=1.0 + FLX(2)=FLX(1)*U + FLX(3)=FLX(2)*U + FLX(4)=FLX(3)*U + FLX(5)=FLX(4)*U + V=(ORDO-0.5*(YYY(JS)+YYY(JS+1)))/(YYY(JS+1)-YYY(JS)) + FLY(1)=1.0 + FLY(2)=FLY(1)*V + FLY(3)=FLY(2)*V + FLY(4)=FLY(3)*V + FLY(5)=FLY(4)*V + W=(COTE-0.5*(ZZZ(KS)+ZZZ(KS+1)))/(ZZZ(KS+1)-ZZZ(KS)) + FLZ(1)=1.0 + FLZ(2)=FLZ(1)*W + FLZ(3)=FLZ(2)*W + FLZ(4)=FLZ(3)*W + FLZ(5)=FLZ(4)*W + DO 90 L=1,LL + I1=IJ1(L) + I2=IJ2(L) + I3=IJ3(L) + AXYZ(I,J,K)=AXYZ(I,J,K)+COEF(IEL,L)*FLX(I1)*FLY(I2)*FLZ(I3) + 90 CONTINUE + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE +*---- +* Scratch storage deallocation +*---- + DEALLOCATE(COEF,IWRK) + RETURN + END diff --git a/Trivac/src/VALUE4.f b/Trivac/src/VALUE4.f new file mode 100755 index 0000000..fe047b2 --- /dev/null +++ b/Trivac/src/VALUE4.f @@ -0,0 +1,138 @@ +*DECK VALUE4 + SUBROUTINE VALUE4(IELEM,NUN,LX,LY,LZ,X,Y,Z,XXX,YYY,ZZZ,EVECT,ISS, + + KFLX,IXLG,IYLG,IZLG,AXYZ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Interpolate the flux distribution for DUAL method in 3D. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Chambon +* +*Parameters: input +* IELEM finite element order +* =1 : linear Raviart-Thomas +* =2 : parabolic Raviart-Thomas +* =3 : cubic Raviart-Thomas +* =4 : quartic Raviart-Thomas +* NUN number of unknowns +* LX number of elements along the X axis. +* LY number of elements along the Y axis. +* LZ number of elements along the Z axis. +* X Cartesian coordinates along the X axis where the flux is +* interpolated. +* Y Cartesian coordinates along the Y axis where the flux is +* interpolated. +* Z Cartesian coordinates along the Z axis where the flux is +* interpolated. +* XXX Cartesian coordinates along the X axis. +* YYY Cartesian coordinates along the Y axis. +* ZZZ Cartesian coordinates along the Z axis. +* EVECT variational coefficients of the flux. +* ISS mixture index assigned to each element. +* KFLX correspondence between local and global numbering. +* IXLG number of interpolated points according to X. +* IYLG number of interpolated points according to Y. +* IZLG number of interpolated points according to Z. +* +*Parameters: output +* AXYZ interpolated fluxes. +* +*---------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER IELEM,NUN,LX,LY,LZ,IXLG,IYLG,IZLG,ISS(LX*LY*LZ), + 1 KFLX(LX*LY*LZ) + REAL X(IXLG),Y(IYLG),Z(IZLG),XXX(LX+1),YYY(LY+1),ZZZ(LZ+1), + 1 EVECT(NUN),AXYZ(IXLG,IYLG,IZLG) +*---- +* LOCAL VARIABLES +*---- + INTEGER I,J,K,L,IS,JS,KS,IEL,I1,I2,I3,IE + REAL COTE,ORDO,ABSC,COEF(2,5),FLX(5),FLY(5),FLZ(5) + REAL U,V,W +*---- +* compute coefficient for legendre polynomials +*---- + COEF(:2,:5)=0.0 + COEF(1,1)=1.0 + COEF(1,2)=2.*3.**0.5 + DO IE=1,3 + COEF(1,IE+2)=2.0*REAL(2*IE+1)/REAL(IE+1) + 1 *(REAL(2*IE+3)/REAL(2*IE+1))**0.5 + COEF(2,IE+2)=REAL(IE)/REAL(IE+1) + 1 *(REAL(2*IE+3)/REAL(2*IE-1))**0.5 + ENDDO +*---- +* perform interpolation +*---- + DO 120 K=1,IZLG + COTE=Z(K) + DO 110 J=1,IYLG + ORDO=Y(J) + DO 100 I=1,IXLG + ABSC=X(I) + AXYZ(I,J,K)=0.0 +* +* Find the finite element index containing the interpolation point + IS=0 + JS=0 + KS=0 + DO 20 L=1,LX + IS=L + IF((ABSC.GE.XXX(L)).AND.(ABSC.LE.XXX(L+1))) GO TO 30 + 20 CONTINUE + CALL XABORT('VALUE4: WRONG INTERPOLATION(1).') + 30 DO 40 L=1,LY + JS=L + IF((ORDO.GE.YYY(L)).AND.(ORDO.LE.YYY(L+1))) GO TO 50 + 40 CONTINUE + CALL XABORT('VALUE4: WRONG INTERPOLATION(2).') + 50 DO 60 L=1,LZ + KS=L + IF((COTE.GE.ZZZ(L)).AND.(COTE.LE.ZZZ(L+1))) GO TO 70 + 60 CONTINUE + CALL XABORT('VALUE4: WRONG INTERPOLATION(3).') + 70 IEL=(KS-1)*LX*LY+(JS-1)*LX+IS +C + IF(ISS(IEL).EQ.0) GO TO 100 + U=(ABSC-0.5*(XXX(IS)+XXX(IS+1)))/(XXX(IS+1)-XXX(IS)) + FLX(1)=COEF(1,1) + FLX(2)=COEF(1,2)*U + V=(ORDO-0.5*(YYY(JS)+YYY(JS+1)))/(YYY(JS+1)-YYY(JS)) + FLY(1)=COEF(1,1) + FLY(2)=COEF(1,2)*V + W=(COTE-0.5*(ZZZ(KS)+ZZZ(KS+1)))/(ZZZ(KS+1)-ZZZ(KS)) + FLZ(1)=COEF(1,1) + FLZ(2)=COEF(1,2)*W + IF(IELEM.GE.2) THEN + DO IE=2,IELEM + FLX(IE+1)=FLX(IE)*U*COEF(1,IE+1)-FLX(IE-1)*COEF(2,IE+1) + FLY(IE+1)=FLY(IE)*V*COEF(1,IE+1)-FLY(IE-1)*COEF(2,IE+1) + FLZ(IE+1)=FLZ(IE)*W*COEF(1,IE+1)-FLZ(IE-1)*COEF(2,IE+1) + ENDDO + ENDIF + DO 93 I3=1,IELEM + DO 92 I2=1,IELEM + DO 91 I1=1,IELEM + L=(I3-1)*(IELEM)**2+(I2-1)*(IELEM)+I1 + AXYZ(I,J,K)=AXYZ(I,J,K)+EVECT(KFLX(IEL)+L-1)*FLX(I1)*FLY(I2) + 1 *FLZ(I3) + 91 CONTINUE + 92 CONTINUE + 93 CONTINUE + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + RETURN + END diff --git a/Trivac/src/VECBLD.f b/Trivac/src/VECBLD.f new file mode 100755 index 0000000..706bd9c --- /dev/null +++ b/Trivac/src/VECBLD.f @@ -0,0 +1,95 @@ +*DECK VECBLD + SUBROUTINE VECBLD(ISEG,L4,MUIN,LON,LBL,MUV,IPV,ITY,ASSIN,ASSV, + 1 DGV) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Rebuild a matrix stored in compressed diagonal storage mode in a form +* compatible with supervectorial calculations. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* ISEG number of elements in a vector register. +* L4 ASSIN matrix order. +* MUIN position of each diagonal element in matrix ASSIN. +* LON number of groups of linear systems. +* LBL number of unknowns in each group. +* MUV position of each diagonal element in matrix ASSV. +* IPV permutation vector for the ordered unknowns. +* ITY type of operation: =1 gather back; =2 scatter forth. +* +*Parameters: input/output +* ASSIN input (ITY=2) or output (ITY=1) matrix in scalar compressed +* diagonal storage mode. Dimensionned to MUIN(L4). +* ASSV input (ITY=1) or output (ITY=2) matrix in supervectorial +* compressed diagonal storage mode. The second dimension is +* equal to MUV(SUM(LBL(I))). +* +*Parameters: output +* DGV diagonal of ASSV. This information is produced only if ITY=2. +* The second dimension is equal to SUM(LBL(I)). +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER ISEG,L4,MUIN(L4),LON,LBL(LON),MUV(L4),IPV(L4),ITY + REAL ASSIN(*),ASSV(ISEG,*),DGV(ISEG,*) +*---- +* REBUILD THE MATRIX +*---- + IF(ITY.EQ.1) THEN + IOF0=0 + DO 20 IND1=1,L4 + IPOS=1+(IPV(IND1)-1)/ISEG + IBANC=1+MOD(IPV(IND1)-1,ISEG) + IOF1=MUIN(IND1) + DO 10 JND1=1-IOF1+IOF0,0 + ASSIN(IOF1+JND1)=ASSV(IBANC,MUV(IPOS)+JND1) + 10 CONTINUE + IOF0=IOF1 + 20 CONTINUE + ELSE IF(ITY.EQ.2) THEN + LBL0=0 + DO 30 I=1,LON + LBL0=LBL0+LBL(I) + 30 CONTINUE + DO 45 J=1,MUV(LBL0) + DO 40 I=1,ISEG + ASSV(I,J)=0.0 + 40 CONTINUE + 45 CONTINUE + LBL0=0 + DO 60 J=1,LON + DO 55 K=1,LBL(J) + DO 50 I=1,ISEG + ASSV(I,MUV(LBL0+K))=1.0 + DGV(I,LBL0+K)=1.0 + 50 CONTINUE + 55 CONTINUE + LBL0=LBL0+LBL(J) + 60 CONTINUE + IOF0=0 + DO 80 IND1=1,L4 + IPOS=1+(IPV(IND1)-1)/ISEG + IBANC=1+MOD(IPV(IND1)-1,ISEG) + IOF1=MUIN(IND1) + DO 70 JND1=1-IOF1+IOF0,0 + ASSV(IBANC,MUV(IPOS)+JND1)=ASSIN(IOF1+JND1) + 70 CONTINUE + DGV(IBANC,IPOS)=ASSIN(IOF1) + IOF0=IOF1 + 80 CONTINUE + ENDIF + RETURN + END diff --git a/Trivac/src/VECPER.f b/Trivac/src/VECPER.f new file mode 100755 index 0000000..1916e03 --- /dev/null +++ b/Trivac/src/VECPER.f @@ -0,0 +1,204 @@ +*DECK VECPER + SUBROUTINE VECPER(HNAME,IMPV,ISEG,L4,MUIN,LON,LTSW,NBL,LBL,MUV, + 1 IPV) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Ordering of matrix elements for supervectorial operations on a matrix +* in compressed diagonal storage mode. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Hebert +* +*Parameters: input +* HNAME name of the matrix (for edition purpose only). +* IMPV print parameter for statistics (equal to zero for no print). +* ISEG number of elements in a vector register. +* L4 matrix order. +* MUIN position of each diagonal element in non-ordered matrix. +* +*Parameters: output +* LON number of groups of linear systems. +* LTSW maximum bandwidth (=2 for tridiagonal systems). +* NBL number of linear systems in each group. +* LBL number of unknowns in each group. +* MUV position of each diagonal element in ordered matrix. +* IPV permutation vector for the ordered unknowns. +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER HNAME*4 + INTEGER IMPV,ISEG,L4,MUIN(L4),LON,LTSW,NBL(LON),LBL(LON),MUV(L4), + 1 IPV(L4) +*---- +* LOCAL VARIABLES +*---- + INTEGER, DIMENSION(:), ALLOCATABLE :: ISET,ISORT,IOFSET,IORD +*---- +* DETERMINE THE TOTAL NUMBER OF LINEAR SYSTEMS AND COMPUTE THE ORDER +* OF EACH OF THEM +*---- + ALLOCATE(ISET(L4)) + ISET(1)=0 + K1=MUIN(1)+1 + DO 10 I=2,L4 + ISET(I)=0 + K2=MUIN(I) + DO 5 J=I-K2+K1,I-1 + ISET(J)=1 + 5 CONTINUE + K1=K2+1 + 10 CONTINUE + NSYS=0 + DO 15 I=1,L4 + IPV(I)=0 + MUV(I)=0 + IF(ISET(I).EQ.0) NSYS=NSYS+1 + 15 CONTINUE + LON=1+(NSYS-1)/ISEG + IF(IMPV.GE.2) WRITE (6,'(/35H VECPER: NUMBER OF INDEPENDANT LINE, + 1 22HAR SYSTEMS IN MATRIX '',A4,3H'' =,I7/9X,17HNUMBER OF GROUPS , + 1 19HOF LINEAR SYSTEMS =,I6)') HNAME,NSYS,LON + ALLOCATE(IORD(NSYS),IOFSET(NSYS)) + ISYS=0 + IORD0=0 + IOFSET(1)=1 + DO 20 I=1,L4 + IF(ISET(I).EQ.0) THEN + ISYS=ISYS+1 + IORD(ISYS)=I-IORD0 + IF(I.NE.L4) IOFSET(ISYS+1)=I+1 + IORD0=I + ENDIF + 20 CONTINUE + DEALLOCATE(ISET) +*---- +* SORT THE LINEAR SYSTEMS BY DECREASING ORDER +*---- + ALLOCATE(ISORT(NSYS)) + JNEW=NSYS + DO 25 ISYS=NSYS,1,-1 + IF(IORD(ISYS).EQ.1) THEN + ISORT(JNEW)=ISYS + JNEW=JNEW-1 + ENDIF + 25 CONTINUE + INEW=0 + 30 IBIG=0 + DO 50 ISYS=1,NSYS + IF(IORD(ISYS).EQ.1) GO TO 50 + DO 40 KSYS=1,INEW + IF(ISORT(KSYS).EQ.ISYS) GO TO 50 + 40 CONTINUE + IBIG=MAX(IBIG,IORD(ISYS)) + 50 CONTINUE + IF(IBIG.LE.1) GO TO 70 + DO 60 ISYS=1,NSYS + IF(IORD(ISYS).EQ.IBIG) THEN + INEW=INEW+1 + ISORT(INEW)=ISYS + ENDIF + 60 CONTINUE + GO TO 30 + 70 IF(INEW.NE.JNEW) CALL XABORT('VECPER: ALGORITHM FAILURE 1') + DO 80 I=1,LON + ISYS=ISORT((I-1)*ISEG+1) + NBL(I)=ISEG + LBL(I)=IORD(ISYS) + 80 CONTINUE + NBL(LON)=NSYS-(LON-1)*ISEG + IF(IMPV.GE.2) WRITE (6,'(9X,33HMAXIMUM ORDER OF AN INDEPENDANT L, + 1 14HINEAR SYSTEM =,I9)') LBL(1) + IF(IMPV.GE.3) THEN + I1=1 + DO 90 I=1,(LON-1)/8+1 + I2=I1+7 + IF(I2.GT.LON) I2=LON + WRITE (6,200) (J,J=I1,I2) + WRITE (6,210) (NBL(J),J=I1,I2) + WRITE (6,220) (LBL(J),J=I1,I2) + I1=I1+8 + 90 CONTINUE + ENDIF +*---- +* COMPUTE THE PERMUTATION MATRIX +*---- + LBL0=0 + KSYS=0 + DO 105 J=1,LON + DO 101 K=1,NBL(J) + KSYS=KSYS+1 + ISYS=ISORT(KSYS) + IOF0=IOFSET(ISYS) + IOF1=IOF0+IORD(ISYS)-1 + IF(IOF1.GT.L4) CALL XABORT('VECPER: ALGORITHM FAILURE 2') + DO 100 I=IOF0,IOF1 + IPV(I)=(LBL0+I-IOF0)*ISEG+K + 100 CONTINUE + 101 CONTINUE + LBL0=LBL0+LBL(J) + 105 CONTINUE + DO 110 I=1,L4 + IF(IPV(I).LE.0) CALL XABORT('VECPER: ALGORITHM FAILURE 3') + IF(IPV(I).GT.LBL0*ISEG) CALL XABORT('VECPER: ALGORITHM FAILURE 4') + 110 CONTINUE + L4NEW=0 + DO 115 J=1,LON + L4NEW=L4NEW+LBL(J)*NBL(J) + 115 CONTINUE + IF(IMPV.GE.2) WRITE (6,'(/35H VECPER: INCREASING NUMBER OF UNKNO, + 1 8HWNS FROM,I7,3H TO,I7,11H. FILL-IN =,F7.2,3H %.)') L4,L4NEW, + 2 100.0*(REAL(L4NEW)/REAL(L4)-1.0) +*---- +* COMPUTE THE VECTORIAL BANDWIDTH +*---- + LBL0=0 + KSYS=0 + IIMAX=0 + LTSW=0 + MAXNEW=0 + MUVOLD=0 + DO 150 J=1,LON + DO 120 I=1,LBL(J) + MUV(LBL0+I)=1 + 120 CONTINUE + DO 131 K=1,NBL(J) + KSYS=KSYS+1 + ISYS=ISORT(KSYS) + IOF0=IOFSET(ISYS)-1 + DO 130 I=2,IORD(ISYS) + IBIG=MUIN(IOF0+I)-MUIN(IOF0+I-1) + IF(IBIG.GT.MUV(LBL0+I)) MUV(LBL0+I)=IBIG + 130 CONTINUE + 131 CONTINUE + DO 140 I=1,LBL(J) + LTSW=MAX(LTSW,MUV(LBL0+I)) + IIMAX=IIMAX+MUV(LBL0+I) + MUV(LBL0+I)=IIMAX + 140 CONTINUE + LBL0=LBL0+LBL(J) + MAXNEW=MAXNEW+(MUV(LBL0)-MUVOLD)*NBL(J) + MUVOLD=MUV(LBL0) + 150 CONTINUE + IF(IMPV.GE.2) WRITE (6,'(/35H VECPER: INCREASING NUMBER OF TERMS, + 1 17H IN MATRICES FROM,I9,3H TO,I9,11H. FILL-IN =,F7.2,3H %./9X, + 2 19HMAXIMUM BANDWIDTH =,I4)') MUIN(L4),MAXNEW, + 3 100.0*(REAL(MAXNEW)/REAL(MUIN(L4))-1.0),LTSW +* + DEALLOCATE(ISORT,IOFSET,IORD) + RETURN +* + 200 FORMAT (//13H GROUP ,8(I8,5X,1HI)) + 210 FORMAT ( 13H NB. SYSTEMS ,8(I8,5X,1HI)) + 220 FORMAT ( 13H NB. UNKNOWNS,8(I8,5X,1HI)) + END diff --git a/Trivac/src/trimod.f90 b/Trivac/src/trimod.f90 new file mode 100755 index 0000000..d2eb489 --- /dev/null +++ b/Trivac/src/trimod.f90 @@ -0,0 +1,90 @@ +! +!----------------------------------------------------------------------- +! +!Purpose: +! Dispatch to a calculation module in TRIVAC. ANSI-C interoperable. +! +!Copyright: +! Copyright (C) 2009 Ecole Polytechnique de Montreal +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Lesser General Public +! License as published by the Free Software Foundation; either +! version 2.1 of the License, or (at your option) any later version. +! +!Author(s): A. Hebert +! +!----------------------------------------------------------------------- +! +integer(c_int) function trimod(cmodul, nentry, hentry, ientry, jentry, & + kentry, hparam_c) bind(c) +! + use GANLIB + implicit none +!---- +! subroutine arguments +!---- + character(kind=c_char), dimension(*) :: cmodul + integer(c_int), value :: nentry + character(kind=c_char), dimension(13,*) :: hentry + integer(c_int), dimension(nentry) :: ientry, jentry + type(c_ptr), dimension(nentry) :: kentry + character(kind=c_char), dimension(73,*) :: hparam_c +!---- +! local variables +!---- + integer :: i, ier + character :: hmodul*12, hsmg*131, hparam*72 + character(len=12), allocatable :: hentry_f(:) + type FIL_file_array + type(FIL_file), pointer :: my_file + end type FIL_file_array + type(FIL_file_array), pointer :: my_file_array(:) + integer, external :: KTRDRV +! + allocate(hentry_f(nentry),my_file_array(nentry)) + call STRFIL(hmodul, cmodul) + do i=1,nentry + call STRFIL(hentry_f(i), hentry(1,i)) + if((ientry(i) >= 3).and.(ientry(i) <= 5)) then +! open a Fortran file. + call STRFIL(hparam, hparam_c(1,i)) + my_file_array(i)%my_file=>FILOPN(hparam,jentry(i),ientry(i)-1,0) + if(.not.associated(my_file_array(i)%my_file)) then + write(hsmg,'(29htrimod: unable to open file '',a12,2h''.)') hentry_f(i) + call XABORT(hsmg) + endif + kentry(i)=c_loc(my_file_array(i)%my_file) + endif + enddo +! ---------------------------------------------------------- + trimod=KTRDRV(hmodul,nentry,hentry_f,ientry,jentry,kentry) +! ---------------------------------------------------------- + do i=1,nentry + if(jentry(i) == -2) then +! destroy a LCM object or a Fortran file. + if(ientry(i) <= 2) then + call LCMCL(kentry(i),2) + kentry(i)=c_null_ptr + else if((ientry(i) >= 3).and.(ientry(i) <= 5)) then + ier=FILCLS(my_file_array(i)%my_file,2) + if(ier < 0) then + write(hsmg,'(32htrimod: unable to destroy file '',a12,2h''.)') hentry_f(i) + call XABORT(hsmg) + endif + kentry(i)=c_null_ptr + endif + else +! close a Fortran file. + if((ientry(i) >= 3).and.(ientry(i) <= 5)) then + ier=FILCLS(my_file_array(i)%my_file,1) + if(ier < 0) then + write(hsmg,'(30htrimod: unable to close file '',a12,2h''.)') hentry_f(i) + call XABORT(hsmg) + endif + endif + endif + enddo + deallocate(my_file_array,hentry_f) + flush(6) + return +end function trimod |