Index: source/include/runopermod.f90 =================================================================== --- source/include/runopermod.f90 (revision 854) +++ source/include/runopermod.f90 (revision 855) @@ -66,8 +66,11 @@ !----------------------------------------------------------------------- ! integers to check largest array sizes +! +! nhparmax : max. no. of parameters defining operator labels +! nhlabmax : max. no. of operator labels defined in labels-section !----------------------------------------------------------------------- - integer(long), save :: minfac,minkoe,nhparmax + integer(long), save :: minfac,minkoe,nhparmax,nhlabmax !----------------------------------------------------------------------- ! flags governing operator generation Index: source/include/openmpmod.f90 =================================================================== --- source/include/openmpmod.f90 (revision 854) +++ source/include/openmpmod.f90 (revision 855) @@ -29,13 +29,12 @@ ! ! lompthread : set to true if threads are used !----------------------------------------------------------------------- - logical(kind=4), save :: lompthread = .false., & + logical(kind=4), save :: lompthread = .true., & lomptim,lexpectval, & lompmfield = .true., & + lompcalcha = .true., & + lompphihphi = .true., & lompqc = .true. -! lsummf, lmfields, lphihphi, & -! lfunka, lhlp1m, lfunkphi,lstarted,lmemcalcha,& -! lmemmfields,lsummf2,lgetdavmat,ldsyev,ldsyevkey !----------------------------------------------------------------------- ! PARAMETERS FOR ARRAY DIMENSIONS Index: source/mctdhlib/gwpphihphi.f90 =================================================================== --- source/mctdhlib/gwpphihphi.f90 (revision 854) +++ source/mctdhlib/gwpphihphi.f90 (revision 855) @@ -1,66 +0,0 @@ - module gwpphihphi - -use decimal, only: dop,long - - implicit none - private - public :: gh2hteil,gh2hteil1 - contains - -! ********************************************************************** - - subroutine gh2hteil(gh,hteil,dgwp,gwpdim,dim) - - implicit none - - integer(long) :: e,e1,e2,e3 - integer(long), intent(in) :: dim,gwpdim - complex(dop), dimension(gwpdim,gwpdim), intent(in) :: gh - complex(dop), dimension(dim,dim), intent(out) :: hteil - complex(dop), dimension(gwpdim,dim), intent(in) :: dgwp - - - do e1=1,dim - do e=1,dim - hteil(e,e1)=0.0_dop - do e2=1,gwpdim - do e3=1,gwpdim - hteil(e,e1) = hteil(e,e1)+& - dconjg(dgwp(e2,e))*gh(e2,e3)*dgwp(e3,e1) - enddo - enddo - enddo - enddo - - return - end subroutine gh2hteil - -!####################################################################### - - subroutine gh2hteil1(gh,hteil,dgwp,dgwp1,gwpdim,dim,gwpdim1,dim1) - - implicit none - - integer(long) :: e,e1,e2,e3 - integer(long), intent(in) :: dim,dim1,gwpdim,gwpdim1 - complex(dop), dimension(gwpdim,gwpdim1), intent(in) :: gh - complex(dop), dimension(dim,dim1), intent(out) :: hteil - complex(dop), dimension(gwpdim,dim), intent(in) :: dgwp - complex(dop), dimension(gwpdim1,dim1), intent(in) :: dgwp1 - - do e1=1,dim1 - do e=1,dim - hteil(e,e1)=0.0_dop - do e2=1,gwpdim - do e3=1,gwpdim1 - hteil(e,e1) = hteil(e,e1)+ & - dconjg(dgwp(e2,e))*gh(e2,e3)*dgwp1(e3,e1) - enddo - enddo - enddo - enddo - - return - end subroutine gh2hteil1 - - end module gwpphihphi Index: source/mctdhlib/densitymod.f90 =================================================================== --- source/mctdhlib/densitymod.f90 (revision 854) +++ source/mctdhlib/densitymod.f90 (revision 855) @@ -1,334 +0,0 @@ -!####################################################################### -! -! MCTDH-module DENSITY -! -! Calculates the reduced density matrices, their inverse matrices and -! their eigenvalues and eigenvectors. -! -! density: passing routine -! denmat: calculates the reduced density matrices -! matinv: inverts a matrix -! -! contains: density,denmat,matinv,denmatgwp -!####################################################################### - module densitymod - -use decimal, only: dop, long -use logdat -use timing -use mtlib, only: qtxxzz -use rmlib, only: rm1hxxxzz, rmhxxxzz -use op1lib, only: trhxz, cpvxz, zeromxz, unitqxz -use eqofmotion, only: compute_dmat_tree - - implicit none - private - public :: density,denmat,chngphs - contains - -!####################################################################### -! DENSITY -! -! Calculates the reduced density matrix etc. for a single mode. -! -! psi: wavefunction coefficients -! dicht1: inverse density matrix -! dicht2: reduced density matrix -! dicht3: eigenvalues and regularised eigenvalues of dicht2 -! dicht4: eigenvectors of dicht2 -! dim: number of single particle functions -! vdim: product of number of single particle functions of proceeding -! modes -! ndim: product of number of single particle functions of following -! modes -! - -! V6.3 MB -!####################################################################### - - subroutine density(psi,dicht1,dicht2,dicht3,dicht4,jindx,gs2) - -use global -use psidef -use griddatmod -use maxv, only: maxdim,maxsta -use ciselect, only: venpsi -use lalib, only: tranqxtzz -use runpropmod - - implicit none - - integer(long) :: s,m,iblock,& - zeig1,zeig2,zeig3,& - m1,f1 - integer(long), dimension(jindxdim), intent(in) :: jindx - integer(long), dimension(maxblock) :: worki - - real(dop) :: epsrel,norm,trace - real(dop), dimension(d3matdim), intent(out) :: dicht3 - complex(dop), dimension(dgldim), intent(in) :: psi - complex(dop), dimension(dmatdim), intent(out) :: dicht1,dicht2,dicht4 - complex(dop), dimension(2*maxblock) :: workc - complex(dop), dimension(gs2matdim), intent(in) :: gs2 - integer(long), save :: tid=0 ! timer ID - -!----------------------------------------------------------------------- -! For ML-MCTDH use different routine -!----------------------------------------------------------------------- - if (lrunml) then - call compute_dmat_tree(tree,psi) - return - endif - - call get_timer(tid, 'Density') - call start_timer(tid) - -!----------------------------------------------------------------------- -! calculate all density matrices -!----------------------------------------------------------------------- - zeig1=1 - zeig2=maxblock+1 - do s=1,nstate - do m=1,nmode - if(idmode(m).eq.0) then - if (citype .gt. 0) then - iblock=vdim(m,s)*dim(m,s)*ndim(m,s) - call venpsi(m,jindx(zpsi(s)),worki,jindx(zpsi(s)), & - block(s),iblock,block(s), & - nmode,vdim(m,s),dim(m,s),ndim(m,s),jvdim, & - workc(zeig1),psi(zpsi(s))) - call rm1hxxxzz(workc(zeig1),dicht2(dmat(m,s)), & - vdim(m,s),dim(m,s),ndim(m,s)) - else if (abs(psitype) .eq. 4) then - call cpvxz(psi(zpsi(s)),workc(zeig1),block(s)) - do m1=1,nmode - f1 = spfdof(1,m1) - if (m1 .ne. m .and. gwpm(m1)) then - zeig3=zeig1 - zeig1=zeig2 - zeig2=zeig3 - call qtxxzz(gs2(gs2mat(m1,s)),workc(zeig2), & - workc(zeig1),vdim(m1,s),dim(m1,s), & - ndim(m1,s)) - endif - enddo - call rmhxxxzz(psi(zpsi(s)),workc(zeig1), & - dicht2(dmat(m,s)),vdim(m,s),dim(m,s), & - ndim(m,s)) - - else - call rm1hxxxzz(psi(zpsi(s)),dicht2(dmat(m,s)), & - vdim(m,s),dim(m,s),ndim(m,s)) - endif - endif - - enddo - enddo - -!----------------------------------------------------------------------- -! compute norm and take a relative regularization parameter -!----------------------------------------------------------------------- - norm=0.0_dop - do s=1,nstate - call trhxz(dicht2(dmat(1,s)),trace,dim(1,s)) - norm=norm+trace - enddo - epsrel=norm*epsmat - if (lmulpack) epsrel=epsrel/dble(npacket) - if (mpb.gt.0) epsrel=epsrel/dble(npackts) - if (lreflex) epsrel=epsrel/dble(2.d0) - -!----------------------------------------------------------------------- -! regularize and invert density matrices for each mode and state -! neither the inverse nor the EVs of the density matrix -! will be needed if psitype == -4, 4. Instead store the diagonal -! elements of the density matrix in dicht3 -!----------------------------------------------------------------------- - do s=1,nstate - do m=1,nmode - if (idmode(m) .eq. 0) then - if (gwpm(m) .and. (abs(psitype) .eq. 4)) then - call denmatgwp(dicht2(dmat(m,s)), & - dicht3(d3mat(m,s)),dicht4(dmat(m,s)),dim(m,s)) - else - call denmat(dicht1(dmat(m,s)),dicht2(dmat(m,s)), & - dicht3(d3mat(m,s)),dicht4(dmat(m,s)),dim(m,s), & - epsrel) - endif - endif - - call chngphs( dicht4(dmat(m,s)), dim(m,s) ) - - enddo - enddo - - call stop_timer(tid) - - return - end subroutine density - -!####################################################################### -! DENMAT -! -! called by density -! calls to matinv -! -! Calculates the inverse reduced density matrix for a single mode. -! -! dicht1: inverse density matrix -! dicht2: reduced density matrix -! dicht3: eigenvalues and regularised eigenvalues of dicht2 -! dicht4: eigenvectors of dicht2 -! dim1: number of single particle functions -! -!####################################################################### - - subroutine denmat(dicht1,dicht2,dicht3,dicht4,dim1,epsrel) - -use global -use psidef - - implicit none - - integer(long) :: e,e1 - integer(long), intent(in) :: dim1 - complex(dop), dimension(dim1,dim1), intent(in) :: dicht2 - complex(dop), dimension(dim1,dim1), intent(out) :: dicht1,dicht4 - real(dop), intent(in) :: epsrel - real(dop), dimension(dim1,2), intent(out) :: dicht3 - -!----------------------------------------------------------------------- -! calculate regularized inverse density matrix -! Notice that negative of dicht2 is inverted, so that eigenvalues are -! ordered with largest at dicht3(1) -!----------------------------------------------------------------------- - do e=1,dim1 - do e1=1,dim1 - dicht4(e1,e)=-dicht2(e1,e) - enddo - enddo - - call matinv(dicht1,dicht3,dicht4,dim1,epsrel) - - return - end subroutine denmat - -!####################################################################### -! -! MATINV -! -! called by denmat -! calls to zheev -! -! calls diagonalisation routines for density matrix and from the -! eigenvalues (regularised) and eigenvectors so obtained calculates -! the inverse density matrix -! -! invers: returned as inverted matrix, used as scratch array. -! eval: eigenvalues of passed matrix -! evek: eigenvectors of passed matrix; on input: Matrix to be inverted. -! dim: dimensions of matrices e.g. invers(dim,dim) -! work: complex workspace -! -! V5.0 MB -!####################################################################### - - subroutine matinv(invers,eval,evek,dim,epsrel) - -use global - - implicit none - - integer(long) :: error,e,e1,e2 - integer(long), intent(in) :: dim - complex(dop), dimension(dim,dim), intent(out) :: invers - complex(dop), dimension(dim,dim) , intent(inout):: evek - real(dop), intent(in) :: epsrel - real(dop), dimension(dim,2), intent(out) :: eval - real(dop), dimension(3*dim) :: work - -!----------------------------------------------------------------------- -! diagonalize matrix -!----------------------------------------------------------------------- - e2 = dim*dim - call zheev('V','U',dim,evek,dim,eval,invers,e2,work,error) - if (error .ne. 0) then - routine = 'matinv' - message = 'Cannot diagonalize density matrix' - call errormsg - endif -!----------------------------------------------------------------------- -! take negative of eigenvalue (due to re-ordering) and regularize. -! The if-statement is introduced to avoid an underflow. -!----------------------------------------------------------------------- - do e=1,dim - eval(e,1)=-eval(e,1) - if( eval(e,1) .lt. 64.0_dop*epsrel) then - eval(e,2)=eval(e,1)+epsrel*exp(-eval(e,1)/epsrel) - else - eval(e,2)=eval(e,1) - endif - enddo - -!----------------------------------------------------------------------- -! calculate regularized inverse matrix -!----------------------------------------------------------------------- - call zeromxz(invers,dim,dim) - do e=1,dim - do e1=1,dim - do e2=1,dim - invers(e1,e)=invers(e1,e) + dconjg(evek(e,e2))*evek(e1,e2)/eval(e2,2) - enddo - enddo - invers(e,e)=dble(invers(e,e)) - enddo - - return - end subroutine matinv - -!####################################################################### - - subroutine denmatgwp(dicht2,dicht3,dicht4,dim1) - - integer, intent(in) :: dim1 - integer :: e - complex(dop), dimension(dim1,dim1), intent(in) :: dicht2 - complex(dop), dimension(dim1,dim1), intent(out) :: dicht4 - real(dop), dimension(dim1), intent(out) :: dicht3 - - do e=1,dim1 - dicht3(e) = dble(dicht2(e,e)) - enddo - - call unitqxz(dicht4,dim1) - - end subroutine denmatgwp - -!####################################################################### - - subroutine chngphs( evek, dim ) - - implicit none - integer(long) :: e1, e2 - integer(long), intent(in) :: dim - complex(dop) :: factor - complex(dop), dimension(dim,dim), intent(inout) :: evek - -!----------------------------------------------------------------------- -! Use the phase-convention: evek(e,e).gt.0, i.e. .gt.0 -!----------------------------------------------------------------------- - do e2=1,dim - if( abs(evek(e2,e2)) .gt. 1.0e-9_dop ) then - factor = abs(evek(e2,e2))/evek(e2,e2) - do e1=1,dim - evek(e1,e2) = evek(e1,e2)*factor - enddo - endif - enddo - - return - end subroutine chngphs - -!----------------------------------------------------------------------- - end module densitymod - Index: source/mctdhlib/phihphimod.F90 =================================================================== --- source/mctdhlib/phihphimod.F90 (revision 854) +++ source/mctdhlib/phihphimod.F90 (revision 855) @@ -22,7 +22,7 @@ use logdat use mmlib, only: mmaxzz, mmaxzzh, mmaxzzh1 use d2tens, only: mkherm -use op1lib, only: cpmxz, cpqxz, zeromxz +use op1lib, only: cpmxz, cpqxz, zeromxz,zerovxz,cpvxz use timing use mltypes @@ -33,7 +33,18 @@ use mpi #endif use mpidata +use openmpmod +use dvrdatmod +use griddatmod +use psidef +use hpsimod +use operdef +use gwpphihphi, only: gh2hteil, gh2hteil1,gh2hteil2 +use xlocphihphimod, only : xlocphihphi +use hphimod, only: hphi1mk +use xlocphihphimod, only : xlocphihphi + implicit none private public :: phihphi,phihunphi,phihunphig,phihphioct @@ -56,11 +67,6 @@ subroutine phihphi (psi,gh,hpsi,hteil,nham,lsym) -use global -use griddatmod -use psidef -use hpsimod - implicit none integer(long) :: m @@ -103,20 +109,6 @@ subroutine phihphipar(psi,psi1,hpsi,hteil,gh,nham,lsym) -!$ use omp_lib -use global -use dvrdatmod -use griddatmod -use psidef -use operdef -use hpsimod -use openmpmod - -use gwpphihphi, only: gh2hteil, gh2hteil1 -use xlocphihphimod, only : xlocphihphi -use op1lib, only: cpvxz -use d2tens, only : mkherm - implicit none integer(long) :: k,m,s,s1,k1,k2,f,h @@ -142,13 +134,14 @@ call mpiphihphi(psi,psi1,hpsi,hteil,nham,lsym,gh) else #endif + !----------------------------------------------------------------------- ! If no parallelisation is used then a usual calculation is ! performed. !----------------------------------------------------------------------- ! --- LOOP OVER EACH MODE AND STATE --- -!$omp parallel num_threads(ompthread) if(lompthread) -!$omp do private(m,f,k,s,s1) +!$omp parallel num_threads(ompthread) if(lompthread .and. lompphihphi) +!$omp do private(m,f,k,s,s1) schedule(dynamic) do k = k1,k2 s=kf(k) s1=ki(k) @@ -179,15 +172,12 @@ else if (hsym(m,k) .eq. 1) then if (gwpm(m)) then if (psitype .eq. 0 .or. psitype .eq. 5) then - call gh2hteil1(gh(ghmat(k,m)),hteil(pmat(m,k)),& - psi(zdgwp(m,s)),psi(zdgwp(m,s1)),& - gwpdim(m,s),dim(m,s),gwpdim(m,s1),dim(m,s1)) + call gh2hteil(gh(ghmat(k,m)),hteil(pmat(m,k)),& + psi(zdgwp(m,s)),gwpdim(m,s),dim(m,s)) else call cpmxz(gh(ghmat(k,m)),hteil(pmat(m,k)),& dim(m,s),dim(m,s1)) endif - if (s .eq. s1) & - call mkherm(hteil(pmat(m,k)),dim(m,s)) else if(basis(f).eq.26 .or. basis(f) .eq. 27)then h=hamilton(f,k) call xlocphihphi(psi(zetf(m,1)),hteil(pmat(m,k)),h,f,& @@ -199,7 +189,7 @@ else if (hsym(m,k) .eq. -1) then if(gwpm(m))then if (psitype .eq. 0 .or. psitype .eq. 5) then - call gh2hteil(gh(ghmat(k,m)),hteil(pmat(m,k)),& + call gh2hteil2(gh(ghmat(k,m)),hteil(pmat(m,k)),& psi(zdgwp(m,s)),gwpdim(m,s),dim(m,s)) else call cpmxz(gh(ghmat(k,m)),hteil(pmat(m,k)),& @@ -249,14 +239,6 @@ subroutine phihphioct(psi,psi1,hpsi,hteil,nham,lsym) -use global -use griddatmod -use psidef -use operdef -use hpsimod - -use hphimod, only: hphi1mk - implicit none integer(long) :: k,m,s,s1,k1,k2 @@ -302,16 +284,6 @@ subroutine phihunphi (psi,hunpsi,hung,hteil,nham) -!$ use omp_lib -use griddatmod -use operdef -use psidef -use hpsimod -use openmpmod - -use gwpphihphi, only: gh2hteil -use d2tens, only : mkherm - implicit none integer(long) :: m,s,kz @@ -329,8 +301,8 @@ kz=zham(nham)+kzahl(nham)-1 -! omp parallel do num_threads(ompthread) if(lompthread) & -! omp private(m,s) +!$omp parallel num_threads(ompthread) if(lompthread .and. lompphihphi) +!$omp do private(m,s) do m = 1,nmode ! Gaussian mode : @@ -359,7 +331,8 @@ enddo endif enddo -! omp end parallel do +!$omp enddo +!$omp end parallel #ifdef MPI @@ -385,14 +358,6 @@ subroutine phihunphig (m,psi,hung,hteil,nham,zetf1,phidim1) -use griddatmod -use operdef -use psidef -use hpsimod - -use gwpphihphi, only: gh2hteil -use d2tens, only : mkherm - implicit none integer(long) :: m,s,kz @@ -429,11 +394,6 @@ subroutine d2phihphi1m (psi,hpsi,hteil,m,zetf1,phidim1,nham, & lsym) -use griddatmod -use operdef -use psidef -use hpsimod - implicit none integer(long) :: k,k1,k2,k3,s,s1 @@ -447,6 +407,8 @@ k2=zham(nham) k3=zham(nham)+kzahl(nham)-1 +!$omp parallel num_threads(ompthread) if(lompthread .and. lompphihphi) +!$omp do private(k,k1,s,s1) schedule (dynamic) do k = k2,k3 if (.not. diag(m,k) .and. k .eq. kfirst(m,k) ) then s=kf(k) @@ -487,6 +449,8 @@ endif enddo +!$omp end do +!$omp end parallel return end subroutine d2phihphi1m @@ -498,21 +462,6 @@ #ifdef MPI subroutine mpiphihphi(psi,psi1,hpsi,hteil,nham,lsym,gh) -use dvrdatmod -use griddatmod -use operdef -use psidef -use hpsimod -use timing -use hpsimod - -use op1lib, only: zerovxz,cpvxz -use mmlib, only: mmaxzz,mmaxzzh,mmaxzzh1 -!use hphimod, only: hphi1mk -use gwpphihphi, only: gh2hteil,gh2hteil1 -use xlocphihphimod, only : xlocphihphi -use d2tens, only : mkherm - implicit none integer(long), intent(in) :: nham Index: source/mctdhlib/gh_elementsmod.f90 =================================================================== --- source/mctdhlib/gh_elementsmod.f90 (revision 854) +++ source/mctdhlib/gh_elementsmod.f90 (revision 855) @@ -1376,7 +1376,7 @@ imoment = 0 !$omp parallel if(lompthread) num_threads(ompthread) & -!$omp private(jg,p1,ig,momval,pfactor,pmoment,imoment) +!$omp private(jg,p1,ig,momval,pfactor,pmoment,imoment,n,n1,n2,n3) !$omp do schedule(dynamic) do jg=1,gwpdim2 ! scalar term @@ -1395,12 +1395,9 @@ enddo enddo !$omp end do -!$omp end parallel ! linear terms if (gwpintord .lt. 1) go to 999 -!$omp parallel if(lompthread) num_threads(ompthread) & -!$omp private(jg,p1,ig,momval,pfactor,pmoment,imoment,n) !$omp do schedule(dynamic) do jg=1,gwpdim2 do n=1,gdof @@ -1421,12 +1418,9 @@ enddo enddo !$omp end do -!$omp end parallel ! bilinear + quadratic terms if (gwpintord .lt. 2) go to 999 -!$omp parallel if(lompthread) num_threads(ompthread) & -!$omp private(jg,p1,ig,momval,pfactor,pmoment,imoment,n,n1) !$omp do schedule(dynamic) do jg=1,gwpdim2 do n=1,gdof @@ -1452,12 +1446,9 @@ enddo enddo !$omp end do -!$omp end parallel ! cubic terms if (gwpintord .lt. 3) go to 999 -!$omp parallel if(lompthread) num_threads(ompthread) & -!$omp private(jg,p1,ig,momval,pfactor,pmoment,imoment,n,n1,n2) !$omp do schedule(dynamic) do jg=1,gwpdim2 do n=1,gdof @@ -1485,12 +1476,9 @@ enddo enddo !$omp end do -!$omp end parallel ! quartic terms if (gwpintord .lt. 4) go to 999 -!$omp parallel if(lompthread) num_threads(ompthread) & -!$omp private(jg,p1,ig,momval,pfactor,pmoment,imoment,n,n1,n2,n3) !$omp do schedule(dynamic) do jg=1,gwpdim2 do n=1,gdof @@ -1521,10 +1509,10 @@ enddo enddo !$omp end do + 999 continue + !$omp end parallel - 999 continue - call stop_timer(tid) return Index: source/mctdhlib/gwpphihphi.F90 =================================================================== --- source/mctdhlib/gwpphihphi.F90 (revision 0) +++ source/mctdhlib/gwpphihphi.F90 (revision 855) @@ -0,0 +1,246 @@ + module gwpphihphi + +use decimal, only: dop,long +use openmpmod + + implicit none + private + public :: gh2hteil,gh2hteil1,gh2hteil2 + contains + +! ********************************************************************** +! +! Hermitian hteil + + subroutine gh2hteil(gh,hteil,dgwp,gwpdim,dim) + + implicit none + + integer(long) :: e,e1,e2,e3 + integer(long), intent(in) :: dim,gwpdim + complex(dop), dimension(gwpdim,gwpdim), intent(in) :: gh + complex(dop), dimension(dim,dim), intent(out) :: hteil + complex(dop), dimension(gwpdim,dim), intent(in) :: dgwp + complex(dop), dimension(gwpdim,dim) :: ztmp + +#ifdef OMP + ztmp(:,:)=0.0d0 + hteil(:,:)=0.0_dop +!$omp parallel num_threads(ompthread) +!$omp do reduction(+:ztmp) + do e3=1,gwpdim + do e1=1,dim + do e2=1,gwpdim + ztmp(e2,e1) = ztmp(e2,e1)+gh(e2,e3)*dgwp(e3,e1) + enddo + enddo + enddo +!$omp end do +!$omp do reduction(+:hteil) + do e2=1,gwpdim + do e1=1,dim + do e=1,dim + hteil(e,e1) = hteil(e,e1)+dconjg(dgwp(e2,e))*ztmp(e2,e1) + enddo + enddo + enddo +!$omp end do +! make Hermitian +!$omp do + do e=1,dim + hteil(e,e)=dble(hteil(e,e)) + enddo +!$omp end do +!$omp do + do e1=1,dim-1 + do e=e1+1,dim + hteil(e1,e)=0.5d0*(hteil(e1,e) + dconjg(hteil(e,e1))) + hteil(e,e1)=dconjg(hteil(e1,e)) + enddo + enddo +!$omp end do +!$omp end parallel + +#else + + ztmp(:,:)=0.0d0 + hteil(:,:)=0.0_dop + do e3=1,gwpdim + do e1=1,dim + do e2=1,gwpdim + ztmp(e2,e1) = ztmp(e2,e1)+gh(e2,e3)*dgwp(e3,e1) + enddo + enddo + enddo + do e2=1,gwpdim + do e1=1,dim + do e=1,dim + hteil(e,e1) = hteil(e,e1)+dconjg(dgwp(e2,e))*ztmp(e2,e1) + enddo + enddo + enddo +! make Hermitian + do e=1,dim + hteil(e,e)=dble(hteil(e,e)) + enddo + do e=1,dim-1 + do e1=e+1,dim + hteil(e1,e)=0.5d0*(hteil(e1,e) + dconjg(hteil(e,e1))) + hteil(e,e1)=dconjg(hteil(e1,e)) + enddo + enddo +#endif + + return + end subroutine gh2hteil + +!####################################################################### + + subroutine gh2hteil1(gh,hteil,dgwp,dgwp1,gwpdim,dim,gwpdim1,dim1) + + implicit none + + integer(long) :: e,e1,e2,e3 + integer(long), intent(in) :: dim,dim1,gwpdim,gwpdim1 + complex(dop), dimension(gwpdim,gwpdim1), intent(in) :: gh + complex(dop), dimension(dim,dim1), intent(out) :: hteil + complex(dop), dimension(gwpdim,dim), intent(in) :: dgwp + complex(dop), dimension(gwpdim1,dim1), intent(in) :: dgwp1 + complex(dop), dimension(gwpdim,dim1) :: ztmp + +#ifdef OMP + ztmp(:,:)=0.0_dop + hteil(:,:)=0.0_dop +!$omp parallel num_threads(ompthread) +!$omp do reduction(+:ztmp) + do e3=1,gwpdim1 + do e1=1,dim1 + do e2=1,gwpdim + ztmp(e2,e1) = ztmp(e2,e1)+ gh(e2,e3)*dgwp1(e3,e1) + enddo + enddo + enddo +!$omp end do +!$omp do reduction(+:hteil) + do e2=1,gwpdim + do e1=1,dim1 + do e=1,dim + hteil(e,e1) = hteil(e,e1)+ dconjg(dgwp(e2,e))*ztmp(e2,e1) + enddo + enddo + enddo +!$omp end do +!$omp end parallel + +#else + + ztmp(:,:)=0.0_dop + hteil(:,:)=0.0_dop + do e3=1,gwpdim1 + do e1=1,dim1 + do e2=1,gwpdim + ztmp(e2,e1) = ztmp(e2,e1)+ gh(e2,e3)*dgwp1(e3,e1) + enddo + enddo + enddo + do e2=1,gwpdim + do e1=1,dim1 + do e=1,dim + hteil(e,e1) = hteil(e,e1)+ dconjg(dgwp(e2,e))*ztmp(e2,e1) + enddo + enddo + enddo +#endif + + return + end subroutine gh2hteil1 + +! ********************************************************************** +! +! Anti-Hermitian hteil + + subroutine gh2hteil2(gh,hteil,dgwp,gwpdim,dim) + + implicit none + + integer(long) :: e,e1,e2,e3 + integer(long), intent(in) :: dim,gwpdim + real(dop) :: x + complex(dop), dimension(gwpdim,gwpdim), intent(in) :: gh + complex(dop), dimension(dim,dim), intent(out) :: hteil + complex(dop), dimension(gwpdim,dim), intent(in) :: dgwp + complex(dop), dimension(gwpdim,dim) :: ztmp + +#ifdef OMP + hteil(:,:)=0.0_dop + ztmp(:,:)=0.0_dop +!$omp parallel num_threads(ompthread) +!$omp do reduction(+:ztmp) + do e3=1,gwpdim + do e1=1,dim + do e2=1,gwpdim + ztmp(e2,e1) = ztmp(e2,e1)+gh(e2,e3)*dgwp(e3,e1) + enddo + enddo + enddo +!$omp end do +!$omp do reduction(+:hteil) + do e2=1,gwpdim + do e1=1,dim + do e=1,dim + hteil(e,e1) = hteil(e,e1)+dconjg(dgwp(e2,e))*ztmp(e2,e1) + enddo + enddo + enddo +!$omp end do +! make anti-Hermitian +!$omp do + do e=1,dim + x=dimag(hteil(e,e)) + hteil(e,e)=dcmplx(0.0d0,x) + enddo +!$omp end do +!$omp do + do e1=1,dim-1 + do e=e1+1,dim + hteil(e1,e)=0.5d0*(hteil(e1,e) - dconjg(hteil(e,e1))) + hteil(e,e1)=-dconjg(hteil(e1,e)) + enddo + enddo +!$omp end do +!$omp end parallel + +#else + hteil(:,:)=0.0_dop + ztmp(:,:)=0.0_dop + do e3=1,gwpdim + do e1=1,dim + do e2=1,gwpdim + ztmp(e2,e1) = ztmp(e2,e1)+gh(e2,e3)*dgwp(e3,e1) + enddo + enddo + enddo + do e2=1,gwpdim + do e1=1,dim + do e=1,dim + hteil(e,e1) = hteil(e,e1)+dconjg(dgwp(e2,e))*ztmp(e2,e1) + enddo + enddo + enddo +! make anti-Hermitian + do e=1,dim + x=dimag(hteil(e,e)) + hteil(e,e)=dcmplx(0.0d0,x) + enddo + do e=1,dim-1 + do e1=e+1,dim + hteil(e1,e)=0.5d0*(hteil(e1,e) - dconjg(hteil(e,e1))) + hteil(e,e1)=-dconjg(hteil(e1,e)) + enddo + enddo +#endif + + return + end subroutine gh2hteil2 + + end module gwpphihphi Index: source/mctdhlib/calchamod.F90 =================================================================== --- source/mctdhlib/calchamod.F90 (revision 854) +++ source/mctdhlib/calchamod.F90 (revision 855) @@ -176,7 +176,7 @@ ! --- LOOP OVER EACH CORRELATED HAMILTONIAN TERM --- -!$omp parallel num_threads(ompthread) private(k,s,s1,ithr) if(lompthread) +!$omp parallel num_threads(ompthread) private(k,s,s1,ithr) if(lompthread .and. lompcalcha) !$omp do schedule(dynamic) do k=k0,koffset #ifdef OMP @@ -317,13 +317,8 @@ workc(zeig1),workc(zeig2)) block2=block1 call cpvxi(worki(zeig1),worki(zeig2),block1) - ! if(.not.lompthread)then - call qtxxzz(hteil(pmat(m,k)),workc(zeig1), & - workc(zeig2),vdim(m,s),dim(m,s),ndim(m,s)) - ! else - ! call qtxxzzomp(hteil(pmat(m,k)),workc(zeig1), & - ! workc(zeig2),vdim(m,s),dim(m,s),ndim(m,s),ompthread) - ! endif + call qtxxzz(hteil(pmat(m,k)),workc(zeig1), & + workc(zeig2),vdim(m,s),dim(m,s),ndim(m,s)) endif enddo @@ -348,13 +343,8 @@ ! --- MULTIPLY WITH MATRIX ELEMENTS --- - ! if(.not.lompthread)then - call qtxxzz(hteil(pmat(m,k)),workc(zeig1), & - workc(zeig2),vdim(m,s),dim(m,s),ndim(m,s)) - ! else - ! call qtxxzzomp(hteil(pmat(m,k)),workc(zeig1), & - ! workc(zeig2),vdim(m,s),dim(m,s),ndim(m,s),ompthread) - ! endif + call qtxxzz(hteil(pmat(m,k)),workc(zeig1), & + workc(zeig2),vdim(m,s),dim(m,s),ndim(m,s)) endif enddo endif @@ -538,13 +528,8 @@ ! --- MULTIPLY WITH MATRIX ELEMENTS --- - ! if(.not.lompthread)then - call qtxxzz(hteil(pmat(m,k)),workc(zeig1), & - workc(zeig2),vdim(m,s),dim(m,s),ndim(m,s)) - ! else - ! call qtxxzzomp(hteil(pmat(m,k)),workc(zeig1), & - ! workc(zeig2),vdim(m,s),dim(m,s),ndim(m,s),ompthread) - ! endif + call qtxxzz(hteil(pmat(m,k)),workc(zeig1), & + workc(zeig2),vdim(m,s),dim(m,s),ndim(m,s)) endif 10 continue enddo @@ -600,13 +585,8 @@ ! --- MULTIPLY WITH MATRIX ELEMENTS --- - ! if(.not.lompthread)then - call qtxxzz(hteil(pmat(m,k)),workc(zeig1), & - workc(zeig2),vdim(m,s),dim(m,s),ndim(m,s)) - ! else - ! call qtxxzzomp(hteil(pmat(m,k)),workc(zeig1), & - ! workc(zeig2),vdim(m,s),dim(m,s),ndim(m,s),ompthread) - ! endif + call qtxxzz(hteil(pmat(m,k)),workc(zeig1), & + workc(zeig2),vdim(m,s),dim(m,s),ndim(m,s)) endif 10 continue enddo @@ -701,13 +681,8 @@ ! --- MULTIPLY WITH MATRIX ELEMENTS --- call zerovxz(workc(zeig2),maxblock) - ! if(.not.lompthread)then - call mtxxzz(hteil(pmat(m,k)),workc(zeig1), & - workc(zeig2),vdim1,dim(m,s1),ndim(m,s1),dim(m,s)) - ! else - ! call mtxxzzomp(hteil(pmat(m,k)),workc(zeig1), & - ! workc(zeig2),vdim1,dim(m,s1),ndim(m,s1),dim(m,s),ompthread) - ! endif + call mtxxzz(hteil(pmat(m,k)),workc(zeig1), & + workc(zeig2),vdim1,dim(m,s1),ndim(m,s1),dim(m,s)) vdim1 = vdim1*dim(m,s) enddo @@ -1227,7 +1202,7 @@ ! Comment in the collapse version when GFortran updated. GWR 08/13 ! omp parallel do num_threads(ompthread) if(s.ge.3) private(s,m) collapse(2) -!$omp parallel do num_threads(ompthread) private(s,m) +!$omp parallel do num_threads(ompthread) private(s,m) if (lompthread .and. lompcalcha) do s=1,nstate do m=1,nmode if (khzahl(m,s,nham) .gt. 0) then Index: source/mctdhlib/densitymod.F90 =================================================================== --- source/mctdhlib/densitymod.F90 (revision 0) +++ source/mctdhlib/densitymod.F90 (revision 855) @@ -0,0 +1,338 @@ +!####################################################################### +! +! MCTDH-module DENSITY +! +! Calculates the reduced density matrices, their inverse matrices and +! their eigenvalues and eigenvectors. +! +! density: passing routine +! denmat: calculates the reduced density matrices +! matinv: inverts a matrix +! +! contains: density,denmat,matinv,denmatgwp +!####################################################################### + module densitymod + +use decimal, only: dop, long +use logdat +use timing +use mtlib, only: qtxxzz +use rmlib, only: rm1hxxxzz, rmhxxxzz +#ifdef OMP +use rmomplib, only: rm1hxxxzzomp +#endif +use op1lib, only: trhxz, cpvxz, zeromxz, unitqxz +use eqofmotion, only: compute_dmat_tree +use openmpmod + + implicit none + private + public :: density,denmat,chngphs + contains + +!####################################################################### +! DENSITY +! +! Calculates the reduced density matrix etc. for a single mode. +! +! psi: wavefunction coefficients +! dicht1: inverse density matrix +! dicht2: reduced density matrix +! dicht3: eigenvalues and regularised eigenvalues of dicht2 +! dicht4: eigenvectors of dicht2 +! dim: number of single particle functions +! vdim: product of number of single particle functions of proceeding +! modes +! ndim: product of number of single particle functions of following +! modes +! + +! V6.3 MB +!####################################################################### + + subroutine density(psi,dicht1,dicht2,dicht3,dicht4,jindx,gs2) + +use global +use psidef +use griddatmod +use maxv, only: maxdim,maxsta +use ciselect, only: venpsi +use lalib, only: tranqxtzz +use runpropmod + + implicit none + + integer(long) :: s,m,iblock,& + zeig1,zeig2,zeig3,& + m1,f1 + integer(long), dimension(jindxdim), intent(in) :: jindx + integer(long), dimension(maxblock) :: worki + + real(dop) :: epsrel,norm,trace + real(dop), dimension(d3matdim), intent(out) :: dicht3 + complex(dop), dimension(dgldim), intent(in) :: psi + complex(dop), dimension(dmatdim), intent(out) :: dicht1,dicht2,dicht4 + complex(dop), dimension(2*maxblock) :: workc + complex(dop), dimension(gs2matdim), intent(in) :: gs2 + integer(long), save :: tid=0 ! timer ID + +!----------------------------------------------------------------------- +! For ML-MCTDH use different routine +!----------------------------------------------------------------------- + if (lrunml) then + call compute_dmat_tree(tree,psi) + return + endif + + call get_timer(tid, 'Density') + call start_timer(tid) + +!----------------------------------------------------------------------- +! calculate all density matrices +!----------------------------------------------------------------------- + zeig1=1 + zeig2=maxblock+1 + do s=1,nstate + do m=1,nmode + if(idmode(m).eq.0) then + if (citype .gt. 0) then + iblock=vdim(m,s)*dim(m,s)*ndim(m,s) + call venpsi(m,jindx(zpsi(s)),worki,jindx(zpsi(s)), & + block(s),iblock,block(s), & + nmode,vdim(m,s),dim(m,s),ndim(m,s),jvdim, & + workc(zeig1),psi(zpsi(s))) + call rm1hxxxzz(workc(zeig1),dicht2(dmat(m,s)), & + vdim(m,s),dim(m,s),ndim(m,s)) + else if (abs(psitype) .eq. 4) then + call cpvxz(psi(zpsi(s)),workc(zeig1),block(s)) + do m1=1,nmode + f1 = spfdof(1,m1) + if (m1 .ne. m .and. gwpm(m1)) then + zeig3=zeig1 + zeig1=zeig2 + zeig2=zeig3 + call qtxxzz(gs2(gs2mat(m1,s)),workc(zeig2), & + workc(zeig1),vdim(m1,s),dim(m1,s), & + ndim(m1,s)) + endif + enddo + call rmhxxxzz(psi(zpsi(s)),workc(zeig1), & + dicht2(dmat(m,s)),vdim(m,s),dim(m,s), & + ndim(m,s)) + + else + call rm1hxxxzz(psi(zpsi(s)),dicht2(dmat(m,s)), & + vdim(m,s),dim(m,s),ndim(m,s)) + endif + endif + + enddo + enddo + +!----------------------------------------------------------------------- +! compute norm and take a relative regularization parameter +!----------------------------------------------------------------------- + norm=0.0_dop + do s=1,nstate + call trhxz(dicht2(dmat(1,s)),trace,dim(1,s)) + norm=norm+trace + enddo + epsrel=norm*epsmat + if (lmulpack) epsrel=epsrel/dble(npacket) + if (mpb.gt.0) epsrel=epsrel/dble(npackts) + if (lreflex) epsrel=epsrel/dble(2.d0) + +!----------------------------------------------------------------------- +! regularize and invert density matrices for each mode and state +! neither the inverse nor the EVs of the density matrix +! will be needed if psitype == -4, 4. Instead store the diagonal +! elements of the density matrix in dicht3 +!----------------------------------------------------------------------- + do s=1,nstate + do m=1,nmode + if (idmode(m) .eq. 0) then + if (gwpm(m) .and. (abs(psitype) .eq. 4)) then + call denmatgwp(dicht2(dmat(m,s)), & + dicht3(d3mat(m,s)),dicht4(dmat(m,s)),dim(m,s)) + else + call denmat(dicht1(dmat(m,s)),dicht2(dmat(m,s)), & + dicht3(d3mat(m,s)),dicht4(dmat(m,s)),dim(m,s), & + epsrel) + endif + endif + + call chngphs( dicht4(dmat(m,s)), dim(m,s) ) + + enddo + enddo + + call stop_timer(tid) + + return + end subroutine density + +!####################################################################### +! DENMAT +! +! called by density +! calls to matinv +! +! Calculates the inverse reduced density matrix for a single mode. +! +! dicht1: inverse density matrix +! dicht2: reduced density matrix +! dicht3: eigenvalues and regularised eigenvalues of dicht2 +! dicht4: eigenvectors of dicht2 +! dim1: number of single particle functions +! +!####################################################################### + + subroutine denmat(dicht1,dicht2,dicht3,dicht4,dim1,epsrel) + +use global +use psidef + + implicit none + + integer(long) :: e,e1 + integer(long), intent(in) :: dim1 + complex(dop), dimension(dim1,dim1), intent(in) :: dicht2 + complex(dop), dimension(dim1,dim1), intent(out) :: dicht1,dicht4 + real(dop), intent(in) :: epsrel + real(dop), dimension(dim1,2), intent(out) :: dicht3 + +!----------------------------------------------------------------------- +! calculate regularized inverse density matrix +! Notice that negative of dicht2 is inverted, so that eigenvalues are +! ordered with largest at dicht3(1) +!----------------------------------------------------------------------- + do e=1,dim1 + do e1=1,dim1 + dicht4(e1,e)=-dicht2(e1,e) + enddo + enddo + + call matinv(dicht1,dicht3,dicht4,dim1,epsrel) + + return + end subroutine denmat + +!####################################################################### +! +! MATINV +! +! called by denmat +! calls to zheev +! +! calls diagonalisation routines for density matrix and from the +! eigenvalues (regularised) and eigenvectors so obtained calculates +! the inverse density matrix +! +! invers: returned as inverted matrix, used as scratch array. +! eval: eigenvalues of passed matrix +! evek: eigenvectors of passed matrix; on input: Matrix to be inverted. +! dim: dimensions of matrices e.g. invers(dim,dim) +! work: complex workspace +! +! V5.0 MB +!####################################################################### + + subroutine matinv(invers,eval,evek,dim,epsrel) + +use global + + implicit none + + integer(long) :: error,e,e1,e2 + integer(long), intent(in) :: dim + complex(dop), dimension(dim,dim), intent(out) :: invers + complex(dop), dimension(dim,dim) , intent(inout):: evek + real(dop), intent(in) :: epsrel + real(dop), dimension(dim,2), intent(out) :: eval + real(dop), dimension(3*dim) :: work + +!----------------------------------------------------------------------- +! diagonalize matrix +!----------------------------------------------------------------------- + e2 = dim*dim + call zheev('V','U',dim,evek,dim,eval,invers,e2,work,error) + if (error .ne. 0) then + routine = 'matinv' + message = 'Cannot diagonalize density matrix' + call errormsg + endif +!----------------------------------------------------------------------- +! take negative of eigenvalue (due to re-ordering) and regularize. +! The if-statement is introduced to avoid an underflow. +!----------------------------------------------------------------------- + do e=1,dim + eval(e,1)=-eval(e,1) + if( eval(e,1) .lt. 64.0_dop*epsrel) then + eval(e,2)=eval(e,1)+epsrel*exp(-eval(e,1)/epsrel) + else + eval(e,2)=eval(e,1) + endif + enddo + +!----------------------------------------------------------------------- +! calculate regularized inverse matrix +!----------------------------------------------------------------------- + call zeromxz(invers,dim,dim) + do e=1,dim + do e1=1,dim + do e2=1,dim + invers(e1,e)=invers(e1,e) + dconjg(evek(e,e2))*evek(e1,e2)/eval(e2,2) + enddo + enddo + invers(e,e)=dble(invers(e,e)) + enddo + + return + end subroutine matinv + +!####################################################################### + + subroutine denmatgwp(dicht2,dicht3,dicht4,dim1) + + integer, intent(in) :: dim1 + integer :: e + complex(dop), dimension(dim1,dim1), intent(in) :: dicht2 + complex(dop), dimension(dim1,dim1), intent(out) :: dicht4 + real(dop), dimension(dim1), intent(out) :: dicht3 + + do e=1,dim1 + dicht3(e) = dble(dicht2(e,e)) + enddo + + call unitqxz(dicht4,dim1) + + end subroutine denmatgwp + +!####################################################################### + + subroutine chngphs( evek, dim ) + + implicit none + integer(long) :: e1, e2 + integer(long), intent(in) :: dim + complex(dop) :: factor + complex(dop), dimension(dim,dim), intent(inout) :: evek + +!----------------------------------------------------------------------- +! Use the phase-convention: evek(e,e).gt.0, i.e. .gt.0 +!----------------------------------------------------------------------- + do e2=1,dim + if( abs(evek(e2,e2)) .gt. 1.0e-9_dop ) then + factor = abs(evek(e2,e2))/evek(e2,e2) + do e1=1,dim + evek(e1,e2) = evek(e1,e2)*factor + enddo + endif + enddo + + return + end subroutine chngphs + +!----------------------------------------------------------------------- + end module densitymod + Index: source/mctdhlib/hphimod.F90 =================================================================== --- source/mctdhlib/hphimod.F90 (revision 854) +++ source/mctdhlib/hphimod.F90 (revision 855) @@ -318,7 +318,7 @@ else if (hktype .eq. 2 .and. autocap(k) .lt. 0) then if (nstatecap(k) .eq. 0 .or. nstatecap(k) .eq. s) kcalc(k)=.true. else - kcalc(k)=.false. + kcalc(k)=.false. endif enddo Index: source/analyse/compare.F90 =================================================================== --- source/analyse/compare.F90 (revision 854) +++ source/analyse/compare.F90 (revision 855) @@ -666,13 +666,18 @@ write(idat,*) write(idat,'(80a1)') ('#',i=1,80) - if (hpassed .and. lrun) then - write(isum,'(2a)') name(1:ilbl)//' : Passed hard limit ' + write(isum,'(2a,f12.4,a,f12.4)') & + name(1:ilbl), ' : Passed hard limit. Time ratio: ',& + sys2/sys1,' Memory ratio: ',mem2/mem1 else if (spassed .and. lrun) then - write(isum,'(2a)') name(1:ilbl)//' : Passed *SOFT* limit ' + write(isum,'(2a,f12.4,a,f12.4)') & + name(1:ilbl),' : Passed *SOFT* limit. Time ratio: ',& + sys2/sys1,' Memory ratio: ',mem2/mem1 else - write(isum,'(2a)') name(1:ilbl)//' : FAILED ' + write(isum,'(2a,f12.4,a,f12.4)') & + name(1:ilbl), ' : FAILED. Time ratio: ',& + sys2/sys1,' Memory ratio: ',mem2/mem1 endif close(idat) Index: source/genoper/einopermod.f90 =================================================================== --- source/genoper/einopermod.f90 (revision 854) +++ source/genoper/einopermod.f90 (revision 855) @@ -344,7 +344,7 @@ if (pass .eq. 1) then maxkoe=minkoe+maxsta*hamdim maxham=hamdim - maxhop=hopdim + maxhop=max(hopdim,nhlabmax) maxhtm=htmdim ! +1 needed in gh_elements to search past end of factors maxfac=minfac+1 Index: source/genoper/heinlab.F90 =================================================================== --- source/genoper/heinlab.F90 (revision 854) +++ source/genoper/heinlab.F90 (revision 855) @@ -52,6 +52,7 @@ endif nhparmax=0 + nhlabmax=max(hopdim,0) maxlen=0 lprint=.true. @@ -185,12 +186,13 @@ else nhpar=nhpar+1 - if (nhpar .le. maxhpar) then + if ((nhpar .le. maxhpar) .and. (np .lt. maxhop)) then call rdfactors(keyorig(i),nfac,factor,optyp,lc(i)) call mkhpar(x,nfac,factor,optyp) hoppar(nhpar,np)=x else nhparmax=max(nhparmax,nhpar) + nhlabmax=max(nhlabmax,np) endif i=i+1 Index: source/mctdh/quantics.F90 =================================================================== --- source/mctdh/quantics.F90 (revision 854) +++ source/mctdh/quantics.F90 (revision 855) @@ -23,6 +23,9 @@ #ifdef MPI use mpi #endif +#ifdef OMP +use omp_lib +#endif use mpidata use maxv @@ -35,6 +38,7 @@ use logopmod use loginwfmod use logdat +use openmpmod implicit none @@ -65,6 +69,13 @@ #endif !----------------------------------------------------------------------- +! Don't allow nested OMP parallelism to retain maximum threads to +! maximum cores asked for +!----------------------------------------------------------------------- +#ifdef OMP + call omp_set_nested(.false.) +#endif +!----------------------------------------------------------------------- ! Write the PID to the file /tmp/QUANTICS_PID !----------------------------------------------------------------------- if(mpirank.eq.master)then Index: source/mctdh/eingabemod.F90 =================================================================== --- source/mctdh/eingabemod.F90 (revision 854) +++ source/mctdh/eingabemod.F90 (revision 855) @@ -1683,11 +1683,19 @@ lompmfield=.true. else if( keyword(i) .eq. 'openmp_qc' ) then lompqc=.true. + else if( keyword(i) .eq. 'openmp_calcha' ) then + lompcalcha=.true. + else if( keyword(i) .eq. 'openmp_phihphi' ) then + lompphihphi=.true. else if( keyword(i) .eq. 'no_openmp_mfield' ) then lompmfield=.false. else if( keyword(i) .eq. 'no_openmp_qc' ) then lompqc=.false. + else if( keyword(i) .eq. 'no_openmp_calcha' ) then + lompcalcha=.false. + else if( keyword(i) .eq. 'no_openmp_phihphi' ) then + lompphihphi=.false. ! fast algorithm will be used for V(natpot)*A operation else if (keyword(i).eq.'natfast') then @@ -2574,8 +2582,6 @@ if (ompthread .gt. 1) then lompthread = .true. - lompmfield = .true. - lompqc = .true. endif else if ( flag .eq. '-gmat' ) then lrunpes = .true. Index: source/lib/linear/mtomplib.f90 =================================================================== --- source/lib/linear/mtomplib.f90 (revision 854) +++ source/lib/linear/mtomplib.f90 (revision 855) @@ -1,1160 +0,0 @@ -!---------------------------------------------------------------------- -! OpenMP generalisations of routines in the mtlib module. -! GWR 9/13 -!---------------------------------------------------------------------- - module mtomplib - -use decimal, only: dop, long, sip - - implicit none - private - public :: qtxxzdomp,qtxxzzomp,qtxxzzaomp,mtxxzdomp,mtxxzzomp,qttxzzsomp,& - qttxzzaomp,mttxzzomp,qttxzzomp,tqxazzomp,tqxazzaomp,mtaxzzomp,& - dtxxdzoomp - - contains -!----------------------------------------------------------------------- -! Library subroutine qtxxzdomp -! -! Multiplication of a complex quadratic matrix with a real tensor -! of third order: -! dble(a(l,j))*b(i,j,k) = c(i,l,k). -! -! Input-variables: a - complex matrix (only real part used) -! b - real tensor of third order -! Output-variables: c - resulting real tensor -! Open MP generalisation of qtxxzd. -!----------------------------------------------------------------------- - - subroutine qtxxzdomp (a,b,c,dim1,dim2,dim3,ompthread) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1, dim2, & - dim3,ompthread - - real(dop), dimension(dim1,dim2,dim3), intent(in) :: b - real(dop), dimension(dim1,dim2,dim3), intent(out) :: c - complex(dop), dimension(dim2,dim2), intent(in) :: a - -!$omp parallel num_threads(ompthread) private(i,j,k,l) - if (dim1.ne.1 .and. dim3.ne.1) then -!$omp do - do k=1,dim3 - do l=1,dim2 - do i=1,dim1 - c(i,l,k)=dble(a(l,1))*b(i,1,k) - enddo - enddo - enddo -!$omp end do -!$omp do - do k=1,dim3 - do j=2,dim2 - do l=1,dim2 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+dble(a(l,j))*b(i,j,k) - enddo - enddo - enddo - enddo -!$omp end do - else if (dim1.eq.1 .and. dim3.ne.1) then -!$omp do - do k=1,dim3 - do l=1,dim2 - c(1,l,k)=dble(a(l,1))*b(1,1,k) - enddo - enddo -!$omp end do -!$omp do - do k=1,dim3 - do j=2,dim2 - do l=1,dim2 - c(1,l,k)=c(1,l,k)+dble(a(l,j))*b(1,j,k) - enddo - enddo - enddo -!$omp end do - else if (dim1.ne.1 .and. dim3.eq.1) then -!$omp do - do l=1,dim2 - do i=1,dim1 - c(i,l,1)=dble(a(l,1))*b(i,1,1) - enddo - enddo -!$omp end do -!$omp do - do l=1,dim2 - do j=2,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+dble(a(l,j))*b(i,j,1) - enddo - enddo - enddo -!$omp end do - else if (dim1.eq.1 .and. dim3.eq.1) then -!$omp do - do l=1,dim2 - c(1,l,1)=dble(a(l,1))*b(1,1,1) - enddo -!$omp end do -!$omp do - do l=1,dim2 - do j=2,dim2 - c(1,l,1)=c(1,l,1)+dble(a(l,j))*b(1,j,1) - enddo - enddo -!$omp end do - endif -!$omp end parallel - - return - end subroutine qtxxzdomp - -!----------------------------------------------------------------------- -! Library subroutine qtxxzzomp -! -! Multiplication of a complex quadratic matrix with a complex tensor -! of third order: -! a(l,j)*b(i,j,k) = c(i,l,k). -! -! Input-variables: a - complex matrix -! b - complex tensor of third order -! Output-variables: c - resulting complex tensor -!----------------------------------------------------------------------- - - subroutine qtxxzzomp (a,b,c,dim1,dim2,dim3,ompthread) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1, dim2, & - dim3,ompthread - complex(dop), dimension(dim2,dim2), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c - -!$omp parallel num_threads(ompthread) private(i,j,k,l) - if (dim1.ne.1 .and. dim3.ne.1) then -!$omp do schedule(dynamic) - do k=1,dim3 - do l=1,dim2 - do i=1,dim1 - c(i,l,k)=a(l,1)*b(i,1,k) - enddo - enddo - enddo -!$omp end do -!$omp do schedule(dynamic) - do k=1,dim3 - do j=2,dim2 - do l=1,dim2 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+a(l,j)*b(i,j,k) - enddo - enddo - enddo - enddo -!$omp end do - else if (dim1.eq.1 .and. dim3.ne.1) then -!$omp do schedule(dynamic) - do k=1,dim3 - do l=1,dim2 - c(1,l,k)=a(l,1)*b(1,1,k) - enddo - enddo -!$omp end do -!$omp do schedule(dynamic) - do k=1,dim3 - do j=2,dim2 - do l=1,dim2 - c(1,l,k)=c(1,l,k)+a(l,j)*b(1,j,k) - enddo - enddo - enddo -!$omp end do - else if (dim1.ne.1 .and. dim3.eq.1) then -!$omp do schedule(dynamic) - do l=1,dim2 - do i=1,dim1 - c(i,l,1)=a(l,1)*b(i,1,1) - enddo - enddo -!$omp end do -!$omp do - do l=1,dim2 - do j=2,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+a(l,j)*b(i,j,1) - enddo - enddo - enddo -!$omp end do - else if (dim1.eq.1 .and. dim3.eq.1) then -!$omp do schedule(dynamic) - do l=1,dim2 - c(1,l,1)=a(l,1)*b(1,1,1) - enddo -!$omp end do -!$omp do schedule(dynamic) - do l=1,dim2 - do j=2,dim2 - c(1,l,1)=c(1,l,1)+a(l,j)*b(1,j,1) - enddo - enddo -!$omp end do - endif -!$omp end parallel - - return - end subroutine qtxxzzomp - -!----------------------------------------------------------------------- -! Library subroutine qtxxzzaomp -! -! Multiplication of a complex quadratic matrix with a complex tensor -! of third order and added to a different tensor: -! a(l,j)*b(i,j,k) + c(i,l,k) = c(i,l,k). -! -! Input-variables: a - complex matrix -! b - complex tensor of third order -! c - complex tensor of third order -! Output-variables: c - resulting complex tensor -! -! NB input c matrix is overwritten on output. -!----------------------------------------------------------------------- - - subroutine qtxxzzaomp (a,b,c,dim1,dim2,dim3,ompthread) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1, dim2, & - dim3,ompthread - complex(dop), dimension(dim2,dim2), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c - -!$omp parallel num_threads(ompthread) private(i,j,k,l) - if (dim1.ne.1 .and. dim3.ne.1) then -!$omp do - do k=1,dim3 - do j=1,dim2 - do l=1,dim2 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+a(l,j)*b(i,j,k) - enddo - enddo - enddo - enddo -!$omp end do - else if (dim1.eq.1 .and. dim3.ne.1) then -!$omp do - do k=1,dim3 - do j=1,dim2 - do l=1,dim2 - c(1,l,k)=c(1,l,k)+a(l,j)*b(1,j,k) - enddo - enddo - enddo -!$omp end do - else if (dim1.ne.1 .and. dim3.eq.1) then -!$omp do - do l=1,dim2 - do j=1,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+a(l,j)*b(i,j,1) - enddo - enddo - enddo -!$omp end do - else if (dim1.eq.1 .and. dim3.eq.1) then -!$omp do - do l=1,dim2 - do j=1,dim2 - c(1,l,1)=c(1,l,1)+a(l,j)*b(1,j,1) - enddo - enddo -!$omp end do - endif -!$omp end parallel - - return - end subroutine qtxxzzaomp - -!----------------------------------------------------------------------- -! Library subroutine mtxxzdomp -! -! Multiplication of a complex rectangular matrix with a real tensor -! of third order: -! dble(a(l,j))*b(i,j,k) = c(i,l,k) . -! -! Input-variables: a - complex matrix -! b - real tensor of third order -! Output-variables: c - resulting real tensor -!----------------------------------------------------------------------- - - subroutine mtxxzdomp (a,b,c,dim1,dim2,dim3,dim4,ompthread) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1,dim2, & - dim3,dim4,ompthread - real(dop), dimension(dim1,dim2,dim3), intent(in) :: b - real(dop), dimension(dim1,dim4,dim3), intent(out) :: c - complex(dop), dimension(dim4,dim2), intent(in) :: a - -!$omp parallel num_threads(ompthread) private(i,j,k,l) - If (dim1.ne.1 .and. dim3.ne.1) then -!$omp do - do k=1,dim3 - do l=1,dim4 - do i=1,dim1 - c(i,l,k)=dble(a(l,1))*b(i,1,k) - enddo - enddo - enddo -!$omp end do -!$omp do - do k=1,dim3 - do j=2,dim2 - do l=1,dim4 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+dble(a(l,j))*b(i,j,k) - enddo - enddo - enddo - enddo -!$omp end do - else if (dim1.eq.1 .and. dim3.ne.1) then -!$omp do - do k=1,dim3 - do l=1,dim4 - c(1,l,k)=dble(a(l,1))*b(1,1,k) - enddo - enddo -!$omp end do -!$omp do - do k=1,dim3 - do j=2,dim2 - do l=1,dim4 - c(1,l,k)=c(1,l,k)+dble(a(l,j))*b(1,j,k) - enddo - enddo - enddo -!$omp end do - else if (dim1.ne.1 .and. dim3.eq.1) then -!$omp do - do l=1,dim4 - do i=1,dim1 - c(i,l,1)=dble(a(l,1))*b(i,1,1) - enddo - enddo -!$omp end do -!$omp do - do l=1,dim4 - do j=2,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+dble(a(l,j))*b(i,j,1) - enddo - enddo - enddo -!$omp end do - else if (dim1.eq.1 .and. dim3.eq.1) then -!$omp do - do l=1,dim4 - c(1,l,1)=dble(a(l,1))*b(1,1,1) - enddo -!$omp end do -!$omp do - do l=1,dim4 - do j=2,dim2 - c(1,l,1)=c(1,l,1)+dble(a(l,j))*b(1,j,1) - enddo - enddo -!$omp end do - endif -!$omp end parallel - return - end subroutine mtxxzdomp - -!----------------------------------------------------------------------- -! Library subroutine mtxxzz -! -! Multiplication of a complex rectangular matrix with a complex tensor -! of third order: -! a(l,j)*b(i,j,k) = c(i,l,k) . -! -! Input-variables: a - complex matrix -! b - complex tensor of third order -! Output-variables: c - resulting complex tensor -!----------------------------------------------------------------------- - - subroutine mtxxzzomp (a,b,c,dim1,dim2,dim3,dim4,ompthread) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1,dim2, & - dim3,dim4,& - ompthread - complex(dop), dimension(dim4,dim2), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim4,dim3), intent(out) :: c - -!$omp parallel num_threads(ompthread) private(i,j,k,l) - If (dim1.ne.1 .and. dim3.ne.1) then - -!$omp do - do k=1,dim3 - do l=1,dim4 - do i=1,dim1 - c(i,l,k)=a(l,1)*b(i,1,k) - enddo - enddo - enddo -!$omp end do -!$omp do - do k=1,dim3 - do j=2,dim2 - do l=1,dim4 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+a(l,j)*b(i,j,k) - enddo - enddo - enddo - enddo -!$omp end do - else if (dim1.eq.1 .and. dim3.ne.1) then -!$omp do - do k=1,dim3 - do l=1,dim4 - c(1,l,k)=a(l,1)*b(1,1,k) - enddo - enddo -!$omp end do -!$omp do - do k=1,dim3 - do j=2,dim2 - do l=1,dim4 - c(1,l,k)=c(1,l,k)+a(l,j)*b(1,j,k) - enddo - enddo - enddo -!$omp end do - else if (dim1.ne.1 .and. dim3.eq.1) then -!$omp do - do l=1,dim4 - do i=1,dim1 - c(i,l,1)=a(l,1)*b(i,1,1) - enddo - enddo -!$omp end do -!$omp do - do l=1,dim4 - do j=2,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+a(l,j)*b(i,j,1) - enddo - enddo - enddo -!$omp end do - else if (dim1.eq.1 .and. dim3.eq.1) then -!$omp do - do l=1,dim4 - c(1,l,1)=a(l,1)*b(1,1,1) - enddo -!$omp end do -!$omp do - do l=1,dim4 - do j=2,dim2 - c(1,l,1)=c(1,l,1)+a(l,j)*b(1,j,1) - enddo - enddo -!$omp end do - endif -!$omp end parallel - - return - end subroutine mtxxzzomp - -!----------------------------------------------------------------------- -! Library subroutine mttxzzomp -! -! Multiplication of a transposed complex rectangular matrix with a -! complex tensor of third order: -! a(j,l)*b(i,j,k) = c(i,l,k). -! -! Input-variables: a - complex matrix -! b - complex tensor of third order -! Output-variables: c - resulting complex tensor -!----------------------------------------------------------------------- - - subroutine mttxzzomp (a,b,c,dim1,dim2,dim3,dim4,ompthread) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1,dim2, & - dim3,dim4,& - ompthread - complex(dop), dimension(dim2,dim4), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim4,dim3), intent(out) :: c - -!$omp parallel num_threads(ompthread) private(i,j,k,l) - If (dim1.ne.1 .and. dim3.ne.1) then -!$omp do - do k=1,dim3 - do l=1,dim4 - do i=1,dim1 - c(i,l,k)=a(1,l)*b(i,1,k) - enddo - enddo - enddo -!$omp end do -!$omp do - do k=1,dim3 - do l=1,dim4 - do j=2,dim2 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+a(j,l)*b(i,j,k) - enddo - enddo - enddo - enddo -!$omp end do - else if (dim1.eq.1 .and. dim3.ne.1) then -!$omp do - do k=1,dim3 - do l=1,dim4 - c(1,l,k)=a(1,l)*b(1,1,k) - enddo - enddo -!$omp end do -!$omp do - do k=1,dim3 - do l=1,dim4 - do j=2,dim2 - c(1,l,k)=c(1,l,k)+a(j,l)*b(1,j,k) - enddo - enddo - enddo -!$omp end do - else if (dim1.ne.1 .and. dim3.eq.1) then -!$omp do - do l=1,dim4 - do i=1,dim1 - c(i,l,1)=a(1,l)*b(i,1,1) - enddo - enddo -!$omp end do -!$omp do - do l=1,dim4 - do j=2,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+a(j,l)*b(i,j,1) - enddo - enddo - enddo -!$omp end do - else if (dim1.eq.1 .and. dim3.eq.1) then -!$omp do - do l=1,dim4 - c(1,l,1)=a(1,l)*b(1,1,1) - enddo -!$omp end do -!$omp do - do l=1,dim4 - do j=2,dim2 - c(1,l,1)=c(1,l,1)+a(j,l)*b(1,j,1) - enddo - enddo -!$omp end do - endif -!$omp end parallel - - return - end subroutine mttxzzomp - -!----------------------------------------------------------------------- -! Library subroutine qttxzzsomp -! -! Multiplication of a complex quadratic matrix with a complex tensor -! of third order and substracted from a different tensor: -! c(i,l,k) - a(j,l)*b(i,j,k) = c(i,l,k). -! -! Input-variables: a - complex matrix -! b - complex tensor of third order -! c - complex tensor of third order -! Output-variables: c - resulting complex tensor -! -! NB input ! matrix is overwritten on output. -!----------------------------------------------------------------------- - - subroutine qttxzzsomp (a,b,c,dim1,dim2,dim3,ompthread) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1,dim2, & - dim3,ompthread - complex(dop), dimension(dim2,dim2), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c - -!$omp parallel num_threads(ompthread) private(i,j,k,l) - if (dim1.ne.1 .and. dim3.ne.1) then -!$omp do - do k=1,dim3 - do j=1,dim2 - do l=1,dim2 - do i=1,dim1 - c(i,l,k)=c(i,l,k)-a(j,l)*b(i,j,k) - enddo - enddo - enddo - enddo -!$omp end do - else if (dim1.eq.1 .and. dim3.ne.1) then -!$omp do - do k=1,dim3 - do j=1,dim2 - do l=1,dim2 - c(1,l,k)=c(1,l,k)-a(j,l)*b(1,j,k) - enddo - enddo - enddo -!$omp end do - else if (dim1.ne.1 .and. dim3.eq.1) then -!$omp do - do l=1,dim2 - do j=1,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)-a(j,l)*b(i,j,1) - enddo - enddo - enddo -!$omp end do - else if (dim1.eq.1 .and. dim3.eq.1) then -!$omp do - do j=1,dim2 - do l=1,dim2 - c(1,l,1)=c(1,l,1)-a(j,l)*b(1,j,1) - enddo - enddo -!$omp end do - endif -!$omp end parallel - - return - end subroutine qttxzzsomp - -!----------------------------------------------------------------------- -! Library subroutine qttxzzaomp -! -! Multiplication of a complex quadratic matrix with a complex tensor -! of third order and added to a different tensor: -! a(j,l)*b(i,j,k) + c(i,l,k) = c(i,l,k). -! -! Input-variables: a - complex matrix -! b - complex tensor of third order -! c - complex tensor of third order -! Output-variables: c - resulting complex tensor -! -! NB input ! matrix is overwritten on output. -!----------------------------------------------------------------------- - - subroutine qttxzzaomp (a,b,c,dim1,dim2,dim3,ompthread) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1,dim2, & - dim3,ompthread - complex(dop), dimension(dim2,dim2), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c - -!$omp parallel num_threads(ompthread) private(i,j,k,l) - if (dim1.ne.1 .and. dim3.ne.1) then -!$omp do - do k=1,dim3 - do j=1,dim2 - do l=1,dim2 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+a(j,l)*b(i,j,k) - enddo - enddo - enddo - enddo -!$omp end do - else if (dim1.eq.1 .and. dim3.ne.1) then -!$omp do - do k=1,dim3 - do j=1,dim2 - do l=1,dim2 - c(1,l,k)=c(1,l,k)+a(j,l)*b(1,j,k) - enddo - enddo - enddo -!$omp end do - else if (dim1.ne.1 .and. dim3.eq.1) then -!$omp do - do l=1,dim2 - do j=1,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+a(j,l)*b(i,j,1) - enddo - enddo - enddo -!$omp end do - else if (dim1.eq.1 .and. dim3.eq.1) then -!$omp do - do l=1,dim2 - do j=1,dim2 - c(1,l,1)=c(1,l,1)+a(j,l)*b(1,j,1) - enddo - enddo -!$omp end do - endif -!$omp end parallel - - return - end subroutine qttxzzaomp - -!----------------------------------------------------------------------- -! Library subroutine qttxzzomp -! -! Multiplication of a transposed complex quadratic matrix with a -! complex tensor of third order: -! a(j,l)*b(i,j,k) = c(i,l,k). -! -! Input-variables: a - real matrix -! b - real tensor of third order -! Output-variables: c - resulting real tensor -!----------------------------------------------------------------------- - - subroutine qttxzzomp (a,b,c,dim1,dim2,dim3,ompthread) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1,dim2, & - dim3,ompthread - complex(dop), dimension(dim2,dim2), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c - -!$omp parallel num_threads(ompthread) private(i,j,k,l) - If (dim1.ne.1 .and. dim3.ne.1) then -!$omp do - do k=1,dim3 - do l=1,dim2 - do i=1,dim1 - c(i,l,k)=a(1,l)*b(i,1,k) - enddo - enddo - enddo -!$omp end do -!$omp do - do k=1,dim3 - do l=1,dim2 - do j=2,dim2 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+a(j,l)*b(i,j,k) - enddo - enddo - enddo - enddo -!$omp end do - else if (dim1.eq.1 .and. dim3.ne.1) then -!$omp do - do k=1,dim3 - do l=1,dim2 - c(1,l,k)=a(1,l)*b(1,1,k) - enddo - enddo -!$omp end do -!$omp do - do k=1,dim3 - do l=1,dim2 - do j=2,dim2 - c(1,l,k)=c(1,l,k)+a(j,l)*b(1,j,k) - enddo - enddo - enddo -!$omp end do - else if (dim1.ne.1 .and. dim3.eq.1) then -!$omp do - do l=1,dim2 - do i=1,dim1 - c(i,l,1)=a(1,l)*b(i,1,1) - enddo - enddo -!$omp end do -!$omp do - do l=1,dim2 - do j=2,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+a(j,l)*b(i,j,1) - enddo - enddo - enddo -!$omp end do - else if (dim1.eq.1 .and. dim3.eq.1) then -!$omp do - do l=1,dim2 - c(1,l,1)=a(1,l)*b(1,1,1) - enddo -!$omp end do -!$omp do - do l=1,dim2 - do j=2,dim2 - c(1,l,1)=c(1,l,1)+a(j,l)*b(1,j,1) - enddo - enddo -!$omp end do - endif -!$omp end parallel - - return - end subroutine qttxzzomp - -!----------------------------------------------------------------------- -! Library subroutine tqxazzaomp -! -! Multiplication of a complex quadratic matrix with a complex tensor -! of third order and added to a different tensor: -! a(i,j,k)*dconjg(b(l,j)) + c(i,l,k) = c(i,l,k). -! -! Input-variables: a - complex tensor of third order -! b - complex matrix -! c - complex tensor of third order -! Output-variables: c - resulting complex tensor -! -! NB input ! matrix is overwritten on output. -!----------------------------------------------------------------------- - - subroutine tqxazzaomp (a,b,c,dim1,dim2,dim3,ompthread) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1,dim2, & - dim3,ompthread - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: a - complex(dop), dimension(dim2,dim2), intent(in) :: b - complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c - -!$omp parallel num_threads(ompthread) private(i,j,k,l) - if (dim1.ne.1 .and. dim3.ne.1) then -!$omp do - do k=1,dim3 - do l=1,dim2 - do j=1,dim2 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+a(i,j,k)*dconjg(b(l,j)) - enddo - enddo - enddo - enddo -!$omp end do - else if (dim1.eq.1 .and. dim3.ne.1) then -!$omp do - do k=1,dim3 - do l=1,dim2 - do j=1,dim2 - c(1,l,k)=c(1,l,k)+a(1,j,k)*dconjg(b(l,j)) - enddo - enddo - enddo -!$omp end do - else if (dim1.ne.1 .and. dim3.eq.1) then -!$omp do - do l=1,dim2 - do j=1,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+a(i,j,1)*dconjg(b(l,j)) - enddo - enddo - enddo -!$omp end do - else if (dim1.eq.1 .and. dim3.eq.1) then -!$omp do - do l=1,dim2 - do j=1,dim2 - c(1,l,1)=c(1,l,1)+a(1,j,1)*dconjg(b(l,j)) - enddo - enddo -!$omp end do - endif -!$omp end parallel - - return - end subroutine tqxazzaomp - -!----------------------------------------------------------------------- -! Library subroutine tqxazzomp -! -! Multiplication of a complex quadratic matrix with a complex tensor -! of third order: -! a(i,j,k)*dconjg(b(l,j)) = c(i,l,k). -! -! Input-variables: a - complex tensor of third order -! b - complex matrix -! -! Output-variables: c - resulting complex tensor -! -!----------------------------------------------------------------------- - - subroutine tqxazzomp (a,b,c,dim1,dim2,dim3,ompthread) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1,dim2, & - dim3,ompthread - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: a - complex(dop), dimension(dim2,dim2), intent(in) :: b - complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c - -!$omp parallel num_threads(ompthread) private(i,j,k,l) - If (dim1.ne.1 .and. dim3.ne.1) then -!$omp do - do k=1,dim3 - do l=1,dim2 - do i=1,dim1 - c(i,l,k)=a(i,1,k)*dconjg(b(l,1)) - enddo - enddo - enddo -!$omp end do -!$omp do - do k=1,dim3 - do l=1,dim2 - do j=2,dim2 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+a(i,j,k)*dconjg(b(l,j)) - enddo - enddo - enddo - enddo -!$omp end do - else if (dim1.eq.1 .and. dim3.ne.1) then -!$omp do - do k=1,dim3 - do l=1,dim2 - c(1,l,k)=a(1,1,k)*dconjg(b(l,1)) - enddo - enddo -!$omp end do -!$omp do - do k=1,dim3 - do l=1,dim2 - do j=2,dim2 - c(1,l,k)=c(1,l,k)+a(1,j,k)*dconjg(b(l,j)) - enddo - enddo - enddo -!$omp end do - else if (dim1.ne.1 .and. dim3.eq.1) then -!$omp do - do l=1,dim2 - do i=1,dim1 - c(i,l,1)=a(i,1,1)*dconjg(b(l,1)) - enddo - enddo -!$omp end do -!$omp do - do l=1,dim2 - do j=2,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+a(i,j,1)*dconjg(b(l,j)) - enddo - enddo - enddo -!$omp end do - else if (dim1.eq.1 .and. dim3.eq.1) then -!$omp do - do l=1,dim2 - c(1,l,1)=a(1,1,1)*dconjg(b(l,1)) - enddo -!$omp end do -!$omp do - do l=1,dim2 - do j=2,dim2 - c(1,l,1)=c(1,l,1)+a(1,j,1)*dconjg(b(l,j)) - enddo - enddo -!$omp end do - endif -!$omp end parallel - - return - end subroutine tqxazzomp - -!----------------------------------------------------------------------- -! Library subroutine mtaxzz -! -! Multiplication of the adjoint of a complex rectangular matrix with a -! complex tensor of third order: -! dconj(a(j,l))*b(i,j,k) = c(i,l,k). -! -! Input-variables: a - complex matrix -! b - complex tensor of third order -! Output-variables: c - resulting complex tensor -!----------------------------------------------------------------------- - - subroutine mtaxzzomp (a,b,c,dim1,dim2,dim3,dim4,ompthread) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1,dim2, & - dim3,dim4,& - ompthread - complex(dop), dimension(dim2,dim4), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim4,dim3), intent(out) :: c - -!$omp parallel num_threads(ompthread) private(i,j,k,l) - If (dim1.ne.1 .and. dim3.ne.1) then -!$omp do - do k=1,dim3 - do l=1,dim4 - do i=1,dim1 - c(i,l,k)=dconjg(a(1,l))*b(i,1,k) - enddo - enddo - enddo -!$omp enddo -!$omp do - do k=1,dim3 - do l=1,dim4 - do j=2,dim2 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+dconjg(a(j,l))*b(i,j,k) - enddo - enddo - enddo - enddo -!$omp enddo - else if (dim1.eq.1 .and. dim3.ne.1) then -!$omp do - do k=1,dim3 - do l=1,dim4 - c(1,l,k)=dconjg(a(1,l))*b(1,1,k) - enddo - enddo -!$omp enddo -!$omp do - do k=1,dim3 - do l=1,dim4 - do j=2,dim2 - c(1,l,k)=c(1,l,k)+dconjg(a(j,l))*b(1,j,k) - enddo - enddo - enddo -!$omp enddo - else if (dim1.ne.1 .and. dim3.eq.1) then -!$omp do - do l=1,dim4 - do i=1,dim1 - c(i,l,1)=dconjg(a(1,l))*b(i,1,1) - enddo - enddo -!$omp enddo -!$omp do - do l=1,dim4 - do j=2,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+dconjg(a(j,l))*b(i,j,1) - enddo - enddo - enddo -!$omp enddo - else if (dim1.eq.1 .and. dim3.eq.1) then -!$omp do - do l=1,dim4 - c(1,l,1)=dconjg(a(1,l))*b(1,1,1) - enddo -!$omp enddo -!$omp do - do l=1,dim4 - do j=2,dim2 - c(1,l,1)=c(1,l,1)+dconjg(a(j,l))*b(1,j,1) - enddo - enddo -!$omp enddo - endif -!$omp end parallel - return - end subroutine mtaxzzomp - -!----------------------------------------------------------------------- -! Library subroutine dtxxdzo -! -! Multiplication of a real diagonal matrix with a complex tensor -! of third order. Only diagonal matrix elements are given as a vector, -! and the result is stored in the input tensor: -! a(j)*b(i,j,k) = b(i,j,k) . -! -! Input-variables: a - complex vector with diagonal matrix elements -! b - complex tensor of third order -! Output-variables: b - resulting complex tensor -!----------------------------------------------------------------------- - - subroutine dtxxdzoomp (a,b,dim1,dim2,dim3,ompthread) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1,dim2, & - dim3,ompthread - real(dop), dimension(dim2), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(out) :: b - -!$omp parallel num_threads(ompthread) private(i,j,k) - if (dim1.ne.1 .and. dim3.ne.1) then -!$omp do - do k=1,dim3 - do j=1,dim2 - do i=1,dim1 - b(i,j,k)=a(j)*b(i,j,k) - enddo - enddo - enddo -!$omp enddo - else if (dim1.eq.1 .and. dim3.ne.1) then -!$omp do - do k=1,dim3 - do j=1,dim2 - b(1,j,k)=a(j)*b(1,j,k) - enddo - enddo -!$omp enddo - else if (dim1.ne.1 .and. dim3.eq.1) then -!$omp do - do j=1,dim2 - do i=1,dim1 - b(i,j,1)=a(j)*b(i,j,1) - enddo - enddo -!$omp enddo - else if (dim1.eq.1 .and. dim3.eq.1) then -!$omp do - do j=1,dim2 - b(1,j,1)=a(j)*b(1,j,1) - enddo -!$omp enddo - endif -!$omp end parallel - - return - end subroutine dtxxdzoomp - - end module mtomplib Index: source/lib/linear/mmlib.f90 =================================================================== --- source/lib/linear/mmlib.f90 (revision 854) +++ source/lib/linear/mmlib.f90 (revision 855) @@ -1,2266 +0,0 @@ -! ********************************************************************** -! -! MMLIB -! -! Library module containing linear algebra routines that involve the -! multiplication of matrices -! -! Nomenclature: -! Each name has 6 basic characters: -! First 2 characters denote the objects being multiplied: -! q: quadratic matrix -! m: general (rectangular) matrix -! h: hermitian matrix -! p: positive definite matrix -! s: symmetric matrix -! u: unitary matrix -! d: diagonal matrix (only diagonal elements are supplied as a -! vector) -! t: tensor of third order -! v: vector -! x: scalar -! e.g. 'qm' denotes the operation (quadratic matrix * rectangular -! matrix) -! Character 3 denotes how first object is used: -! x: unchanged from input -! t: transpose of input -! a: adjoint of input -! c: complex conjugate of input -! v: as a vector -! Character 4 denotes how second object is used: -! see Character 3 above. -! Character 5, 6 denote data types of first, second object -! respectively: -! z: complex double precision (complex*16) -! c: complex single precision (complex*8) -! d: real double precision (real*8) -! r: real single precision (real*4) -! Further characters, if present, give more informaion: -! a: the result is added to a further object -! r: the result is subtracted (removed) from a further object -! c: the input matrices commute -! h: the resulting matrix is hermitian -! h1: the resulting matrix is anti-hermitian -! s: the resulting matrix is symmetric -! 1: the physical dimensions of the matrices differs from those -! used. -! -! Contents: -! In the following list of available subroutines, matrices on the LHS -! of the definition are input, that on the RHS output. The usual -! summation convention is used i.e. a sum is made over repeated indices -! on the LHS (NOTE: there is only elementwise multiplication and -! no subsequent summation if a diagonal matrix is involved !!!). -! -! qqxxdd (a,b,c,dim) -! Definition: a(j,k)*b(k,i) = c(j,i) . -! Dimensions: a(dim,dim),b(dim,dim),c(dim,dim) -! -! qqxxzd (a,b,c,dim) -! Definition: a(j,k)*b(k,i) = c(j,i) . -! Dimensions: a(dim,dim),b(dim,dim),c(dim,dim) -! -! mmxxzz (a,b,c,dim1,dim2,dim3) -! Definition: a(j,k)*b(k,i) = c(j,i) . -! Dimensions: a(dim1,dim2),b(dim2,dim3),c(dim1,dim3) -! -! mmvxzz (a,b,c,dim1,dim2,dim3,p) -! Definition: a(p,k)*b(k,i) = c(i) -! Dimensions: a(dim1,dim2),b(dim2,dim3),c(dim3) -! -! mmxtzz (a,b,c,dim1,dim2,dim3) -! Definition: a(j,k)*b(i,k) = c(j,i) . -! Dimensions: a(dim1,dim2),b(dim3,dim2),c(dim1,dim3) -! -! mmtczz (a,b,c,dim1,dim2,dim3) -! Definition: a(k,j)*dconjg(b(k,i)) = c(j,i) . -! Dimensions: a(dim1,dim2),b(dim1,dim3),c(dim2,dim3) -! -! mmxxzza (a,b,c,dim1,dim2,dim3) -! Definition: a(j,k)*b(k,i) + c(j,i) = c(j,i) . -! Dimensions: a(dim1,dim2),b(dim2,dim3),c(dim1,dim3) -! -! dmxxzz (a,b,c,dim1,dim2) -! Definition: a(j)*b(j,i) = c(j,i) . -! Dimensions: a(dim1),b(dim1,dim2),c(dim1,dim2) -! -! dmxxzza (a,b,c,dim1,dim2) -! Definition: a(j)*b(j,i) + c(j,i) = c(j,i) . -! Dimensions: a(dim1),b(dim1,dim2),c(dim1,dim2) -! -! dmxxdz (a,b,c,dim1,dim2) -! Definition: a(j)*b(j,i) = c(j,i) . -! Dimensions: a(dim1),b(dim1,dim2),c(dim1,dim2) -! -! dmxxdd (a,b,c,dim1,dim2) -! Definition: a(j)*b(j,i) = c(j,i) . -! Dimensions: a(dim1),b(dim1,dim2),c(dim1,dim2) -! -! ddxxdd (a,b,c,dim) -! Definition: a(j)*b(j) = c(j) . -! Dimensions: a(dim),b(dim),c(dim) -! -! ddxxdz (a,b,c,dim) -! Definition: a(j)*b(j) = c(j) . -! Dimensions: a(dim),b(dim),c(dim) -! -! dqxxzz (a,b,c,dim) -! Definition: a(j)*b(j,i) = c(j,i) . -! Dimensions: a(dim),b(dim,dim),c(dim,dim) -! -! dqxxdd (a,b,c,dim) -! Definition: a(j)*b(j,i) = c(j,i) . -! Dimensions: a(dim),b(dim,dim),c(dim,dim) -! -! dqxxdd1 (a,b,c,phdim,dim) -! Definition: a(j)*b(j,i) = c(j,i) . -! Dimensions: a(dim),b(phdim,dim),c(phdim,dim) -! -! dqxxdz (a,v,w,dim) -! Definition: a(i)*v(i,j) = w(i,j) . -! Dimensions: a(dim),v(dim,dim),w(dim,dim) -! -! dqxxdz2 (a,v,w,dim) -! Definition: a(j)*v(i,j) = w(i,j) . -! Dimensions: a(dim),v(dim,dim),w(dim,dim) -! -!C mmxxdz (a,b,c,dim1,dim2,dim3) -!C Definition: a(j,k)*b(k,i) = c(j,i) . -!C Dimensions: a(dim1,dim2),b(dim2,dim3),c(dim1,dim3) -! -! mmtxdd (a,b,c,dim1,dim2,dim3) -! Definition: a(k,j)*b(k,i) = c(j,i) . -! Dimensions: a(dim2,dim1),b(dim2,dim3),c(dim1,dim3) -! -! mmtxdd1 (a,b,c,phdim,dim1,dim2,dim3) -! Definition: a(k,j)*b(k,i) = c(j,i) . -! Dimensions: a(dim2,dim1),b(dim2,dim3),c(dim1,dim3) (= used dim.) -! Dimensions: a,b,c(phdim,phdim) (= allocated dimension) -! -! mmxtdd (a,b,c,dim1,dim2,dim3) -! Definition: a(j,k)*b(i,k) = c(j,i) . -! Dimensions: a(dim1,dim2),b(dim3,dim2),c(dim1,dim3) -! -! mmxxdd (a,b,c,dim1,dim2,dim3) -! Definition: a(j,k)*b(k,i) = c(j,i) . -! Dimensions: a(dim1,dim2),b(dim2,dim3),c(dim1,dim3) -! -! mmxxdd1 (a,b,c,phdim,dim1,dim2,dim3) -! Definition: a(j,k)*b(k,i) = c(j,i) . -! Dimensions: a(dim1,dim2),b(dim2,dim3),c(dim1,dim3) (= used dim.) -! Dimensions: a,b,c(phdim,phdim) (= allocated dimension) -! -! qqxtdd (a,b,c,dim) -! Definition: a(j,k)*b(i,k) = c(j,i) . -! Dimensions: a(dim,dim),b(dim,dim),c(dim,dim) -! -! qqxtdd1 (a,b,c,phdim,dim) -! Definition: a(j,k)*b(i,k) = c(j,i) ; 1 <= i,j,k <= dim . -! Dimensions: a(phdim,dim),b(phdim,dim),c(phdim,dim) -! -! qqtxdd (a,b,c,dim) -! Definition: a(k,j)*b(k,i) = c(j,i) . -! Dimensions: a(dim,dim),b(dim,dim),c(dim,dim) -! -! qdxxzz (a,b,c,dim) -! Definition: a(j,i)*b(i) = c(j,i) . -! Dimensions: a(dim,dim),b(dim),c(dim,dim) -! -! qdxxdd (a,b,c,dim) -! Definition: a(j,i)*b(i) = c(j,i) . -! Dimensions: a(dim,dim),b(dim),c(dim,dim) -! -! qdxxdd1 (a,b,c,phdim,dim) -! Definition: a(j,i)*b(i) = c(j,i) ; 1 <= i,j <= dim . -! Dimensions: a(phdim,dim),b(dim),c(phdim,dim) -! -! hhxtzzc (a,b,c,dim) -! Definition: a(j,k)*b(i,k) = c(j,i) . -! Dimensions: a(dim,dim),b(dim,dim),c(dim,dim) -! -! mmaxzzh (a,b,c,dim1,dim2) -! Definition: dconjg(a(k,j))*b(k,i) = c(j,i) . -! Dimensions: a(dim1,dim2),b(dim1,dim2),c(dim2,dim2) -! -! mmaxzzh1 (a,b,c,dim1,dim2) -! Definition: dconjg(a(k,j))*b(k,i) = c(j,i) . -! Dimensions: a(dim1,dim2),b(dim1,dim2),c(dim2,dim2) -! -! mmtxzzs (a,b,c,dim1,dim2) -! Definition: a(k,j)*b(k,i) = c(j,i) . -! Dimensions: a(dim1,dim2),b(dim1,dim2),c(dim2,dim2) -! -! qmxxzz (a,b,c,dim1,dim2) -! Definition: a(j,k)*b(k,i) = c(j,i) . -! Dimensions: a(dim1,dim1),b(dim1,dim2),c(dim1,dim2) -! -! qqxxdd1 (a,b,c,phdim,dim) -! Definition: a(j,k)*b(k,i) = c(j,i) ; 1 <= i,j,k <= dim . -! Dimensions: a(phdim,dim),b(phdim,dim),c(phdim,dim) -! -!C mmxxzz1 (a,b,c,phdim1,phdim2,phdim3,dim1,dim2,dim3) -!C Definition: a(j,k)*b(k,i) = c(j,i) . -!C Dimensions: a(phdim1,phdim2),b(phdim2,phdim3),c(phdim1,phdim3) -! -! mmaxzz (a,b,c,dim1,dim2,dim3) -! Definition: dconjg(a(k,j))*b(k,i) = c(j,i) . -! Dimensions: a(dim1,dim2),b(dim1,dim3),c(dim2,dim3) -! -! mmcxzz (a,b,c,dim1,dim2,dim3) -! Definition: dconjg(a(j,k))*b(k,i) = c(j,i) . -! Dimensions: a(dim1,dim2),b(dim2,dim3),c(dim1,dim3) -! -! qqcxzz (a,b,c,dim) -! Definition: dconjg(a(j,k))*b(k,i) = c(j,i) . -! Dimensions: a(dim,dim),b(dim,dim),c(dim,dim) -! -! mmxazz (a,b,c,dim1,dim2,dim3) -! Definition: a(j,k)*dconjg(b(i,k)) = c(j,i) . -! Dimensions: a(dim1,dim2),b(dim3,dim2),c(dim1,dim3) -! -! mmxtzza (a,b,c,dim1,dim2,dim3) -! Definition: a(j,k)*b(i,k) +c(j,i) = c(j,i) . -! Dimensions: a(dim1,dim2),b(dim3,dim2),c(dim1,dim3) -! -! mqxtzza (a,b,c,dim1,dim2) -! Definition: a(j,k)*b(i,k) +c(j,i) = c(j,i) . -! Dimensions: a(dim1,dim2),b(dim2,dim2),c(dim1,dim2) -! -! mmcazza (a,b,c,dim1,dim2,dim3) -! Definition: conjg(a(j,k))*conjg(b(i,k)) + c(j,i) = c(j,i) -! Dimensions: a(dim1,dim2),b(dim3,dim2),c(dim1,dim3/) -! -! mqxxzza (a,b,c,dim1,dim2) -! Definition: a(j,k)*b(k,i) +c(j,i) = c(j,i) . -! Dimensions: a(dim1,dim2),b(dim2,dim2),c(dim1,dim2) -! -! mqxtzd (a,b,c,dim1,dim2) -! Definition: a(j,k)*b(i,k) = c(j,i) . -! Dimensions: a(dim1,dim2),b(dim2,dim2),c(dim1,dim2) -! -! qqtxzz (a,b,c,dim) -! Definition: a(k,j)*b(k,i) = c(j,i) . -! Dimensions: a(dim,dim),b(dim,dim),c(dim,dim) -! -! mqxazz (a,b,c,dim1,dim2) -! Definition: a(j,k)*dconjg(b(i,k)) = c(j,i) . -! Dimensions: a(dim1,dim2),b(dim2,dim2),c(dim1,dim2) -! -! qmxxdz (a,b,c,dim1,dim2) -! Definition: a(j,k)*b(k,i) = c(j,i) . -! Dimensions: a(dim1,dim1),b(dim1,dim2),c(dim1,dim2) -! -! qmtxdz (a,b,c,dim1,dim2) -! Definition: a(k,j)*b(k,i) = c(j,i) . -! Dimensions: a(dim1,dim1),b(dim1,dim2),c(dim1,dim2) -! -! qqxxzz (a,b,c,dim) -! Definition: a(j,k)*b(k,i) = c(j,i) . -! Dimensions: a(dim,dim),b(dim,dim),c(dim,dim) -! -! mqxtzz (a,b,c,dim1,dim2) -! Definition: a(j,k)*b(i,k) = c(j,i) . -! Dimensions: a(dim1,dim2),b(dim2,dim2),c(dim1,dim2) -! -! mqxxzz (a,b,c,dim1,dim2) -! Definition: a(j,k)*b(k,i) = c(j,i) . -! Dimensions: a(dim1,dim2),b(dim2,dim2),c(dim1,dim2) -! -! mmtxzz (a,b,c,dim1,dim2,dim3) -! Definition: a(k,j)*b(k,i) = c(j,i) . -! Dimensions: a(dim1,dim2),b(dim1,dim3),c(dim2,dim3) -! -! mmtxzza (a,b,c,dim1,dim2,dim3) -! Definition: a(k,j)*b(k,i) + c(j,i) = c(j,i) . -! Dimensions: a(dim1,dim2),b(dim1,dim3),c(dim2,dim3) -! -! mmxczz (a,b,c,dim1,dim2,dim3) -! Definition: a(j,k)*dconjg(b(k,i)) = c(j,i) . -! Dimensions: a(dim1,dim2),b(dim2,dim3),c(dim1,dim3) -! -! mqxczz (a,b,c,dim1,dim2) -! Definition: a(j,k)*dconjg(b(k,i)) = c(j,i) . -! Dimensions: a(dim1,dim2),b(dim2,dim2),c(dim1,dim2) -! -! qqaxzz (a,b,c,dim) -! Definition: dconjg(a(k,j))*b(k,i) = c(j,i) . -! Dimensions: a(dim,dim),b(dim,dim),c(dim,dim) -! -! qqxazz (a,b,c,dim) -! Definition: a(j,k)*dconjg(b(i,k)) = c(j,i) . -! Dimensions: a(dim,dim),b(dim,dim),c(dim,dim) -! -! msqzz (a,b,dim1,dim2,dim3) -! Definition: Local control: generating vibrational wavefuntion -! Dimensions: a(dim1,dim2),b(dim1,dim2) -!*********************************************************************** - - module mmlib - - use decimal, only: dop, long - - implicit none - private - public :: qqxxdd, qqxxzd, mmxxzz, mmvxzz, mmxtzz, mmtczz, & - mmxxzza, dmxxzz, dmxxzza, dmxxdz, dmxxdd, & - ddxxdd, ddxxdz,dqxxzz, dqxxdd, dqxxdd1, dqxxdz, dqxxdz2, & - mmtxdd, mmtxdd1, mmxtdd, mmxxdd, mmxxdd1, & - qqxtdd, qqxtdd1, qqtxdd, qdxxzz, qdxxdd, qdxxdd1, & - hhxtzzc, mmaxzzh, mmaxzzh1, mmtxzzs, qmxxzz,qqxxdd1, & - mmaxzz, mmcxzz, qqcxzz, mmxazz, mmxtzza, qdxxdz, & - mmcazza, mqxxzz, mqxxzza, mqxtzd, qqtxzz, & - mqxazz, qmxxdz, qmtxdz, qqxxzz, mqxtzz, mmtxzz, & - mmtxzza, mmxczz, mqxczz, qqaxzz, qqxazz, msqzz -! mmxxdz, mmxxzz1, mqxtzza - contains - -!----------------------------------------------------------------------- -! Library subroutine qqxxdd -! -! Multiplication of two real quadratic matrices: -! a(j,k)*b(k,i) = c(j,i) -!----------------------------------------------------------------------- - - subroutine qqxxdd (a,b,c,dim) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim - real(dop), dimension(dim,dim), intent(in) :: a - real(dop), dimension(dim,dim), intent(in) :: b - real(dop), dimension(dim,dim), intent(out) :: c - - do i=1,dim - do j=1,dim - c(j,i) = a(j,1)*b(1,i) - enddo - enddo - do i = 1,dim - do k = 2,dim - do j = 1,dim - c(j,i) = c(j,i)+a(j,k)*b(k,i) - enddo - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine qqxxzd -! -! Multiplication of a complex quadratic matrix with a real quadratic -! matrix: -! a(j,k)*b(k,i) = c(j,i) -!----------------------------------------------------------------------- - - subroutine qqxxzd (a,b,c,dim) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim - real(dop), dimension(dim,dim), intent(in) :: b - complex(dop), dimension(dim,dim), intent(in) :: a - complex(dop), dimension(dim,dim), intent(out) :: c - - do i=1,dim - do j=1,dim - c(j,i) = a(j,1)*b(1,i) - enddo - enddo - do i = 1,dim - do k = 2,dim - do j = 1,dim - c(j,i) = c(j,i)+a(j,k)*b(k,i) - enddo - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine mmxxzz -! -! Multiplication of two complex rectangular matrices: -! a(j,k)*b(k,i) = c(j,i) -!----------------------------------------------------------------------- - - subroutine mmxxzz (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2, dim3 - complex(dop), dimension(dim1,dim2), intent(in) :: a - complex(dop), dimension(dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim3), intent(out) :: c - - do i=1,dim3 - do j=1,dim1 - c(j,i) = a(j,1)*b(1,i) - enddo - enddo - do i = 1,dim3 - do k = 2,dim2 - do j = 1,dim1 - c(j,i) = c(j,i)+a(j,k)*b(k,i) - enddo - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! subroutine mmvxzz -! -! Multiplication of two complex rectangular matrices with p fixed (uses -! first matrix as a vector): -! -! a(p,k)*b(k,i) = c(i) -!----------------------------------------------------------------------- - - subroutine mmvxzz (a,b,c,dim1,dim2,dim3,p) - - implicit none - - integer(long) :: i, p, k - integer(long), intent(in) :: dim1, dim2, dim3 - complex(dop), dimension(dim1,dim2), intent(in) :: a - complex(dop), dimension(dim2,dim3), intent(in) :: b - complex(dop), dimension(dim3), intent(out) :: c - - do i=1,dim3 - c(i) = a(p,1)*b(1,i) - enddo - do i = 1,dim3 - do k = 2,dim2 - c(i) = c(i)+a(p,k)*b(k,i) - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine mmxtzz -! -! Multiplication of a complex rectangular matrix with the transpose of -! a rectangular complex matrix -! a(j,k)*b(i,k) = c(j,i) -!----------------------------------------------------------------------- - - subroutine mmxtzz (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2, dim3 - complex(dop), dimension(dim1,dim2), intent(in) :: a - complex(dop), dimension(dim3,dim2), intent(in) :: b - complex(dop), dimension(dim1,dim3), intent(out) :: c - - do i=1,dim3 - do j=1,dim1 - c(j,i) = a(j,1)*b(i,1) - enddo - enddo - - do i = 1,dim3 - do k = 2,dim2 - do j = 1,dim1 - c(j,i) = c(j,i)+a(j,k)*b(i,k) - enddo - enddo - enddo - - return - end subroutine - - -!----------------------------------------------------------------------- -! Library subroutine mmxxzza -! -! Multiplication of a complex rectangular matrix with a rectangular -! complex matrix, the result of which is added to a further matrix. -! a(j,k)*b(k,i) +c(j,i) = c(j,i) -!----------------------------------------------------------------------- - - subroutine mmxxzza (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2, dim3 - complex(dop), dimension(dim1,dim2), intent(in) :: a - complex(dop), dimension(dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim3), intent(out) :: c - - do k = 1,dim2 - do i = 1,dim3 - do j = 1,dim1 - c(j,i) = c(j,i)+a(j,k)*b(k,i) - enddo - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine dmxxzz -! -! Multiplication of a diagonal complex matrix with a complex rectangular -! matrix: -! a(j)*b(j,i) = c(j,i) -!----------------------------------------------------------------------- - - subroutine dmxxzz (a,b,c,dim1,dim2) - - implicit none - - integer(long) :: i, j - integer(long), intent(in) :: dim1, dim2 - complex(dop), dimension(dim1), intent(in) :: a - complex(dop), dimension(dim1,dim2), intent(in) :: b - complex(dop), dimension(dim1,dim2), intent(out) :: c - - do i = 1,dim2 - do j = 1,dim1 - c(j,i) = a(j)*b(j,i) - enddo - enddo - - return - end subroutine - - -!----------------------------------------------------------------------- -! Library subroutine dmxxzza -! -! Multiplication of a diagonal complex matrix with a complex rectangular -! matrix: -! a(j)*b(j,i) + c(j,i) = c(j,i) -!----------------------------------------------------------------------- - - subroutine dmxxzza (a,b,c,dim1,dim2) - - implicit none - - integer(long) :: i, j - integer(long), intent(in) :: dim1, dim2 - complex(dop), dimension(dim1), intent(in) :: a - complex(dop), dimension(dim1,dim2), intent(in) :: b - complex(dop), dimension(dim1,dim2), intent(inout) :: c - - do i = 1,dim2 - do j = 1,dim1 - c(j,i) = c(j,i) + a(j)*b(j,i) - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine dmxxdz -! -! Multiplication of a diagonal real matrix with a real rectangular -! matrix: -! a(j)*b(j,i) = c(j,i) -!----------------------------------------------------------------------- - - subroutine dmxxdz (a,b,c,dim1,dim2) - - implicit none - - integer(long) :: i, j - integer(long), intent(in) :: dim1, dim2 - real(dop), dimension(dim1), intent(in) :: a - complex(dop), dimension(dim1,dim2), intent(in) :: b - complex(dop), dimension(dim1,dim2), intent(out) :: c - - do i = 1,dim2 - do j = 1,dim1 - c(j,i) = a(j)*b(j,i) - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine dmxxdd -! -! Multiplication of a diagonal real matrix with a real rectangular -! matrix: -! a(j)*b(j,i) = c(j,i) -!----------------------------------------------------------------------- - - subroutine dmxxdd (a,b,c,dim1,dim2) - - implicit none - - integer(long) :: i, j - integer(long), intent(in) :: dim1, dim2 - real(dop), dimension(dim1), intent(in) :: a - real(dop), dimension(dim1,dim2), intent(in) :: b - real(dop), dimension(dim1,dim2), intent(out) :: c - - do i = 1,dim2 - do j = 1,dim1 - c(j,i) = a(j)*b(j,i) - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine dqxxzz -! -! Multiplication of a diagonal complex matrix with a complex quadratic -! matrix: -! a(j)*b(j,i) = c(j,i) -!----------------------------------------------------------------------- - - subroutine dqxxzz (a,b,c,dim) - - implicit none - - integer(long) :: i, j - integer(long), intent(in) :: dim - complex(dop), dimension(dim), intent(in) :: a - complex(dop), dimension(dim,dim), intent(in) :: b - complex(dop), dimension(dim,dim), intent(out) :: c - - do i = 1,dim - do j = 1,dim - c(j,i) = a(j)*b(j,i) - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine ddxxdd -! -! Multiplication of a diagonal real matrix with a diagonal real matrix: -! a(j)*b(j) = c(j) -!----------------------------------------------------------------------- - - subroutine ddxxdd (a,b,c,dim) - - implicit none - - integer(long) :: j - integer(long), intent(in) :: dim - real(dop), dimension(dim), intent(in) :: a - real(dop), dimension(dim), intent(in) :: b - real(dop), dimension(dim), intent(out) :: c - - do j = 1,dim - c(j) = a(j)*b(j) - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine ddxxdz -! -! Multiplication of a diagonal real matrix with a diagonal complex matrix: -! a(j)*b(j) = c(j) -!----------------------------------------------------------------------- - - subroutine ddxxdz (a,b,c,dim) - - implicit none - - integer(long) :: j - integer(long), intent(in) :: dim - real(dop), dimension(dim), intent(in) :: a - complex(dop), dimension(dim), intent(in) :: b - complex(dop), dimension(dim), intent(out) :: c - - do j = 1,dim - c(j) = a(j)*b(j) - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine dqxxdd -! -! Multiplication of a diagonal real matrix with a real quadratic matrix: -! a(j)*b(j,i) = c(j,i) -!----------------------------------------------------------------------- - - subroutine dqxxdd (a,b,c,dim) - - implicit none - - integer(long) :: i, j - integer(long), intent(in) :: dim - real(dop), dimension(dim), intent(in) :: a - real(dop), dimension(dim,dim), intent(in) :: b - real(dop), dimension(dim,dim), intent(out) :: c - - do i = 1,dim - do j = 1,dim - c(j,i) = a(j)*b(j,i) - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine dqxxdd1 -! -! Multiplication of a diagonal real matrix with a real quadratic matrix: -! a(j)*b(j,i) = c(j,i) -! -! NB phdim is physical (leading) dimension, dim is used dimension -!----------------------------------------------------------------------- - - subroutine dqxxdd1 (a,b,c,phdim,dim) - - implicit none - - integer(long) :: i, j - integer(long), intent(in) :: dim, phdim - real(dop), dimension(dim), intent(in) :: a - real(dop), dimension(phdim,dim), intent(in) :: b - real(dop), dimension(phdim,dim), intent(out) :: c - - do i = 1,dim - do j = 1,dim - c(j,i) = a(j)*b(j,i) - enddo - enddo - - return - end subroutine - -! ---------------------------------------------------------------------- -! Library subroutine dqxxdz -! -! Multiplication of a diagonal real matrix with a complex matrix -! a(i)*v(i,j)=w(i,j) -!----------------------------------------------------------------------- - - subroutine dqxxdz (a,v,w,dim) - - implicit none - - integer(long) :: i, j - integer(long), intent(in) :: dim - real(dop), dimension(dim), intent(in) :: a - complex(dop), dimension(dim,dim), intent(in) :: v - complex(dop), dimension(dim,dim), intent(out) :: w - - do j=1,dim - do i=1,dim - w(i,j) = a(i)*v(i,j) - enddo - enddo - - return - end subroutine - - -! ---------------------------------------------------------------------- -! Library subroutine dqxxdz2 -! -! Multiplication of a diagonal real matrix with a complex matrix -! a(j)*v(i,j)=w(i,j) -!----------------------------------------------------------------------- - - subroutine dqxxdz2 (a,v,w,dim) - - implicit none - - integer(long) :: i, j - integer(long), intent(in) :: dim - real(dop), dimension(dim), intent(in) :: a - complex(dop), dimension(dim,dim), intent(in) :: v - complex(dop), dimension(dim,dim), intent(out) :: w - - do j=1,dim - do i=1,dim - w(i,j) = a(j)*v(i,j) - enddo - enddo - - return - end subroutine - - -!----------------------------------------------------------------------- -! Library subroutine mmxxdz -! -! Multiplication of a rectangular real matrix with a rectangular complex -! matrix: -! a(j,k)*b(k,i) = c(j,i) -!----------------------------------------------------------------------- - -! subroutine mmxxdz (a,b,c,dim1,dim2,dim3) - -! implicit none - -! integer(long) :: i, j, k -! integer(long), intent(in) :: dim1, dim2, dim3 -! real(dop), dimension(dim1,dim2), intent(in) :: a -! complex(dop), dimension(dim2,dim3), intent(in) :: b -! complex(dop), dimension(dim1,dim3), intent(out) :: c - -! do i=1,dim3 -! do j=1,dim1 -! c(j,i) = a(j,1)*b(1,i) -! enddo -! enddo -! do i = 1,dim3 -! do k = 2,dim2 -! do j = 1,dim1 -! c(j,i) = c(j,i)+a(j,k)*b(k,i) -! enddo -! enddo -! enddo - -! return -! end subroutine - -!----------------------------------------------------------------------- -! Library subroutine mmtxdd -! -! Multiplication of the transpose of a rectangular real matrix with a -! rectangular real matrix: -! a(k,j)*b(k,i) = c(j,i) -!----------------------------------------------------------------------- - - subroutine mmtxdd (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2, dim3 - real(dop), dimension(dim2,dim1), intent(in) :: a - real(dop), dimension(dim2,dim3), intent(in) :: b - real(dop), dimension(dim1,dim3), intent(out) :: c - - do i = 1,dim3 - do j = 1,dim1 - c(j,i) = a(1,j)*b(1,i) - do k = 2,dim2 - c(j,i) = c(j,i)+a(k,j)*b(k,i) - enddo - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine mmxtdd -! -! Multiplication of the rectangular real matrix with the transpose of a -! rectangular real matrix: -! a(j,k)*b(i,k) = c(j,i) -!----------------------------------------------------------------------- - - subroutine mmxtdd(a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2, dim3 - real(dop), dimension(dim1,dim2), intent(in) :: a - real(dop), dimension(dim3,dim2), intent(in) :: b - real(dop), dimension(dim1,dim3), intent(out) :: c - - do i = 1,dim3 - do j = 1,dim1 - c(j,i) = a(j,1)*b(i,1) - do k = 2,dim2 - c(j,i) = c(j,i)+a(j,k)*b(i,k) - enddo - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine mmtxdd1 -! -! Multiplication of the transpose of a rectangular real matrix with a -! rectangular real matrix: -! a(k,j)*b(k,i) = c(j,i) -! -! NB phdim is physical (leading) dimension, dim1-3 is used dimension -!----------------------------------------------------------------------- - - subroutine mmtxdd1 (a,b,c,phdim,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: phdim, dim1, dim2, & - dim3 - real(dop), dimension(phdim,phdim), intent(in) :: a - real(dop), dimension(phdim,phdim), intent(in) :: b - real(dop), dimension(phdim,phdim), intent(out) :: c - - do i = 1,dim3 - do j = 1,dim1 - c(j,i) = a(1,j)*b(1,i) - do k = 2,dim2 - c(j,i) = c(j,i)+a(k,j)*b(k,i) - enddo - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine mmxxdd -! -! Multiplication of two real rectangular matrices: -! a(j,k)*b(k,i) = c(j,i) -!----------------------------------------------------------------------- - - subroutine mmxxdd (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2, dim3 - real(dop), dimension(dim1,dim2), intent(in) :: a - real(dop), dimension(dim2,dim3), intent(in) :: b - real(dop), dimension(dim1,dim3), intent(out) :: c - - do i=1,dim3 - do j=1,dim1 - c(j,i) = a(j,1)*b(1,i) - enddo - enddo - do i = 1,dim3 - do k = 2,dim2 - do j = 1,dim1 - c(j,i) = c(j,i)+a(j,k)*b(k,i) - enddo - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine mmxxdd1 -! -! Multiplication of two real rectangular matrices: -! a(j,k)*b(k,i) = c(j,i) -! -! NB phdim is physical (leading) dimension, dim1-3 is used dimension -!----------------------------------------------------------------------- - - subroutine mmxxdd1 (a,b,c,phdim,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: phdim, dim1, dim2, & - dim3 - real(dop), dimension(phdim,phdim), intent(in) :: a - real(dop), dimension(phdim,phdim), intent(in) :: b - real(dop), dimension(phdim,phdim), intent(out) :: c - - do i=1,dim3 - do j=1,dim1 - c(j,i) = a(j,1)*b(1,i) - enddo - enddo - do i = 1,dim3 - do k = 2,dim2 - do j = 1,dim1 - c(j,i) = c(j,i)+a(j,k)*b(k,i) - enddo - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine qqxtdd -! -! Multiplication of a real quadratic matrix with the transpose of a real -! quadratic matrix: -! a(j,k)*b(i,k) = c(j,i) -!----------------------------------------------------------------------- - - subroutine qqxtdd (a,b,c,dim) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim - real(dop), dimension(dim,dim), intent(in) :: a - real(dop), dimension(dim,dim), intent(in) :: b - real(dop), dimension(dim,dim), intent(out) :: c - - do i = 1,dim - do j = 1,dim - c(j,i) = a(j,1)*b(i,1) - enddo - enddo - do k = 2,dim - do i = 1,dim - do j = 1,dim - c(j,i) = c(j,i)+a(j,k)*b(i,k) - enddo - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine qqxtdd1 -! -! Multiplication of a real quadratic matrix with the transpose of a real -! quadratic matrix: -! a(j,k)*b(i,k) = c(j,i) -! -! NB phdim is physical (leading) dimension, dim is used dimension -!----------------------------------------------------------------------- - - subroutine qqxtdd1 (a,b,c,phdim,dim) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: phdim, dim - real(dop), dimension(phdim,dim), intent(in) :: a - real(dop), dimension(phdim,dim), intent(in) :: b - real(dop), dimension(phdim,dim), intent(out) :: c - - do i = 1,dim - do j = 1,dim - c(j,i) = a(j,1)*b(i,1) - enddo - enddo - do k = 2,dim - do i = 1,dim - do j = 1,dim - c(j,i) = c(j,i)+a(j,k)*b(i,k) - enddo - enddo - enddo - - return - end subroutine - -! ---------------------------------------------------------------------- -! Library subroutine qqtxdd -! -! Multiplication of the transpose of a real quadratic matrix with a -! real quadratic matrix: -! a(k,j)*b(k,i) = c(j,i) -!----------------------------------------------------------------------- - - subroutine qqtxdd (a,b,c,dim) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim - real(dop), dimension(dim,dim), intent(in) :: a - real(dop), dimension(dim,dim), intent(in) :: b - real(dop), dimension(dim,dim), intent(out) :: c - - do i = 1,dim - do j = 1,dim - c(j,i) = a(1,j)*b(1,i) - do k = 2,dim - c(j,i) = c(j,i)+a(k,j)*b(k,i) - enddo - enddo - enddo - - return - end subroutine - -!---------------------------------------------------------------------- -! Library subroutine qdxxzz -! -! Multiplication of a complex quadratic matrix with a diagonal complex -! matrix: -! a(j,i)*b(i) = c(j,i) -!----------------------------------------------------------------------- - - subroutine qdxxzz (a,b,c,dim) - - implicit none - - integer(long) :: i, j - integer(long), intent(in) :: dim - complex(dop), dimension(dim,dim), intent(in) :: a - complex(dop), dimension(dim), intent(in) :: b - complex(dop), dimension(dim,dim), intent(out) :: c - - do i = 1,dim - do j = 1,dim - c(j,i) = a(j,i)*b(i) - enddo - enddo - - return - end subroutine - -!---------------------------------------------------------------------- -! Library subroutine qdxxdz -! -! Multiplication of a complex quadratic matrix with a diagonal real -! matrix: -! a(j,i)*b(i) = c(j,i) -!----------------------------------------------------------------------- - - subroutine qdxxdz (a,b,c,dim) - - implicit none - - integer(long) :: i, j - integer(long), intent(in) :: dim - real(dop), dimension(dim), intent(in) :: b - complex(dop), dimension(dim,dim), intent(in) :: a - complex(dop), dimension(dim,dim), intent(out) :: c - - do i = 1,dim - do j = 1,dim - c(j,i) = a(j,i)* b(i) - enddo - enddo - - return - end subroutine - -!---------------------------------------------------------------------- -! Library subroutine qdxxdd -! -! Multiplication of a real quadratic matrix with a diagonal real matrix: -! a(j,i)*b(i) = c(j,i) -!----------------------------------------------------------------------- - - subroutine qdxxdd (a,b,c,dim) - - implicit none - - integer(long) :: i, j - integer(long), intent(in) :: dim - real(dop), dimension(dim,dim), intent(in) :: a - real(dop), dimension(dim), intent(in) :: b - real(dop), dimension(dim,dim), intent(out) :: c - - do i = 1,dim - do j = 1,dim - c(j,i) = a(j,i)*b(i) - enddo - enddo - - return - end subroutine - -!---------------------------------------------------------------------- -! Library subroutine qdxxdd1 -! -! Multiplication of a real quadratic matrix with a diagonal real matrix: -! a(j,i)*b(i) = c(j,i) -! -! NB phdim is physical (leading) dimension, dim is used dimension -!----------------------------------------------------------------------- - - subroutine qdxxdd1 (a,b,c,phdim,dim) - - implicit none - - integer(long) :: i, j - integer(long), intent(in) :: phdim, dim - real(dop), dimension(phdim,dim), intent(in) :: a - real(dop), dimension(dim), intent(in) :: b - real(dop), dimension(phdim,dim), intent(out) :: c - - do i = 1,dim - do j = 1,dim - c(j,i) = a(j,i)*b(i) - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine hhxtzzc -! -! Multiplication of a complex hermitian matrix with the transpose of a -! complex hermitian matrix, where the two matrices commute: -! a(j,k)*b(i,k) = c(j,i) -! -! NB The fact that the two matrices commute means that the result of -! the multiplication is also hermitian -!----------------------------------------------------------------------- - - subroutine hhxtzzc (a,b,c,dim) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim - complex(dop), dimension(dim,dim), intent(in) :: a - complex(dop), dimension(dim,dim), intent(in) :: b - complex(dop), dimension(dim,dim), intent(out) :: c - - do i = 1,dim - do j = i,dim - c(j,i) = a(j,1)*b(i,1) - enddo - enddo - do k = 2,dim - do i = 1,dim - do j = i,dim - c(j,i) = c(j,i)+a(j,k)*b(i,k) - enddo - enddo - enddo - do i = 1,dim - do j = 1,i-1 - c(j,i) = dconjg(c(i,j)) - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine mmaxzzh -! -! Multiplication of the adjoint of a complex rectangular matrix with -! a rectangular complex matrix, where the result is a hermitian matrix -! dconjg(a(k,j))*b(k,i) = c(j,i) -! -! NB this routine can be used for the overlap of two sets of "spfs" in -! the same basis -!----------------------------------------------------------------------- - - subroutine mmaxzzh (a,b,c,dim1,dim2) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2 - complex(dop), dimension(dim1,dim2), intent(in) :: a - complex(dop), dimension(dim1,dim2), intent(in) :: b - complex(dop), dimension(dim2,dim2), intent(out) :: c - - do i = 1,dim2 - do j = i,dim2 - c(j,i) = dconjg(a(1,j))*b(1,i) - do k = 2,dim1 - c(j,i) = c(j,i)+dconjg(a(k,j))*b(k,i) - enddo - enddo - enddo -! -! now fill in other half of hermitian matrix -! - do i=1,dim2 - c(i,i)=dble(c(i,i)) - enddo - do i=1,dim2 - do j=1,i-1 - c(j,i)=dconjg(c(i,j)) - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine mmaxzzh1 -! -! Multiplication of the adjoint of a complex rectangular matrix with -! a rectangular complex matrix, where the result is an anti- hermitian -! matrix -! dconjg(a(k,j))*b(k,i) = c(j,i) -! -!----------------------------------------------------------------------- - - subroutine mmaxzzh1 (a,b,c,dim1,dim2) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2 - real(dop) :: x - complex(dop), dimension(dim1,dim2), intent(in) :: a - complex(dop), dimension(dim1,dim2), intent(in) :: b - complex(dop), dimension(dim2,dim2), intent(out) :: c - - do i = 1,dim2 - do j = i,dim2 - c(j,i) = dconjg(a(1,j))*b(1,i) - do k = 2,dim1 - c(j,i) = c(j,i)+dconjg(a(k,j))*b(k,i) - enddo - enddo - enddo -! -! now fill in other half of anti-hermitian matrix -! - do i=1,dim2 - x=dimag(c(i,i)) - c(i,i)=dcmplx(0.0d0,x) - enddo - do i=1,dim2 - do j=1,i-1 - c(j,i)=-dconjg(c(i,j)) - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine mmtxzzs -! -! Multiplication of a transposed complex rectangular matrix with -! a rectangular complex matrix, where the result is a symmetric matrix -! a(k,j)*b(k,i) = c(j,i) -!----------------------------------------------------------------------- - - subroutine mmtxzzs (a,b,c,dim1,dim2) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2 - complex(dop), dimension(dim1,dim2), intent(in) :: a - complex(dop), dimension(dim1,dim2), intent(in) :: b - complex(dop), dimension(dim2,dim2), intent(out) :: c - - do i = 1,dim2 - do j = i,dim2 - c(j,i) = a(1,j)*b(1,i) - do k = 2,dim1 - c(j,i) = c(j,i)+a(k,j)*b(k,i) - enddo - enddo - enddo -! -! now fill in other half of symmetric matrix -! - do i=1,dim2 - do j=1,i-1 - c(j,i)=c(i,j) - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine qmxxzz -! -! Multiplication of a complex quadratic matrix with a complex -! rectangular matrix: -! a(j,k)*b(k,i) = c(j,i) -!----------------------------------------------------------------------- - - subroutine qmxxzz (a,b,c,dim1,dim2) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2 - complex(dop), dimension(dim1,dim1), intent(in) :: a - complex(dop), dimension(dim1,dim2), intent(in) :: b - complex(dop), dimension(dim1,dim2), intent(out) :: c - - do i = 1,dim2 - do j = 1,dim1 - c(j,i) = a(j,1)*b(1,i) - enddo - enddo - do i = 1,dim2 - do k = 2,dim1 - do j = 1,dim1 - c(j,i) = c(j,i)+a(j,k)*b(k,i) - enddo - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine qqxxdd1 -! -! Multiplication of two real quadratic matrices: -! a(j,k)*b(k,i) = c(j,i) -! -! NB phdim is physical (leading) dimension, dim is used dimension -!----------------------------------------------------------------------- - - subroutine qqxxdd1 (a,b,c,phdim,dim) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: phdim, dim - real(dop), dimension(phdim,dim), intent(in) :: a - real(dop), dimension(phdim,dim), intent(in) :: b - real(dop), dimension(phdim,dim), intent(out) :: c - - do i = 1,dim - do j = 1,dim - c(j,i) = a(j,1)*b(1,i) - enddo - enddo - do i = 1,dim - do k = 2,dim - do j = 1,dim - c(j,i) = c(j,i)+a(j,k)*b(k,i) - enddo - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine mmxxzz1 -! -! Multiplication of two complex rectangular matrices: -! a(j,k)*b(k,i) = c(j,i) -! -! NB phdims are physical dimensions, dims are used dimensions -!----------------------------------------------------------------------- - -! subroutine mmxxzz1 (phdim1,phdim2,phdim3,dim1,dim2,dim3,a,b,c) - -! implicit none - -! integer(long) :: i, j, k -! integer(long), intent(in) :: phdim1, phdim2, & -! phdim3, dim1, & -! dim2, dim3 -! complex(dop), dimension(phdim1,phdim2), intent(in) :: a -! complex(dop), dimension(phdim2,phdim3), intent(in) :: b -! complex(dop). dimension(phdim1,phdim3), intent(out) :: c - -! do i = 1,dim3 -! do j = i,dim1 -! c(j,i) = a(j,1)*b(1,i) -! enddo -! enddo -! do i = 1,dim3 -! do k = 2,dim2 -! do j = 1,dim1 -! c(j,i) = c(j,i)+a(j,k)*b(k,i) -! enddo -! enddo -! enddo - -! return -! end subroutine - -!----------------------------------------------------------------------- -! Library subroutine mmaxzz -! -! Multiplication of the adjoint of a complex rectangular matrix with -! a rectangular complex matrix -! dconjg(a(k,j))*b(k,i) = c(j,i) -! -! NB this routine can be used for the overlap of two sets of vectors in -! different spf bases -!----------------------------------------------------------------------- - - subroutine mmaxzz (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2, & - dim3 - complex(dop), dimension(dim1,dim2), intent(in) :: a - complex(dop), dimension(dim1,dim3), intent(in) :: b - complex(dop), dimension(dim2,dim3), intent(out) :: c - - do i = 1,dim3 - do j = 1,dim2 - c(j,i) = dconjg(a(1,j))*b(1,i) - do k = 2,dim1 - c(j,i) = c(j,i)+dconjg(a(k,j))*b(k,i) - enddo - enddo - enddo - - return - end subroutine - - -!----------------------------------------------------------------------- -! Library subroutine mmtczz -! -! Multiplication of the transpose of a complex rectangular matrix with -! the complex conjugate of a rectangular complex matrix -! a(k,j)*dconjg(b(k,i)) = c(j,i) -! -!----------------------------------------------------------------------- - subroutine mmtczz (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2, & - dim3 - complex(dop), dimension(dim1,dim2), intent(in) :: a - complex(dop), dimension(dim1,dim3), intent(in) :: b - complex(dop), dimension(dim2,dim3), intent(out) :: c - - do i = 1,dim3 - do j = 1,dim2 - c(j,i) = a(1,j)*dconjg(b(1,i)) - do k = 2,dim1 - c(j,i) = c(j,i)+a(k,j)*dconjg(b(k,i)) - enddo - enddo - enddo - - return - end subroutine - - -!----------------------------------------------------------------------- -! Library subroutine mmaczz -! -! Multiplication of the adjoint of a complex rectangular matrix with -! a adjoint of a rectangular complex matrix -! dconjg(a(k,j))*dconjg(b(k,i)) = c(j,i) -! -! NB this routine can be used for the overlap of two sets of vectors in -! different spf bases -!----------------------------------------------------------------------- -! subroutine mmaczz (a,b,c,dim1,dim2,dim3) - -! implicit none - -! integer(long) :: i, j, k -! integer(long), intent(in) :: dim1, dim2, & -! dim3 -! complex(dop), dimension(dim1,dim2), intent(in) :: a -! complex(dop), dimension(dim1,dim3), intent(in) :: b -! complex(dop), dimension(dim2,dim3), intent(out) :: c - -! do i = 1,dim3 -! do j = 1,dim2 -! c(j,i) = dconjg(a(1,j))*dconjg(b(1,i)) -! do k = 2,dim1 -! c(j,i) = c(j,i)+dconjg(a(k,j))*dconjg(b(k,i)) -! enddo -! enddo -! enddo - -! return -! end subroutine - - -!----------------------------------------------------------------------- -! Library subroutine mmcxzz -! -! Multiplication of the adjoint of a complex rectangular matrix with -! a rectangular complex matrix -! dconjg(a(j,k))*b(k,i) = c(j,i) -! -! NB this routine can be used for the overlap of two sets of vectors in -! different spf bases -!----------------------------------------------------------------------- - subroutine mmcxzz (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2, & - dim3 - complex(dop), dimension(dim1,dim2), intent(in) :: a - complex(dop), dimension(dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim3), intent(out) :: c - - do i = 1,dim3 - do j = 1,dim1 - c(j,i) = dconjg(a(j,1))*b(1,i) - do k = 2,dim2 - c(j,i) = c(j,i)+dconjg(a(j,k))*b(k,i) - enddo - enddo - enddo - - return - end subroutine - - -!----------------------------------------------------------------------- -! Library subroutine qqcxzz -! -! Multiplication of the adjoint of a complex quadratic matrix with -! a quadratic complex matrix -! dconjg(a(j,k))*b(k,i) = c(j,i) -! -!----------------------------------------------------------------------- - subroutine qqcxzz (a,b,c,dim) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim - complex(dop), dimension(dim,dim), intent(in) :: a - complex(dop), dimension(dim,dim), intent(in) :: b - complex(dop), dimension(dim,dim), intent(out) :: c - - do i = 1,dim - do j = 1,dim - c(j,i) = dconjg(a(j,1))*b(1,i) - do k = 2,dim - c(j,i) = c(j,i)+dconjg(a(j,k))*b(k,i) - enddo - enddo - enddo - - return - end subroutine - - -!----------------------------------------------------------------------- -! Library subroutine mmaxzz -! -! Multiplication of the adjoint of a complex rectangular matrix with -! a rectangular complex matrix -! a(j,k)*dconjg(b(i,k)) = c(j,i) -! -! NB this routine can be used for the overlap of two sets of vectors in -! different spf bases -!----------------------------------------------------------------------- - - subroutine mmxazz (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2, & - dim3 - complex(dop), dimension(dim1,dim2), intent(in) :: a - complex(dop), dimension(dim3,dim2), intent(in) :: b - complex(dop), dimension(dim1,dim3), intent(out) :: c - - do i = 1,dim3 - do j = 1,dim1 - c(j,i) = 0.0d0 - enddo - enddo - - do i = 1,dim3 - do j = 1,dim1 - do k = 1,dim2 - c(j,i) = c(j,i)+a(j,k)*dconjg(b(i,k)) - enddo - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine mmxtzza -! -! Multiplication of a complex rectangular matrix with the transpose of -! a rectangular complex matrix, the result of which is added to a -! further matrix. -! a(j,k)*b(i,k) + c(j,i) = c(j,i) -!----------------------------------------------------------------------- - - subroutine mmxtzza (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2, & - dim3 - complex(dop), dimension(dim1,dim2), intent(in) :: a - complex(dop), dimension(dim3,dim2), intent(in) :: b - complex(dop), dimension(dim1,dim3), intent(inout) :: c - - do k = 1,dim2 - do i = 1,dim3 - do j = 1,dim1 - c(j,i) = c(j,i)+a(j,k)*b(i,k) - enddo - enddo - enddo - - return - end subroutine - - -!----------------------------------------------------------------------- -! Library subroutine mmcazza -! -! Multiplication of a conjugated complex rectangular matrix with the -! adjoint of a quadratic complex matrix, the result of which is added -! to a further rectangular matrix. -! conjg(a(j,k))*conjg(b(i,k)) + c(j,i) = c(j,i) -!----------------------------------------------------------------------- - subroutine mmcazza (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2, & - dim3 - complex(dop), dimension(dim1,dim2), intent(in) :: a - complex(dop), dimension(dim3,dim2), intent(in) :: b - complex(dop), dimension(dim1,dim3), intent(inout) :: c - - do k = 1,dim2 - do i = 1,dim3 - do j = 1,dim1 - c(j,i) = c(j,i)+conjg(a(j,k))*conjg(b(i,k)) - enddo - enddo - enddo - - return - end subroutine - - -!----------------------------------------------------------------------- -! Library subroutine mqxxzza -! -! Multiplication of a complex rectangular matrix with a quadratic -! complex matrix, the result of which is added to a further rectangular -! matrix. -! a(j,k)*b(k,i) + c(j,i) = c(j,i) -!----------------------------------------------------------------------- - - subroutine mqxxzza (a,b,c,dim1,dim2) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2 - complex(dop), dimension(dim1,dim2), intent(in) :: a - complex(dop), dimension(dim2,dim2), intent(in) :: b - complex(dop), dimension(dim1,dim2), intent(inout) :: c - - do i = 1,dim2 - do k = 1,dim2 - do j = 1,dim1 - c(j,i) = c(j,i)+a(j,k)*b(k,i) - enddo - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine mqxtzd -! -! Multiplication of a rectangular complex matrix with the transpose of -! a quadratic real matrix: -! a(j,k)*b(i,k) = c(j,i) -!----------------------------------------------------------------------- - - subroutine mqxtzd (a,b,c,dim1,dim2) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2 - real(dop), dimension(dim2,dim2), intent(in) :: b - complex(dop), dimension(dim1,dim2), intent(in) :: a - complex(dop), dimension(dim1,dim2), intent(out) :: c - - do j=1,dim1 - do i=1,dim2 - c(j,i) = a(j,1)*b(i,1) - enddo - enddo - do k=2,dim2 - do j=1,dim1 - do i=1,dim2 - c(j,i) = c(j,i)+a(j,k)*b(i,k) - enddo - enddo - enddo - - return - end subroutine - -!---------------------------------------------------------------------- -! Library subroutine qqtxzz -! -! Multiplication of the transpose of a complex quadratic matrix with a -! complex quadratic matrix: -! a(k,j)*b(k,i) = c(j,i) -!----------------------------------------------------------------------- - - subroutine qqtxzz (a,b,c,dim) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim - complex(dop), dimension(dim,dim), intent(in) :: a - complex(dop), dimension(dim,dim), intent(in) :: b - complex(dop), dimension(dim,dim), intent(out) :: c - - do i = 1,dim - do j = 1,dim - c(j,i) = a(1,j)*b(1,i) - do k = 2,dim - c(j,i) = c(j,i)+a(k,j)*b(k,i) - enddo - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine mqxazz -! -! Multiplication of a complex rectangular matrix with the adjoint of -! a quadratic complex matrix: -! a(j,k)*dconjg(b(i,k)) = c(j,i) -!----------------------------------------------------------------------- - - subroutine mqxazz (a,b,c,dim1,dim2) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2 - complex(dop), dimension(dim1,dim2), intent(in) :: a - complex(dop), dimension(dim2,dim2), intent(in) :: b - complex(dop), dimension(dim1,dim2), intent(out) :: c - - do i = 1,dim2 - do j = 1,dim1 - c(j,i) = a(j,1)*dconjg(b(i,1)) - enddo - enddo - do k = 2,dim2 - do i = 1,dim2 - do j = 1,dim1 - c(j,i) = c(j,i)+a(j,k)*dconjg(b(i,k)) - enddo - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine qmxxdz -! -! Multiplication of a quadratic real matrix with a rectangular complex -! matrix: -! a(j,k)*b(k,i) = c(j,i) -!----------------------------------------------------------------------- - - subroutine qmxxdz (a,b,c,dim1,dim2) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2 - real(dop), dimension(dim1,dim1), intent(in) :: a - complex(dop), dimension(dim1,dim2), intent(in) :: b - complex(dop), dimension(dim1,dim2), intent(out) :: c - - do i=1,dim2 - do j=1,dim1 - c(j,i) = a(j,1)*b(1,i) - enddo - enddo - do i = 1,dim2 - do k = 2,dim1 - do j = 1,dim1 - c(j,i) = c(j,i)+a(j,k)*b(k,i) - enddo - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine qmtxdz -! -! Multiplication of the transpose of a quadratic real matrix with a -! rectangular complex matrix: -! a(k,j)*b(k,i) = c(j,i) -!----------------------------------------------------------------------- - - subroutine qmtxdz (a,b,c,dim1,dim2) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2 - real(dop), dimension(dim1,dim1), intent(in) :: a - complex(dop), dimension(dim1,dim2), intent(in) :: b - complex(dop), dimension(dim1,dim2), intent(out) :: c - - do i = 1,dim2 - do j = 1,dim1 - c(j,i) = a(1,j)*b(1,i) - do k = 2,dim1 - c(j,i) = c(j,i)+a(k,j)*b(k,i) - enddo - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine qqxxzz -! -! Multiplication of two complex quadratic matrices: -! a(j,k)*b(k,i) = c(j,i) -!----------------------------------------------------------------------- - - subroutine qqxxzz (a,b,c,dim) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim - complex(dop), dimension(dim,dim), intent(in) :: a - complex(dop), dimension(dim,dim), intent(in) :: b - complex(dop), dimension(dim,dim), intent(out) :: c - - do i=1,dim - do j=1,dim - c(j,i) = a(j,1)*b(1,i) - enddo - enddo - do i = 1,dim - do k = 2,dim - do j = 1,dim - c(j,i) = c(j,i)+a(j,k)*b(k,i) - enddo - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine mqxtzz -! -! Multiplication of a complex rectangular matrix with the transpose of -! a quadratic complex matrix: -! a(j,k)*b(i,k) = c(j,i) -!----------------------------------------------------------------------- - - subroutine mqxtzz (a,b,c,dim1,dim2) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2 - complex(dop), dimension(dim1,dim2), intent(in) :: a - complex(dop), dimension(dim2,dim2), intent(in) :: b - complex(dop), dimension(dim1,dim2), intent(out) :: c - - do i = 1,dim2 - do j = 1,dim1 - c(j,i) = a(j,1)*b(i,1) - enddo - enddo - do k = 2,dim2 - do i = 1,dim2 - do j = 1,dim1 - c(j,i) = c(j,i)+a(j,k)*b(i,k) - enddo - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine mqxxzz -! -! Multiplication of a complex rectangular matrix with a quadratic -! complex matrix: -! a(j,k)*b(k,i) = c(j,i) -!----------------------------------------------------------------------- - - subroutine mqxxzz (a,b,c,dim1,dim2) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2 - complex(dop), dimension(dim1,dim2), intent(in) :: a - complex(dop), dimension(dim2,dim2), intent(in) :: b - complex(dop), dimension(dim1,dim2), intent(out) :: c - - do i = 1,dim2 - do j = 1,dim1 - c(j,i) = a(j,1)*b(1,i) - enddo - enddo - do i = 1,dim2 - do k = 2,dim2 - do j = 1,dim1 - c(j,i) = c(j,i)+a(j,k)*b(k,i) - enddo - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine mmtxzz -! -! Multiplication of a transposed complex rectangular matrix with -! a rectangular complex matrix -! a(k,j)*b(k,i) = c(j,i) -!----------------------------------------------------------------------- - - subroutine mmtxzz (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2, & - dim3 - complex(dop), dimension(dim1,dim2), intent(in) :: a - complex(dop), dimension(dim1,dim3), intent(in) :: b - complex(dop), dimension(dim2,dim3), intent(out) :: c - - do i = 1,dim3 - do j = 1,dim2 - c(j,i) = a(1,j)*b(1,i) - do k = 2,dim1 - c(j,i) = c(j,i)+a(k,j)*b(k,i) - enddo - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine mmtxzza -! -! Multiplication of a transposed complex rectangular matrix with -! a rectangular complex matrix -! a(k,j)*b(k,i) + c(j,i) = c(j,i) -!----------------------------------------------------------------------- - - subroutine mmtxzza (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2, & - dim3 - complex(dop), dimension(dim1,dim2), intent(in) :: a - complex(dop), dimension(dim1,dim3), intent(in) :: b - complex(dop), dimension(dim2,dim3), intent(inout) :: c - - do i = 1,dim3 - do j = 1,dim2 - do k = 1,dim1 - c(j,i) = c(j,i)+a(k,j)*b(k,i) - enddo - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine mmxczz -! -! Multiplication of a complex rectangular matrices with the complex -! conjugate of a rectangular matrix: -! a(j,k)*dconjg(b(k,i)) = c(j,i) -!----------------------------------------------------------------------- - - subroutine mmxczz (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2, & - dim3 - complex(dop), dimension(dim1,dim2), intent(in) :: a - complex(dop), dimension(dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim3), intent(out) :: c - - do i=1,dim3 - do j=1,dim1 - c(j,i) = a(j,1)*dconjg(b(1,i)) - enddo - enddo - do i = 1,dim3 - do k = 2,dim2 - do j = 1,dim1 - c(j,i) = c(j,i)+a(j,k)*dconjg(b(k,i)) - enddo - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine mqxczz -! -! Multiplication of a complex rectangular matrices with the complex -! conjugate of a quadratic matrix: -! a(j,k)*dconjg(b(k,i)) = c(j,i) -!----------------------------------------------------------------------- - - subroutine mqxczz (a,b,c,dim1,dim2) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2 - complex(dop), dimension(dim1,dim2), intent(in) :: a - complex(dop), dimension(dim2,dim2), intent(in) :: b - complex(dop), dimension(dim1,dim2), intent(out) :: c - - do i=1,dim2 - do j=1,dim1 - c(j,i) = a(j,1)*dconjg(b(1,i)) - enddo - enddo - do i = 1,dim2 - do k = 2,dim2 - do j = 1,dim1 - c(j,i) = c(j,i)+a(j,k)*dconjg(b(k,i)) - enddo - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine qqaxzz -! -! Multiplication of the adjoint of a complex quadratic matrix with -! a another quadratic complex matrix -! dconjg(a(k,j))*b(k,i) = c(j,i) -! -!----------------------------------------------------------------------- - - subroutine qqaxzz (a,b,c,dim) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim - complex(dop), dimension(dim,dim), intent(in) :: a - complex(dop), dimension(dim,dim), intent(in) :: b - complex(dop), dimension(dim,dim), intent(out) :: c - - do i = 1,dim - do j = 1,dim - c(j,i) = dconjg(a(1,j))*b(1,i) - do k = 2,dim - c(j,i) = c(j,i)+dconjg(a(k,j))*b(k,i) - enddo - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine qqxazz -! -! Multiplication of a complex quadratic matrix with the adjoint of -! a another quadratic complex matrix -! a(j,k)*dconjg(b(i,k)) = c(j,i) -! -!----------------------------------------------------------------------- - - subroutine qqxazz (a,b,c,dim) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim - complex(dop), dimension(dim,dim), intent(in) :: a - complex(dop), dimension(dim,dim), intent(in) :: b - complex(dop), dimension(dim,dim), intent(out) :: c - - do i = 1,dim - do j = 1,dim - c(j,i) = a(j,1)*dconjg(b(i,1)) - do k = 2,dim - c(j,i) = c(j,i)+a(j,k)*dconjg(b(i,k)) - enddo - enddo - enddo - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine msqzz -! Local control: generating vibrational wavefuntion -!----------------------------------------------------------------------- - - subroutine msqzz (a,b,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j - integer(long), intent(in) :: dim1, dim2, & - dim3 - complex(dop), dimension(dim1,dim2), intent(in) :: a - complex(dop), dimension(dim1,dim2), intent(out) :: b - - do i = 1,dim2 - do j = 1,dim1 - if (i .ne. dim3) then - b(j,i) = dcmplx(0.0d0) - else - b(j,i) = a(j,i) - endif - enddo - enddo - - - return - end subroutine - - end module mmlib Index: source/lib/linear/mtlib.f90 =================================================================== --- source/lib/linear/mtlib.f90 (revision 854) +++ source/lib/linear/mtlib.f90 (revision 855) @@ -1,3794 +0,0 @@ -! ********************************************************************** -! -! MTLIB -! -! Library module containing linear algebra routines that involve the -! multiplication of a tensor of third order with a matrix. -! -! Nomenclature: -! Each name has 6 basic characters: -! First 2 characters denote the objects being multiplied: -! q: quadratic matrix -! m: general (rectangular) matrix -! h: hermitian matrix -! p: positive definite matrix -! s: symmetric matrix -! u: unitary matrix -! d: diagonal matrix (only diagonal elements are supplied as a -! vector) -! t: 2nd index of tensor of third order -! t1: 1st index of tensor of third order -! v: vector -! x: scalar -! e.g. 'qt' denotes the operation (quadratic matrix * tensor 2nd -! index) -! e.g. 'qt1' denotes the operation (quadratic matrix * tensor 1st -! index) -! Character 3 denotes how first object is used: -! x: unchanged from input -! t: transpose of input -! a: adjoint of input -! c: complex conjugate of input -! v: as a vector -! Character 4 denotes how second object is used: -! see Character 3 above. -! Character 5, 6 denote data types of first, second object -! respectively: -! z: complex double precision (complex*16) -! c: complex single precision (complex*8) -! d: real double precision (real*8) -! r: real single precision (real*4) -! y: complex matrix stored as two double precision (real*8) -! matrices -! Further characters, if present, give more informaion: -! a: the result is added to a further object -! r: the result is subtracted (removed) from a further object -! c: the input matrices commute -! h: the resulting matrix is hermitian -! s: the resulting matrix is symmetric -! 1: the physical dimensions of the matrices differs from those -! used. -! -! The suffix _s after the name means that the routine works with a -! "selected" vector", i.e. not all elements are present. -! -! Contents: -! In the following list of available subroutines, matrices/tensors on -! the LHS of the definition are input, that on the RHS output. The -! usual summation convention is used i.e. a sum is made over repeated -! indices on the LHS. -! -! addtxxzz (a,b,dim1,dim2,dim3) -! Definition: a(j) + b(i,j,k) = b(i,j,k) . -! Dimensions: a(dim2),b(dim1,dim2,dim3) -! -! qtxxzz (a,b,c,dim1,dim2,dim3) -! Definition: a(l,j)*b(i,j,k) = c(i,l,k) . -! Dimensions: a(dim2,dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) -! -! qtxxzd (a,b,c,dim1,dim2,dim3) -! Definition: dble(a(l,j))*b(i,j,k) = c(i,l,k) . -! Dimensions: a(dim2,dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) -! -! qtxxzza (a,b,c,dim1,dim2,dim3) -! Definition: a(l,j)*b(i,j,k) + c(i,l,k) = c(i,l,k) . -! Dimensions: a(dim2,dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) -! -! qtxxzda (a,b,c,dim1,dim2,dim3) -! Definition: dble(a(l,j))*b(i,j,k) + c(i,l,k) = c(i,l,k) . -! Dimensions: a(dim2,dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) -! -! qttxzza (a,b,c,dim1,dim2,dim3) -! Definition: a(j,l)*b(i,j,k) + c(i,l,k) = c(i,l,k) . -! Dimensions: a(dim2,dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) -! -! qttxzzs (a,b,c,dim1,dim2,dim3) -! Definition: c(i,l,k) - a(j,l)*b(i,j,k) = c(i,l,k) . -! Dimensions: a(dim2,dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) -! -! qtxxzzr (a,b,c,dim1,dim2,dim3) -! Definition: c(i,l,k) - a(l,j)*b(i,j,k) = c(i,l,k) . -! Dimensions: a(dim2,dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) -! -! tqxxzza (a,b,c,dim1,dim2,dim3) -! Definition: a(i,j,k)*b(j,l) + c(i,l,k) = c(i,l,k) . -! Dimensions: a(dim1,dim2,dim3),b(dim2,dim2),c(dim1,dim2,dim3) -! -! tqxazza (a,b,c,dim1,dim2,dim3) -! Definition: a(i,j,k)*dconjg(b(l,j)) + c(i,l,k) = c(i,l,k) . -! Dimensions: a(dim1,dim2,dim3),b(dim2,dim2),c(dim1,dim2,dim3) -! -! tqxazz (a,b,c,dim1,dim2,dim3) -! Definition: a(i,j,k)*dconjg(b(l,j)) = c(i,l,k) . -! Dimensions: a(dim1,dim2,dim3),b(dim2,dim2),c(dim1,dim2,dim3) -! -! mtxxzz (a,b,c,dim1,dim2,dim3,dim4) -! Definition: a(l,j)*b(i,j,k) = c(i,l,k) . -! Dimensions: a(dim4,dim2),b(dim1,dim2,dim3),c(dim1,dim4,dim3) -! -! mtxxzd (a,b,c,dim1,dim2,dim3,dim4) -! Definition: a(l,j)*b(i,j,k) = c(i,l,k) . -! Dimensions: a(dim4,dim2),b(dim1,dim2,dim3),c(dim1,dim4,dim3) -! -! mtvxzz (a,b,c,dim1,dim2,dim3,dim4,p) -! Definition: a(p,j)*b(i,j,k) = c(i,k) . -! Dimensions: a(dim4,dim2),b(dim1,dim2,dim3),c(dim1,dim3) -! -! mtcxzz (a,b,c,dim1,dim2,dim3,dim4) -! Definition: conjg(a(l,j))*b(i,j,k) = c(i,l,k) . -! Dimensions: a(dim4,dim2),b(dim1,dim2,dim3),c(dim1,dim4,dim3) -! -! mtxxdz (a,b,c,dim1,dim2,dim3,dim4) -! Definition: a(l,j)*b(i,j,k) = c(i,l,k) . -! Dimensions: a(dim4,dim2),b(dim1,dim2,dim3),c(dim1,dim4,dim3) -! -! mttxzz (a,b,c,dim1,dim2,dim3,dim4) -! Definition: a(j,l)*b(i,j,k) = c(i,l,k) . -! Dimensions: a(dim2,dim4),b(dim1,dim2,dim3),c(dim1,dim4,dim3) -! -! mttxdd (a,b,c,dim1,dim2,dim3,dim4) -! Definition: a(j,l)*b(i,j,k) = c(i,l,k) . -! Dimensions: a(dim2,dim4),b(dim1,dim2,dim3),c(dim1,dim4,dim3) -! -! mttxdr (a,b,c,dim1,dim2,dim3,dim4) -! Definition: a(j,l)*b(i,j,k) = c(i,l,k) . -! Dimensions: a(dim2,dim4),b(dim1,dim2,dim3),c(dim1,dim4,dim3) -! -! mtxxdd (a,b,c,dim1,dim2,dim3,dim4) -! Definition: a(l,j)*b(i,j,k) = c(i,l,k) . -! Dimensions: a(dim4,dim2),b(dim1,dim2,dim3),c(dim1,dim4,dim3) -! -! mtaxzz (a,b,c,dim1,dim2,dim3,dim4) -! Definition: dconjg(a(j,l))*b(i,j,k) = c(i,l,k) . -! Dimensions: a(dim2,dim4),b(dim1,dim2,dim3),c(dim1,dim4,dim3) -! -!C qtxxdd (a,b,c,dim1,dim2,dim3) -!C Definition: a(l,j)*b(i,j,k) = c(i,l,k) . -!C Dimensions: a(dim2,dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) -! -! qtcxzz (a,b,c,dim1,dim2,dim3) -! Definition: dconjg(a(l,j))*b(i,j,k) = c(i,l,k) . -! Dimensions: a(dim2,dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) -! -! qttxdd (a,b,c,dim1,dim2,dim3) -! Definition: a(l,j)*b(i,j,k) = c(i,l,k) . -! Dimensions: a(dim2,dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) -! -! dtxxzz (a,b,c,dim1,dim2,dim3) -! Definition: a(j)*b(i,j,k) = c(i,j,k) . -! Dimensions: a(dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) -! -! dtxxzzo (a,b,dim1,dim2,dim3) -! Definition: a(j)*b(i,j,k) = b(i,j,k) . -! Dimensions: a(dim2),b(dim1,dim2,dim3) -! -! dtxxzzr (a,b,c,dim1,dim2,dim3) -! Definition: c(i,j,k) - a(j)*b(i,j,k) = c(i,j,k) . -! Dimensions: a(dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) -! -! dtxxdd (a,b,c,dim1,dim2,dim3) -! Definition: a(j)*b(i,j,k) = c(i,j,k) . -! Dimensions: a(dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) -! -! dtxxddo (a,b,dim1,dim2,dim3) -! Definition: a(j)*b(i,j,k) = b(i,j,k) . -! Dimensions: a(dim2),b(dim1,dim2,dim3) -! -! dtxxdz (a,b,c,dim1,dim2,dim3) -! Definition: a(j)*b(i,j,k) = c(i,j,k) . -! Dimensions: a(dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) -! -! dtxxdzo (a,b,dim1,dim2,dim3) -! Definition: a(j)*b(i,j,k) = b(i,j,k) . -! Dimensions: a(dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) -! -! qtaxzz (a,b,c,dim1,dim2,dim3) -! Definition: dconjg(a(j,l))*b(i,j,k) = c(i,l,k) . -! Dimensions: a(dim2,dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) -! -! qtxxdz (a,b,c,dim1,dim2,dim3) -! Definition: a(l,j)*b(i,j,k) = c(i,l,k) . -! Dimensions: a(dim2,dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) -! -! qtxxdza (a,b,c,dim1,dim2,dim3) -! Definition: a(l,j)*b(i,j,k) + c(i,l,k) = c(i,l,k) . -! Dimensions: a(dim2,dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) -! -! qt1xxdz (a,b,c,dim1,dim2,dim3) -! Definition: a(l,i)*b(i,j,k) = c(l,j,k) . -! Dimensions: a(dim1,dim1),b(dim1,dim2,dim3),c(dim1,dim2,dim3) -! -! dt1xxzz (a,b,c,dim1,dim2,dim3) -! Definition: a(i)*b(i,j,k) = c(i,j,k) . -! Dimensions: a(dim1),b(dim1,dim2,dim3),c(dim1,dim2,dim3) -! -! qt1txdz (a,b,c,dim1,dim2,dim3) -! Definition: a(i,l)*b(i,j,k) = c(l,j,k) . -! Dimensions: a(dim1,dim1),b(dim1,dim2,dim3),c(dim1,dim2,dim3) -! -! qttxdz (a,b,c,dim1,dim2,dim3) -! Definition: a(l,j)*b(i,j,k) = c(i,l,k) . -! Dimensions: a(dim2,dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) -! -! qttxzz (a,b,c,dim1,dim2,dim3) -! Definition: a(j,l)*b(i,j,k) = c(i,l,k) . -! Dimensions: a(dim2,dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) -! -! qtxxyz (a,b,c,dim1,dim2,dim3) -! Definition: a(l,j)*b(i,j,k) = c(i,l,k) . -! Dimensions: a(dim2,dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) -! -! qttxyz (a,b,c,dim1,dim2,dim3) -! Definition: a(j,l)*b(i,j,k) = c(i,l,k) . -! Dimensions: a(dim2,dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) -! -! dtxxyz (a,b,c,dim1,dim2,dim3) -! Definition: a(j,1)*b(i,j,k) + (0,1)*a(j,2)*b(i,j,k) = c(i,j,k) . -! Dimensions: a(dim2,2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) -! -! qtxxzz_s (a,b,c,dim1,dim2,dim3,index,index1) -! Definition: index(i,j,k)=x -! index1(i,l,k)=x1 -! a(l,j)*b(x) = c(x1) . -! Dimensions: a(dim2,dim2),index(dim1,dim2,dim3), -! index1(dim1,dim2,dim3),b(max(x)),c(max(x1)) -! -! mtxxzz_s (a,b,c,dim1,dim2,dim3,dim4,dim5,index,index1) -! Definition: index(i,j,k)=x -! index1(i,l,k)=x1 -! a(l,j)*b(x) = c(x1) . -! Dimensions: a(dim4,dim5),index(dim1,dim2,dim3), -! index1(dim1,dim2,dim3),b(max(x)),c(max(x1)) -! -! qttxzz_s (a,b,c,dim1,dim2,dim3,index,index1) -! Definition: index(i,j,k)=x -! index1(i,l,k)=x1 -! a(j,l)*b(x) = c(x1) . -! Dimensions: a(dim2,dim2),index(dim1,dim2,dim3), -! index1(dim1,dim2,dim3),b(max(x)),c(max(x1)) -! -! qtxxzza_s (a,b,c,dim1,dim2,dim3,index,index1) -! Definition: index(i,j,k)=x -! index1(i,l,k)=x1 -! a(l,j)*b(x) + c(x1) = c(x1) . -! Dimensions: a(dim2,dim2),index(dim1,dim2,dim3), -! index1(dim1,dim2,dim3),b(max(x)),c(max(x1)) -! -! qtxxzzr_s (a,b,c,dim1,dim2,dim3,index,index1) -! Definition: index(i,j,k)=x -! index1(i,l,k)=x1 -! c(x1) - a(l,j)*b(x) = c(x1) . -! Dimensions: a(dim2,dim2),index(dim1,dim2,dim3), -! index1(dim1,dim2,dim3),b(max(x)),c(max(x1)) -! -! ********************************************************************** - module mtlib - -use decimal, only: dop, long, sip - - implicit none - private - public :: addtxxzz, qtxxzz, qtxxzd, qtxxzza, qtxxzda, qttxzza, & - qttxzzs, qtxxzzr, tqxxzza, tqxazza, tqxazz, mtxxzz, & - mtvxzz, mtxxzd, mtcxzz, mtxxdz, mttxzz, mttxdd, mttxdr, & - mtxxdd, mtaxzz, qtxxdd, qtcxzz, qttxdd, dtxxzz, & - dtxxzzo, dtxxzzr, dtxxdd, dtxxddo, dtxxdz, dtxxdzo, qtaxzz, & - qtxxdz, qtxxdza, qt1xxdz, dt1xxzz, qt1txdz, & - qttxdz, qttxzz, qtxxyz, qttxyz, dtxxyz, qtxxzz_s, & - mtxxzz_s, qttxzz_s, qtxxzza_s, qtxxzzr_s - - contains - -!----------------------------------------------------------------------- -! Library subroutine addtxxzz -! -! Multiplication of a complex quadratic matrix with a complex tensor -! of third order: -! a(j) + b(i,j,k) = b(i,j,k). -! -! Input-variables: a - complex vector -! b - complex tensor of third order -! Output-variables: b - resulting complex tensor -!----------------------------------------------------------------------- - - subroutine addtxxzz (a,b,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2, & - dim3 - complex(dop), dimension(dim2), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(inout) :: b - - do k=1,dim3 - do j=1,dim2 - do i=1,dim1 - b(i,j,k)=b(i,j,k)+a(j) - enddo - enddo - enddo - - return - end subroutine - - -!----------------------------------------------------------------------- -! Library subroutine qtxxzz -! -! Multiplication of a complex quadratic matrix with a complex tensor -! of third order: -! a(l,j)*b(i,j,k) = c(i,l,k). -! -! Input-variables: a - complex matrix -! b - complex tensor of third order -! Output-variables: c - resulting complex tensor -!----------------------------------------------------------------------- - - subroutine qtxxzz (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1, dim2, & - dim3 - complex(dop), dimension(dim2,dim2), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c - - if (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim2 - do i=1,dim1 - c(i,l,k)=a(l,1)*b(i,1,k) - enddo - enddo - enddo - do k=1,dim3 - do j=2,dim2 - do l=1,dim2 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+a(l,j)*b(i,j,k) - enddo - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim2 - c(1,l,k)=a(l,1)*b(1,1,k) - enddo - enddo - do k=1,dim3 - do j=2,dim2 - do l=1,dim2 - c(1,l,k)=c(1,l,k)+a(l,j)*b(1,j,k) - enddo - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do l=1,dim2 - do i=1,dim1 - c(i,l,1)=a(l,1)*b(i,1,1) - enddo - enddo - do j=2,dim2 - do l=1,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+a(l,j)*b(i,j,1) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do l=1,dim2 - c(1,l,1)=a(l,1)*b(1,1,1) - enddo - do j=2,dim2 - do l=1,dim2 - c(1,l,1)=c(1,l,1)+a(l,j)*b(1,j,1) - enddo - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine qtxxzd -! -! Multiplication of a complex quadratic matrix with a real tensor -! of third order: -! dble(a(l,j))*b(i,j,k) = c(i,l,k). -! -! Input-variables: a - complex matrix (only real part used) -! b - real tensor of third order -! Output-variables: c - resulting real tensor -!----------------------------------------------------------------------- - - subroutine qtxxzd (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1, dim2, & - dim3 - real(dop), dimension(dim1,dim2,dim3), intent(in) :: b - real(dop), dimension(dim1,dim2,dim3), intent(out) :: c - complex(dop), dimension(dim2,dim2), intent(in) :: a - - if (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim2 - do i=1,dim1 - c(i,l,k)=dble(a(l,1))*b(i,1,k) - enddo - enddo - enddo - do k=1,dim3 - do j=2,dim2 - do l=1,dim2 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+dble(a(l,j))*b(i,j,k) - enddo - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim2 - c(1,l,k)=dble(a(l,1))*b(1,1,k) - enddo - enddo - do k=1,dim3 - do j=2,dim2 - do l=1,dim2 - c(1,l,k)=c(1,l,k)+dble(a(l,j))*b(1,j,k) - enddo - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do l=1,dim2 - do i=1,dim1 - c(i,l,1)=dble(a(l,1))*b(i,1,1) - enddo - enddo - do j=2,dim2 - do l=1,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+dble(a(l,j))*b(i,j,1) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do l=1,dim2 - c(1,l,1)=dble(a(l,1))*b(1,1,1) - enddo - do j=2,dim2 - do l=1,dim2 - c(1,l,1)=c(1,l,1)+dble(a(l,j))*b(1,j,1) - enddo - enddo - endif - - return - end subroutine - - -!----------------------------------------------------------------------- -! Library subroutine qtxxzza -! -! Multiplication of a complex quadratic matrix with a complex tensor -! of third order and added to a different tensor: -! a(l,j)*b(i,j,k) + c(i,l,k) = c(i,l,k). -! -! Input-variables: a - complex matrix -! b - complex tensor of third order -! c - complex tensor of third order -! Output-variables: c - resulting complex tensor -! -! NB input c matrix is overwritten on output. -!----------------------------------------------------------------------- - - subroutine qtxxzza (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1, dim2, & - dim3 - complex(dop), dimension(dim2,dim2), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c - - if (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - do l=1,dim2 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+a(l,j)*b(i,j,k) - enddo - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - do l=1,dim2 - c(1,l,k)=c(1,l,k)+a(l,j)*b(1,j,k) - enddo - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do j=1,dim2 - do l=1,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+a(l,j)*b(i,j,1) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do j=1,dim2 - do l=1,dim2 - c(1,l,1)=c(1,l,1)+a(l,j)*b(1,j,1) - enddo - enddo - endif - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine qtxxzda -! -! Multiplication of a complex quadratic matrix with a complex tensor -! of third order and added to a different tensor: -! dble(a(l,j))*b(i,j,k) + c(i,l,k) = c(i,l,k). -! -! Input-variables: a - complex matrix -! b - real tensor of third order -! c - real tensor of third order -! Output-variables: c - resulting complex tensor -! -! NB input ! matrix is overwritten on output. -!----------------------------------------------------------------------- - - subroutine qtxxzda (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1, dim2, & - dim3 - real(dop), dimension(dim1,dim2,dim3), intent(in) :: b - real(dop), dimension(dim1,dim2,dim3), intent(inout) :: c - complex(dop), dimension(dim2,dim2), intent(in) :: a - - if (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - do l=1,dim2 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+dble(a(l,j))*b(i,j,k) - enddo - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - do l=1,dim2 - c(1,l,k)=c(1,l,k)+dble(a(l,j))*b(1,j,k) - enddo - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do j=1,dim2 - do l=1,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+dble(a(l,j))*b(i,j,1) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do j=1,dim2 - do l=1,dim2 - c(1,l,1)=c(1,l,1)+dble(a(l,j))*b(1,j,1) - enddo - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine qttxzza -! -! Multiplication of a complex quadratic matrix with a complex tensor -! of third order and added to a different tensor: -! a(j,l)*b(i,j,k) + c(i,l,k) = c(i,l,k). -! -! Input-variables: a - complex matrix -! b - complex tensor of third order -! c - complex tensor of third order -! Output-variables: c - resulting complex tensor -! -! NB input ! matrix is overwritten on output. -!----------------------------------------------------------------------- - - subroutine qttxzza (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1, dim2, & - dim3 - complex(dop), dimension(dim2,dim2), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c - - if (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - do l=1,dim2 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+a(j,l)*b(i,j,k) - enddo - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - do l=1,dim2 - c(1,l,k)=c(1,l,k)+a(j,l)*b(1,j,k) - enddo - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do j=1,dim2 - do l=1,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+a(j,l)*b(i,j,1) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do j=1,dim2 - do l=1,dim2 - c(1,l,1)=c(1,l,1)+a(j,l)*b(1,j,1) - enddo - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine qtxxzzs -! -! Multiplication of a complex quadratic matrix with a complex tensor -! of third order and subtracted from a different tensor: -! c(i,l,k) - a(l,j)*b(i,j,k) = c(i,l,k). -! -! Input-variables: a - complex matrix -! b - complex tensor of third order -! c - complex tensor of third order -! Output-variables: c - resulting complex tensor -! -! NB input ! matrix is overwritten on output. -!----------------------------------------------------------------------- - -! subroutine qtxxzzs (a,b,c,dim1,dim2,dim3) - -! implicit none - -! integer(long) :: i, j, k, l -! integer(long), intent(in) :: dim1, dim2, & -! dim3 -! complex(dop), dimension(dim2,dim2), intent(in) :: a -! complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b -! complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c - -! if (dim1.ne.1 .and. dim3.ne.1) then -! do k=1,dim3 -! do j=1,dim2 -! do l=1,dim2 -! do i=1,dim1 -! c(i,l,k)=c(i,l,k)-a(l,j)*b(i,j,k) -! enddo -! enddo -! enddo -! enddo -! else if (dim1.eq.1 .and. dim3.ne.1) then -! do k=1,dim3 -! do j=1,dim2 -! do l=1,dim2 -! c(1,l,k)=c(1,l,k)-a(l,j)*b(1,j,k) -! enddo -! enddo -! enddo -! else if (dim1.ne.1 .and. dim3.eq.1) then -! do j=1,dim2 -! do l=1,dim2 -! do i=1,dim1 -! c(i,l,1)=c(i,l,1)-a(l,j)*b(i,j,1) -! enddo -! enddo -! enddo -! else if (dim1.eq.1 .and. dim3.eq.1) then -! do j=1,dim2 -! do l=1,dim2 -! c(1,l,1)=c(1,l,1)-a(l,j)*b(1,j,1) -! enddo -! enddo -! endif - -! return -! end subroutine - - -!----------------------------------------------------------------------- -! Library subroutine qttxzzs -! -! Multiplication of a complex quadratic matrix with a complex tensor -! of third order and substracted from a different tensor: -! c(i,l,k) - a(j,l)*b(i,j,k) = c(i,l,k). -! -! Input-variables: a - complex matrix -! b - complex tensor of third order -! c - complex tensor of third order -! Output-variables: c - resulting complex tensor -! -! NB input ! matrix is overwritten on output. -!----------------------------------------------------------------------- - - subroutine qttxzzs (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1, dim2, & - dim3 - complex(dop), dimension(dim2,dim2), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c - - if (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - do l=1,dim2 - do i=1,dim1 - c(i,l,k)=c(i,l,k)-a(j,l)*b(i,j,k) - enddo - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - do l=1,dim2 - c(1,l,k)=c(1,l,k)-a(j,l)*b(1,j,k) - enddo - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do j=1,dim2 - do l=1,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)-a(j,l)*b(i,j,1) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do j=1,dim2 - do l=1,dim2 - c(1,l,1)=c(1,l,1)-a(j,l)*b(1,j,1) - enddo - enddo - endif - - return - end subroutine - - -!----------------------------------------------------------------------- -! Library subroutine qtxxzzr -! -! Multiplication of a complex quadratic matrix with a complex tensor -! of third order and subtracted from a different tensor: -! c(i,l,k) - a(l,j)*b(i,j,k) = c(i,l,k). -! -! Input-variables: a - complex matrix -! b - complex tensor of third order -! c - complex tensor of third order -! Output-variables: c - resulting complex tensor -!----------------------------------------------------------------------- - - subroutine qtxxzzr (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1, dim2, & - dim3 - complex(dop), dimension(dim2,dim2), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c - - if (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - do l=1,dim2 - do i=1,dim1 - c(i,l,k)=c(i,l,k)-a(l,j)*b(i,j,k) - enddo - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - do l=1,dim2 - c(1,l,k)=c(1,l,k)-a(l,j)*b(1,j,k) - enddo - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do j=1,dim2 - do l=1,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)-a(l,j)*b(i,j,1) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do j=1,dim2 - do l=1,dim2 - c(1,l,1)=c(1,l,1)-a(l,j)*b(1,j,1) - enddo - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine tqxxzza -! -! Multiplication of a complex quadratic matrix with a complex tensor -! of third order and added to a different tensor: -! a(i,j,k)*b(j,l) + c(i,l,k) = c(i,l,k). -! -! Input-variables: a - complex tensor of third order -! b - complex matrix -! c - complex tensor of third order -! Output-variables: c - resulting complex tensor -! -! NB input ! matrix is overwritten on output. -!----------------------------------------------------------------------- - - subroutine tqxxzza (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1, dim2, & - dim3 - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: a - complex(dop), dimension(dim2,dim2), intent(in) :: b - complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c - - if (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim2 - do j=1,dim2 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+a(i,j,k)*b(j,l) - enddo - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim2 - do j=1,dim2 - c(1,l,k)=c(1,l,k)+a(1,j,k)*b(j,l) - enddo - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do l=1,dim2 - do j=1,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+a(i,j,1)*b(j,l) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do l=1,dim2 - do j=1,dim2 - c(1,l,1)=c(1,l,1)+a(1,j,1)*b(j,l) - enddo - enddo - endif - - return - end subroutine - - - -!----------------------------------------------------------------------- -! Library subroutine tqxazza -! -! Multiplication of a complex quadratic matrix with a complex tensor -! of third order and added to a different tensor: -! a(i,j,k)*dconjg(b(l,j)) + c(i,l,k) = c(i,l,k). -! -! Input-variables: a - complex tensor of third order -! b - complex matrix -! c - complex tensor of third order -! Output-variables: c - resulting complex tensor -! -! NB input ! matrix is overwritten on output. -!----------------------------------------------------------------------- - - subroutine tqxazza (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1, dim2, & - dim3 - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: a - complex(dop), dimension(dim2,dim2), intent(in) :: b - complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c - - if (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim2 - do j=1,dim2 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+a(i,j,k)*dconjg(b(l,j)) - enddo - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim2 - do j=1,dim2 - c(1,l,k)=c(1,l,k)+a(1,j,k)*dconjg(b(l,j)) - enddo - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do l=1,dim2 - do j=1,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+a(i,j,1)*dconjg(b(l,j)) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do l=1,dim2 - do j=1,dim2 - c(1,l,1)=c(1,l,1)+a(1,j,1)*dconjg(b(l,j)) - enddo - enddo - endif - - return - end subroutine - - - -!----------------------------------------------------------------------- -! Library subroutine tqxazz -! -! Multiplication of a complex quadratic matrix with a complex tensor -! of third order: -! a(i,j,k)*dconjg(b(l,j)) = c(i,l,k). -! -! Input-variables: a - complex tensor of third order -! b - complex matrix -! -! Output-variables: c - resulting complex tensor -! -!----------------------------------------------------------------------- - - subroutine tqxazz (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1, dim2, & - dim3 - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: a - complex(dop), dimension(dim2,dim2), intent(in) :: b - complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c - - If (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim2 - do i=1,dim1 - c(i,l,k)=a(i,1,k)*dconjg(b(l,1)) - enddo - enddo - enddo - do k=1,dim3 - do l=1,dim2 - do j=2,dim2 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+a(i,j,k)*dconjg(b(l,j)) - enddo - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim2 - c(1,l,k)=a(1,1,k)*dconjg(b(l,1)) - enddo - enddo - do k=1,dim3 - do l=1,dim2 - do j=2,dim2 - c(1,l,k)=c(1,l,k)+a(1,j,k)*dconjg(b(l,j)) - enddo - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do l=1,dim2 - do i=1,dim1 - c(i,l,1)=a(i,1,1)*dconjg(b(l,1)) - enddo - enddo - do l=1,dim2 - do j=2,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+a(i,j,1)*dconjg(b(l,j)) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do l=1,dim2 - c(1,l,1)=a(1,1,1)*dconjg(b(l,1)) - enddo - do l=1,dim2 - do j=2,dim2 - c(1,l,1)=c(1,l,1)+a(1,j,1)*dconjg(b(l,j)) - enddo - enddo - endif - - return - end subroutine - - -!----------------------------------------------------------------------- -! Library subroutine mtxxzz -! -! Multiplication of a complex rectangular matrix with a complex tensor -! of third order: -! a(l,j)*b(i,j,k) = c(i,l,k) . -! -! Input-variables: a - complex matrix -! b - complex tensor of third order -! Output-variables: c - resulting complex tensor -!----------------------------------------------------------------------- - - subroutine mtxxzz (a,b,c,dim1,dim2,dim3,dim4) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1, dim2, & - dim3, dim4 - complex(dop), dimension(dim4,dim2), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim4,dim3), intent(out) :: c - - If (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim4 - do i=1,dim1 - c(i,l,k)=a(l,1)*b(i,1,k) - enddo - enddo - enddo - do k=1,dim3 - do j=2,dim2 - do l=1,dim4 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+a(l,j)*b(i,j,k) - enddo - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim4 - c(1,l,k)=a(l,1)*b(1,1,k) - enddo - enddo - do k=1,dim3 - do j=2,dim2 - do l=1,dim4 - c(1,l,k)=c(1,l,k)+a(l,j)*b(1,j,k) - enddo - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do l=1,dim4 - do i=1,dim1 - c(i,l,1)=a(l,1)*b(i,1,1) - enddo - enddo - do j=2,dim2 - do l=1,dim4 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+a(l,j)*b(i,j,1) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do l=1,dim4 - c(1,l,1)=a(l,1)*b(1,1,1) - enddo - do j=2,dim2 - do l=1,dim4 - c(1,l,1)=c(1,l,1)+a(l,j)*b(1,j,1) - enddo - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine mtvxzz -! -! Multiplication of a complex rectangular matrix with a complex tensor -! of third order witth p fixed (matrix used as a vector): -! a(p,j)*b(i,j,k) = c(i,k) . -! -! Input-variables: a - complex matrix -! b - complex tensor of third order -! Output-variables: c - resulting complex tensor -!----------------------------------------------------------------------- - - subroutine mtvxzz (a,b,c,dim1,dim2,dim3,dim4,p) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2, & - dim3, dim4, p - complex(dop), dimension(dim4,dim2), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim3), intent(out) :: c - - If (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do i=1,dim1 - c(i,k)=a(p,1)*b(i,1,k) - enddo - enddo - do k=1,dim3 - do j=2,dim2 - do i=1,dim1 - c(i,k)=c(i,k)+a(p,j)*b(i,j,k) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - c(1,k)=a(p,1)*b(1,1,k) - enddo - do k=1,dim3 - do j=2,dim2 - c(1,k)=c(1,k)+a(p,j)*b(1,j,k) - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do i=1,dim1 - c(i,1)=a(p,1)*b(i,1,1) - enddo - do j=2,dim2 - do i=1,dim1 - c(i,1)=c(i,1)+a(p,j)*b(i,j,1) - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - c(1,1)=a(p,1)*b(1,1,1) - do j=2,dim2 - c(1,1)=c(1,1)+a(p,j)*b(1,j,1) - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine mtxxzd -! -! Multiplication of a complex rectangular matrix with a real tensor -! of third order: -! dble(a(l,j))*b(i,j,k) = c(i,l,k) . -! -! Input-variables: a - complex matrix -! b - real tensor of third order -! Output-variables: c - resulting real tensor -!----------------------------------------------------------------------- - - subroutine mtxxzd (a,b,c,dim1,dim2,dim3,dim4) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1, dim2, & - dim3, dim4 - real(dop), dimension(dim1,dim2,dim3), intent(in) :: b - real(dop), dimension(dim1,dim4,dim3), intent(out) :: c - complex(dop), dimension(dim4,dim2), intent(in) :: a - - If (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim4 - do i=1,dim1 - c(i,l,k)=dble(a(l,1))*b(i,1,k) - enddo - enddo - enddo - do k=1,dim3 - do j=2,dim2 - do l=1,dim4 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+dble(a(l,j))*b(i,j,k) - enddo - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim4 - c(1,l,k)=dble(a(l,1))*b(1,1,k) - enddo - enddo - do k=1,dim3 - do j=2,dim2 - do l=1,dim4 - c(1,l,k)=c(1,l,k)+dble(a(l,j))*b(1,j,k) - enddo - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do l=1,dim4 - do i=1,dim1 - c(i,l,1)=dble(a(l,1))*b(i,1,1) - enddo - enddo - do j=2,dim2 - do l=1,dim4 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+dble(a(l,j))*b(i,j,1) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do l=1,dim4 - c(1,l,1)=dble(a(l,1))*b(1,1,1) - enddo - do j=2,dim2 - do l=1,dim4 - c(1,l,1)=c(1,l,1)+dble(a(l,j))*b(1,j,1) - enddo - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine mtcxzz -! -! Multiplication of a complex rectangular matrix with a complex tensor -! of third order: -! conjg(a(l,j))*b(i,j,k) = c(i,l,k) . -! -! Input-variables: a - complex matrix -! b - complex tensor of third order -! Output-variables: c - resulting complex tensor -!----------------------------------------------------------------------- - - subroutine mtcxzz (a,b,c,dim1,dim2,dim3,dim4) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1, dim2, & - dim3, dim4 - complex(dop), dimension(dim4,dim2), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim4,dim3), intent(out) :: c - - If (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim4 - do i=1,dim1 - c(i,l,k)=conjg(a(l,1))*b(i,1,k) - enddo - enddo - enddo - do k=1,dim3 - do j=2,dim2 - do l=1,dim4 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+conjg(a(l,j))*b(i,j,k) - enddo - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim4 - c(1,l,k)=conjg(a(l,1))*b(1,1,k) - enddo - enddo - do k=1,dim3 - do j=2,dim2 - do l=1,dim4 - c(1,l,k)=c(1,l,k)+conjg(a(l,j))*b(1,j,k) - enddo - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do l=1,dim4 - do i=1,dim1 - c(i,l,1)=conjg(a(l,1))*b(i,1,1) - enddo - enddo - do j=2,dim2 - do l=1,dim4 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+conjg(a(l,j))*b(i,j,1) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do l=1,dim4 - c(1,l,1)=conjg(a(l,1))*b(1,1,1) - enddo - do j=2,dim2 - do l=1,dim4 - c(1,l,1)=c(1,l,1)+conjg(a(l,j))*b(1,j,1) - enddo - enddo - endif - - return - end subroutine - - -!----------------------------------------------------------------------- -! Library subroutine mtxxdz -! -! Multiplication of a real rectangular matrix with a complex tensor -! of third order: -! a(l,j)*b(i,j,k) = c(i,l,k) . -! -! Input-variables: a - real rectangular matrix -! b - complex tensor of third order -! Output-variables: c - resulting complex tensor -!----------------------------------------------------------------------- - - subroutine mtxxdz (a,b,c,dim1,dim2,dim3,dim4) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1, dim2, & - dim3, dim4 - real(dop), dimension(dim4,dim2), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim4,dim3), intent(out) :: c - - If (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim4 - do i=1,dim1 - c(i,l,k)=a(l,1)*b(i,1,k) - enddo - enddo - enddo - do k=1,dim3 - do j=2,dim2 - do l=1,dim4 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+a(l,j)*b(i,j,k) - enddo - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim4 - c(1,l,k)=a(l,1)*b(1,1,k) - enddo - enddo - do k=1,dim3 - do j=2,dim2 - do l=1,dim4 - c(1,l,k)=c(1,l,k)+a(l,j)*b(1,j,k) - enddo - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do l=1,dim4 - do i=1,dim1 - c(i,l,1)=a(l,1)*b(i,1,1) - enddo - enddo - do j=2,dim2 - do l=1,dim4 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+a(l,j)*b(i,j,1) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do l=1,dim4 - c(1,l,1)=a(l,1)*b(1,1,1) - enddo - do j=2,dim2 - do l=1,dim4 - c(1,l,1)=c(1,l,1)+a(l,j)*b(1,j,1) - enddo - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine mttxzz -! -! Multiplication of a transposed complex rectangular matrix with a -! complex tensor of third order: -! a(j,l)*b(i,j,k) = c(i,l,k). -! -! Input-variables: a - complex matrix -! b - complex tensor of third order -! Output-variables: c - resulting complex tensor -!----------------------------------------------------------------------- - - subroutine mttxzz (a,b,c,dim1,dim2,dim3,dim4) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1, dim2, & - dim3, dim4 - complex(dop), dimension(dim2,dim4), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim4,dim3), intent(out) :: c - - If (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim4 - do i=1,dim1 - c(i,l,k)=a(1,l)*b(i,1,k) - enddo - enddo - enddo - do k=1,dim3 - do l=1,dim4 - do j=2,dim2 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+a(j,l)*b(i,j,k) - enddo - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim4 - c(1,l,k)=a(1,l)*b(1,1,k) - enddo - enddo - do k=1,dim3 - do l=1,dim4 - do j=2,dim2 - c(1,l,k)=c(1,l,k)+a(j,l)*b(1,j,k) - enddo - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do l=1,dim4 - do i=1,dim1 - c(i,l,1)=a(1,l)*b(i,1,1) - enddo - enddo - do l=1,dim4 - do j=2,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+a(j,l)*b(i,j,1) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do l=1,dim4 - c(1,l,1)=a(1,l)*b(1,1,1) - enddo - do l=1,dim4 - do j=2,dim2 - c(1,l,1)=c(1,l,1)+a(j,l)*b(1,j,1) - enddo - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine mttxdd -! -! Multiplication of a transposed real rectangular matrix with a -! real tensor of third order: -! a(j,l)*b(i,j,k) = c(i,l,k). -! -! Input-variables: a - real matrix -! b - real tensor of third order -! Output-variables: c - resulting real tensor -!----------------------------------------------------------------------- - - subroutine mttxdd (a,b,c,dim1,dim2,dim3,dim4) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1, dim2, & - dim3, dim4 - real(dop), dimension(dim2,dim4), intent(in) :: a - real(dop), dimension(dim1,dim2,dim3), intent(in) :: b - real(dop), dimension(dim1,dim4,dim3), intent(out) :: c - - If (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim4 - do i=1,dim1 - c(i,l,k)=a(1,l)*b(i,1,k) - enddo - enddo - enddo - do k=1,dim3 - do l=1,dim4 - do j=2,dim2 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+a(j,l)*b(i,j,k) - enddo - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim4 - c(1,l,k)=a(1,l)*b(1,1,k) - enddo - enddo - do k=1,dim3 - do l=1,dim4 - do j=2,dim2 - c(1,l,k)=c(1,l,k)+a(j,l)*b(1,j,k) - enddo - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do l=1,dim4 - do i=1,dim1 - c(i,l,1)=a(1,l)*b(i,1,1) - enddo - enddo - do l=1,dim4 - do j=2,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+a(j,l)*b(i,j,1) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do l=1,dim4 - c(1,l,1)=a(1,l)*b(1,1,1) - enddo - do l=1,dim4 - do j=2,dim2 - c(1,l,1)=c(1,l,1)+a(j,l)*b(1,j,1) - enddo - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine mttxdr -! -! Multiplication of a transposed real rectangular matrix with a -! real tensor of third order: -! a(j,l)*b(i,j,k) = c(i,l,k). -! -! Input-variables: a - real matrix -! b - real tensor of third order -! Output-variables: c - resulting real tensor -!----------------------------------------------------------------------- - - subroutine mttxdr (a,b,c,dim1,dim2,dim3,dim4) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1, dim2, & - dim3, dim4 - real(sip), dimension(dim1,dim2,dim3), intent(in) :: b - real(dop), dimension(dim2,dim4), intent(in) :: a - real(dop), dimension(dim1,dim4,dim3), intent(out) :: c - - If (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim4 - do i=1,dim1 - c(i,l,k)=a(1,l)*b(i,1,k) - enddo - enddo - enddo - do k=1,dim3 - do l=1,dim4 - do j=2,dim2 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+a(j,l)*b(i,j,k) - enddo - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim4 - c(1,l,k)=a(1,l)*b(1,1,k) - enddo - enddo - do k=1,dim3 - do l=1,dim4 - do j=2,dim2 - c(1,l,k)=c(1,l,k)+a(j,l)*b(1,j,k) - enddo - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do l=1,dim4 - do i=1,dim1 - c(i,l,1)=a(1,l)*b(i,1,1) - enddo - enddo - do l=1,dim4 - do j=2,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+a(j,l)*b(i,j,1) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do l=1,dim4 - c(1,l,1)=a(1,l)*b(1,1,1) - enddo - do l=1,dim4 - do j=2,dim2 - c(1,l,1)=c(1,l,1)+a(j,l)*b(1,j,1) - enddo - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine mtxxdd -! -! Multiplication of a real rectangular matrix with a real tensor -! of third order: -! a(l,j)*b(i,j,k) = c(i,l,k) . -! -! Input-variables: a - real matrix -! b - real tensor of third order -! Output-variables: c - resulting real tensor -!----------------------------------------------------------------------- - - subroutine mtxxdd (a,b,c,dim1,dim2,dim3,dim4) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1, dim2, & - dim3, dim4 - real(dop), dimension(dim4,dim2), intent(in) :: a - real(dop), dimension(dim1,dim2,dim3), intent(in) :: b - real(dop), dimension(dim1,dim4,dim3), intent(out) :: c - - If (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim4 - do i=1,dim1 - c(i,l,k)=a(l,1)*b(i,1,k) - enddo - enddo - enddo - do k=1,dim3 - do j=2,dim2 - do l=1,dim4 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+a(l,j)*b(i,j,k) - enddo - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim4 - c(1,l,k)=a(l,1)*b(1,1,k) - enddo - enddo - do k=1,dim3 - do j=2,dim2 - do l=1,dim4 - c(1,l,k)=c(1,l,k)+a(l,j)*b(1,j,k) - enddo - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do l=1,dim4 - do i=1,dim1 - c(i,l,1)=a(l,1)*b(i,1,1) - enddo - enddo - do j=2,dim2 - do l=1,dim4 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+a(l,j)*b(i,j,1) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do l=1,dim4 - c(1,l,1)=a(l,1)*b(1,1,1) - enddo - do j=2,dim2 - do l=1,dim4 - c(1,l,1)=c(1,l,1)+a(l,j)*b(1,j,1) - enddo - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine mtaxzz -! -! Multiplication of the adjoint of a complex rectangular matrix with a -! complex tensor of third order: -! dconj(a(j,l))*b(i,j,k) = c(i,l,k). -! -! Input-variables: a - complex matrix -! b - complex tensor of third order -! Output-variables: c - resulting complex tensor -!----------------------------------------------------------------------- - - subroutine mtaxzz (a,b,c,dim1,dim2,dim3,dim4) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1, dim2, & - dim3, dim4 - complex(dop), dimension(dim2,dim4), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim4,dim3), intent(out) :: c - - If (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim4 - do i=1,dim1 - c(i,l,k)=dconjg(a(1,l))*b(i,1,k) - enddo - enddo - enddo - do k=1,dim3 - do l=1,dim4 - do j=2,dim2 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+dconjg(a(j,l))*b(i,j,k) - enddo - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim4 - c(1,l,k)=dconjg(a(1,l))*b(1,1,k) - enddo - enddo - do k=1,dim3 - do l=1,dim4 - do j=2,dim2 - c(1,l,k)=c(1,l,k)+dconjg(a(j,l))*b(1,j,k) - enddo - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do l=1,dim4 - do i=1,dim1 - c(i,l,1)=dconjg(a(1,l))*b(i,1,1) - enddo - enddo - do l=1,dim4 - do j=2,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+dconjg(a(j,l))*b(i,j,1) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do l=1,dim4 - c(1,l,1)=dconjg(a(1,l))*b(1,1,1) - enddo - do l=1,dim4 - do j=2,dim2 - c(1,l,1)=c(1,l,1)+dconjg(a(j,l))*b(1,j,1) - enddo - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine qtxxdd -! -! Multiplication of a real quadratic matrix with a real tensor -! of third order: -! a(l,j)*b(i,j,k) = c(i,l,k) . -! -! Input-variables: a - real matrix -! b - real tensor of third order -! Output-variables: c - resulting real tensor -!----------------------------------------------------------------------- - - subroutine qtxxdd (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1, dim2, & - dim3 - real(dop), dimension(dim2,dim2), intent(in) :: a - real(dop), dimension(dim1,dim2,dim3), intent(in) :: b - real(dop), dimension(dim1,dim2,dim3), intent(out) :: c - - if (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim2 - do i=1,dim1 - c(i,l,k)=a(l,1)*b(i,1,k) - enddo - enddo - enddo - do k=1,dim3 - do j=2,dim2 - do l=1,dim2 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+a(l,j)*b(i,j,k) - enddo - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim2 - c(1,l,k)=a(l,1)*b(1,1,k) - enddo - enddo - do k=1,dim3 - do j=2,dim2 - do l=1,dim2 - c(1,l,k)=c(1,l,k)+a(l,j)*b(1,j,k) - enddo - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do l=1,dim2 - do i=1,dim1 - c(i,l,1)=a(l,1)*b(i,1,1) - enddo - enddo - do j=2,dim2 - do l=1,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+a(l,j)*b(i,j,1) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do l=1,dim2 - c(1,l,1)=a(l,1)*b(1,1,1) - enddo - do j=2,dim2 - do l=1,dim2 - c(1,l,1)=c(1,l,1)+a(l,j)*b(1,j,1) - enddo - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine qtcxzz - -! Multiplication of the complex conjugate of a complex quadratic matrix -! with a complex tensor of third order: -! dconjg(a(l,j))*b(i,j,k) = c(i,l,k) . - -! Input-variables: a - complex matrix -! b - complex tensor of third order -! Output-variables: c - resulting complex tensor -!----------------------------------------------------------------------- - - subroutine qtcxzz (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1, dim2, & - dim3 - complex(dop), dimension(dim2,dim2), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c - - if (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim2 - do i=1,dim1 - c(i,l,k)=dconjg(a(l,1))*b(i,1,k) - enddo - enddo - enddo - do k=1,dim3 - do j=2,dim2 - do l=1,dim2 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+dconjg(a(l,j))*b(i,j,k) - enddo - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim2 - c(1,l,k)=dconjg(a(l,1))*b(1,1,k) - enddo - enddo - do k=1,dim3 - do j=2,dim2 - do l=1,dim2 - c(1,l,k)=c(1,l,k)+dconjg(a(l,j))*b(1,j,k) - enddo - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do l=1,dim2 - do i=1,dim1 - c(i,l,1)=dconjg(a(l,1))*b(i,1,1) - enddo - enddo - do j=2,dim2 - do l=1,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+dconjg(a(l,j))*b(i,j,1) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do l=1,dim2 - c(1,l,1)=dconjg(a(l,1))*b(1,1,1) - enddo - do j=2,dim2 - do l=1,dim2 - c(1,l,1)=c(1,l,1)+dconjg(a(l,j))*b(1,j,1) - enddo - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine qttxdd -! -! Multiplication of a transposed real quadratic matrix with a -! real tensor of third order: -! a(j,l)*b(i,j,k) = c(i,l,k). -! -! Input-variables: a - real matrix -! b - real tensor of third order -! Output-variables: c - resulting real tensor -!----------------------------------------------------------------------- - - subroutine qttxdd (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1, dim2, & - dim3 - real(dop), dimension(dim2,dim2), intent(in) :: a - real(dop), dimension(dim1,dim2,dim3), intent(in) :: b - real(dop), dimension(dim1,dim2,dim3), intent(out) :: c - - If (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim2 - do i=1,dim1 - c(i,l,k)=a(1,l)*b(i,1,k) - enddo - enddo - enddo - do k=1,dim3 - do l=1,dim2 - do j=2,dim2 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+a(j,l)*b(i,j,k) - enddo - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim2 - c(1,l,k)=a(1,l)*b(1,1,k) - enddo - enddo - do k=1,dim3 - do l=1,dim2 - do j=2,dim2 - c(1,l,k)=c(1,l,k)+a(j,l)*b(1,j,k) - enddo - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do l=1,dim2 - do i=1,dim1 - c(i,l,1)=a(1,l)*b(i,1,1) - enddo - enddo - do l=1,dim2 - do j=2,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+a(j,l)*b(i,j,1) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do l=1,dim2 - c(1,l,1)=a(1,l)*b(1,1,1) - enddo - do l=1,dim2 - do j=2,dim2 - c(1,l,1)=c(1,l,1)+a(j,l)*b(1,j,1) - enddo - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine dtxxzz -! -! Multiplication of a complex diagonal matrix with a complex tensor -! of third order. Only diagonal matrix elements are given as a vector: -! a(j)*b(i,j,k) = c(i,j,k) . -! -! Input-variables: a - complex vector with diagonal matrix elements -! b - complex tensor of third order -! Output-variables: c - resulting complex tensor -!----------------------------------------------------------------------- - - subroutine dtxxzz (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2, & - dim3 - complex(dop), dimension(dim2), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c - - if (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - do i=1,dim1 - c(i,j,k)=a(j)*b(i,j,k) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - c(1,j,k)=a(j)*b(1,j,k) - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do j=1,dim2 - do i=1,dim1 - c(i,j,1)=a(j)*b(i,j,1) - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do j=1,dim2 - c(1,j,1)=a(j)*b(1,j,1) - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine dtxxzzo -! -! Multiplication of a complex diagonal matrix with a complex tensor -! of third order. Only diagonal matrix elements are given as a vector, -! and the result is stored in the input tensor: -! a(j)*b(i,j,k) = b(i,j,k) . -! -! Input-variables: a - complex vector with diagonal matrix elements -! b - complex tensor of third order -! Output-variables: b - resulting complex tensor -!----------------------------------------------------------------------- - - subroutine dtxxzzo (a,b,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2, & - dim3 - complex(dop), dimension(dim2), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(inout) :: b - - if (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - do i=1,dim1 - b(i,j,k)=a(j)*b(i,j,k) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - b(1,j,k)=a(j)*b(1,j,k) - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do j=1,dim2 - do i=1,dim1 - b(i,j,1)=a(j)*b(i,j,1) - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do j=1,dim2 - b(1,j,1)=a(j)*b(1,j,1) - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine dtxxzzr -! -! Multiplication of a complex diagonal matrix with a complex tensor -! of third order and subtracted from a different tensor: -! c(i,l,k) - a(j)*b(i,j,k) = c(i,l,k). -! -! Input-variables: a - complex vector with diagonal matrix elements -! b - complex tensor of third order -! c - complex tensor of third order -! Output-variables: c - resulting complex tensor -!----------------------------------------------------------------------- - - subroutine dtxxzzr (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2, & - dim3 - complex(dop), dimension(dim2), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c - - if (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - do i=1,dim1 - c(i,j,k)=c(i,j,k)-a(j)*b(i,j,k) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - c(1,j,k)=c(1,j,k)-a(j)*b(1,j,k) - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do j=1,dim2 - do i=1,dim1 - c(i,j,1)=c(i,j,1)-a(j)*b(i,j,1) - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do j=1,dim2 - c(1,j,1)=c(1,j,1)-a(j)*b(1,j,1) - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine dtxxdd -! -! Multiplication of a real diagonal matrix with a real tensor -! of third order. Only diagonal matrix elements are given as a vector: -! a(j)*b(i,j,k) = c(i,j,k) . -! -! Input-variables: a - real vector with diagonal matrix elements -! b - real tensor of third order -! Output-variables: c - resulting real tensor -!----------------------------------------------------------------------- - - subroutine dtxxdd (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2, & - dim3 - real(dop), dimension(dim2), intent(in) :: a - real(dop), dimension(dim1,dim2,dim3), intent(in) :: b - real(dop), dimension(dim1,dim2,dim3), intent(out) :: c - - if (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - do i=1,dim1 - c(i,j,k)=a(j)*b(i,j,k) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - c(1,j,k)=a(j)*b(1,j,k) - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do j=1,dim2 - do i=1,dim1 - c(i,j,1)=a(j)*b(i,j,1) - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do j=1,dim2 - c(1,j,1)=a(j)*b(1,j,1) - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine dtxxddo -! -! Multiplication of a real diagonal matrix with a real tensor -! of third order. Only diagonal matrix elements are given as a vector, -! and the result is stored in the input tensor: -! a(j)*b(i,j,k) = b(i,j,k) . -! -! Input-variables: a - real vector with diagonal matrix elements -! b - real tensor of third order -! Output-variables: b - resulting real tensor -!----------------------------------------------------------------------- - - subroutine dtxxddo (a,b,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2, & - dim3 - real(dop), dimension(dim2), intent(in) :: a - real(dop), dimension(dim1,dim2,dim3), intent(out) :: b - - if (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - do i=1,dim1 - b(i,j,k)=a(j)*b(i,j,k) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - b(1,j,k)=a(j)*b(1,j,k) - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do j=1,dim2 - do i=1,dim1 - b(i,j,1)=a(j)*b(i,j,1) - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do j=1,dim2 - b(1,j,1)=a(j)*b(1,j,1) - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine dtxxdz -! -! Multiplication of a real diagonal matrix with a complex tensor -! of third order. Only diagonal matrix elements are given as a vector: -! a(j)*b(i,j,k) = c(i,j,k) . -! -! Input-variables: a - real vector with diagonal matrix elements -! b - complex tensor of third order -! Output-variables: c - resulting complex tensor -!----------------------------------------------------------------------- - - subroutine dtxxdz (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2, & - dim3 - real(dop), dimension(dim2), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c - - if (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - do i=1,dim1 - c(i,j,k)=a(j)*b(i,j,k) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - c(1,j,k)=a(j)*b(1,j,k) - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do j=1,dim2 - do i=1,dim1 - c(i,j,1)=a(j)*b(i,j,1) - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do j=1,dim2 - c(1,j,1)=a(j)*b(1,j,1) - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine dtxxdzo -! -! Multiplication of a real diagonal matrix with a complex tensor -! of third order. Only diagonal matrix elements are given as a vector, -! and the result is stored in the input tensor: -! a(j)*b(i,j,k) = b(i,j,k) . -! -! Input-variables: a - complex vector with diagonal matrix elements -! b - complex tensor of third order -! Output-variables: b - resulting complex tensor -!----------------------------------------------------------------------- - - subroutine dtxxdzo (a,b,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2, & - dim3 - real(dop), dimension(dim2), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(out) :: b - - if (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - do i=1,dim1 - b(i,j,k)=a(j)*b(i,j,k) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - b(1,j,k)=a(j)*b(1,j,k) - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do j=1,dim2 - do i=1,dim1 - b(i,j,1)=a(j)*b(i,j,1) - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do j=1,dim2 - b(1,j,1)=a(j)*b(1,j,1) - enddo - endif - - return - end subroutine - - -!----------------------------------------------------------------------- -! Library subroutine qtaxzz -! -! Multiplication of the adjoint of a complex quadratic matrix with a -! complex tensor of third order: -! dconj(a(j,l))*b(i,j,k) = c(i,l,k). -! -! Input-variables: a - complex matrix -! b - complex tensor of third order -! Output-variables: c - resulting complex tensor -!----------------------------------------------------------------------- - - subroutine qtaxzz (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1, dim2, & - dim3 - complex(dop), dimension(dim2,dim2), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c - - If (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim2 - do i=1,dim1 - c(i,l,k)=dconjg(a(1,l))*b(i,1,k) - enddo - enddo - enddo - do k=1,dim3 - do l=1,dim2 - do j=2,dim2 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+dconjg(a(j,l))*b(i,j,k) - enddo - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim2 - c(1,l,k)=dconjg(a(1,l))*b(1,1,k) - enddo - enddo - do k=1,dim3 - do l=1,dim2 - do j=2,dim2 - c(1,l,k)=c(1,l,k)+dconjg(a(j,l))*b(1,j,k) - enddo - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do l=1,dim2 - do i=1,dim1 - c(i,l,1)=dconjg(a(1,l))*b(i,1,1) - enddo - enddo - do l=1,dim2 - do j=2,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+dconjg(a(j,l))*b(i,j,1) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do l=1,dim2 - c(1,l,1)=dconjg(a(1,l))*b(1,1,1) - enddo - do l=1,dim2 - do j=2,dim2 - c(1,l,1)=c(1,l,1)+dconjg(a(j,l))*b(1,j,1) - enddo - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine qtxxdz -! -! Multiplication of a real quadratic matrix with a complex tensor -! of third order: -! a(l,j)*b(i,j,k) = c(i,l,k). -! -! Input-variables: a - real matrix -! b - complex tensor of third order -! Output-variables: c - resulting complex tensor -!----------------------------------------------------------------------- - - subroutine qtxxdz (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1, dim2, & - dim3 - real(dop), dimension(dim2,dim2), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c - - if (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim2 - do i=1,dim1 - c(i,l,k)=a(l,1)*b(i,1,k) - enddo - enddo - enddo - do k=1,dim3 - do j=2,dim2 - do l=1,dim2 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+a(l,j)*b(i,j,k) - enddo - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim2 - c(1,l,k)=a(l,1)*b(1,1,k) - enddo - enddo - do k=1,dim3 - do j=2,dim2 - do l=1,dim2 - c(1,l,k)=c(1,l,k)+a(l,j)*b(1,j,k) - enddo - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do l=1,dim2 - do i=1,dim1 - c(i,l,1)=a(l,1)*b(i,1,1) - enddo - enddo - do j=2,dim2 - do l=1,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+a(l,j)*b(i,j,1) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do l=1,dim2 - c(1,l,1)=a(l,1)*b(1,1,1) - enddo - do j=2,dim2 - do l=1,dim2 - c(1,l,1)=c(1,l,1)+a(l,j)*b(1,j,1) - enddo - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine qtxxdza -! -! Multiplication of a real quadratic matrix with a complex tensor -! of third order: -! a(l,j)*b(i,j,k) + c(i,l,k) = c(i,l,k). -! -! Input-variables: a - real matrix -! b - complex tensor of third order -! Output-variables: c - resulting complex tensor -!----------------------------------------------------------------------- - - subroutine qtxxdza (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1, dim2, & - dim3 - real(dop), dimension(dim2,dim2), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c - - if (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - do l=1,dim2 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+a(l,j)*b(i,j,k) - enddo - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - do l=1,dim2 - c(1,l,k)=c(1,l,k)+a(l,j)*b(1,j,k) - enddo - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do j=1,dim2 - do l=1,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+a(l,j)*b(i,j,1) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do j=1,dim2 - do l=1,dim2 - c(1,l,1)=c(1,l,1)+a(l,j)*b(1,j,1) - enddo - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine qt1xxdz -! -! Multiplication of a real quadratic matrix with the first index of a -! complex tensor of third order: -! a(l,i)*b(i,j,k) = c(l,j,k) . -! -! Input-variables: a - real matrix -! b - complex tensor of third order -! Output-variables: c - resulting complex tensor -!----------------------------------------------------------------------- - - subroutine qt1xxdz (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1, dim2, & - dim3 - real(dop), dimension(dim1,dim1), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c - - if (dim2.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - do l=1,dim1 - c(l,j,k)=a(l,1)*b(1,j,k) - enddo - enddo - enddo - do k=1,dim3 - do j=1,dim2 - do i=2,dim1 - do l=1,dim1 - c(l,j,k)=c(l,j,k)+a(l,i)*b(i,j,k) - enddo - enddo - enddo - enddo - else if (dim2.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim1 - c(l,1,k)=a(l,1)*b(1,1,k) - enddo - enddo - do k=1,dim3 - do i=2,dim1 - do l=1,dim1 - c(l,1,k)=c(l,1,k)+a(l,i)*b(i,1,k) - enddo - enddo - enddo - else if (dim2.ne.1 .and. dim3.eq.1) then - do j=1,dim2 - do l=1,dim1 - c(l,j,1)=a(l,1)*b(1,j,1) - enddo - enddo - do j=1,dim2 - do i=2,dim1 - do l=1,dim1 - c(l,j,1)=c(l,j,1)+a(l,i)*b(i,j,1) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do l=1,dim1 - c(l,1,1)=a(l,1)*b(1,1,1) - enddo - do i=2,dim1 - do l=1,dim1 - c(l,1,1)=c(l,1,1)+a(l,i)*b(i,1,1) - enddo - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine dt1xxzz -! -! Multiplication of a complex diagonal matrix with the first index of a -! complex tensor of third order. Only diagonal matrix elements are -! supplied as vector: -! a(i)*b(i,j,k) = c(i,j,k) . -! -! Input-variables: a - complex matrix -! b - complex tensor of third order -! Output-variables: c - resulting complex tensor -!----------------------------------------------------------------------- - - subroutine dt1xxzz (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2, & - dim3 - complex(dop), dimension(dim1), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c - - - if (dim2.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - do i=1,dim1 - c(i,j,k)=a(i)*b(i,j,k) - enddo - enddo - enddo - else if (dim2.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do i=1,dim1 - c(i,1,k)=a(i)*b(i,1,k) - enddo - enddo - else if (dim2.ne.1 .and. dim3.eq.1) then - do j=1,dim2 - do i=1,dim1 - c(i,j,1)=a(i)*b(i,j,1) - enddo - enddo - else if (dim2.eq.1 .and. dim3.eq.1) then - do i=1,dim1 - c(i,1,1)=a(i)*b(i,1,1) - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine qt1txdz -! -! Multiplication of a transposed real quadratic matrix with the -! first index of a complex tensor of third order: -! a(i,l)*b(i,j,k) = c(l,j,k) . -! -! Input-variables: a - real matrix -! b - complex tensor of third order -! Output-variables: c - resulting complex tensor -!----------------------------------------------------------------------- - - subroutine qt1txdz (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1, dim2, & - dim3 - real(dop), dimension(dim1,dim1), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c - - if (dim2.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - do l=1,dim1 - c(l,j,k)=a(1,l)*b(1,j,k) - enddo - enddo - enddo - do k=1,dim3 - do j=1,dim2 - do l=1,dim1 - do i=2,dim1 - c(l,j,k)=c(l,j,k)+a(i,l)*b(i,j,k) - enddo - enddo - enddo - enddo - else if (dim2.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim1 - c(l,1,k)=a(1,l)*b(1,1,k) - enddo - enddo - do k=1,dim3 - do l=1,dim1 - do i=2,dim1 - c(l,1,k)=c(l,1,k)+a(i,l)*b(i,1,k) - enddo - enddo - enddo - else if (dim2.ne.1 .and. dim3.eq.1) then - do j=1,dim2 - do l=1,dim1 - c(l,j,1)=a(1,l)*b(1,j,1) - enddo - enddo - do j=1,dim2 - do l=1,dim1 - do i=2,dim1 - c(l,j,1)=c(l,j,1)+a(i,l)*b(i,j,1) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do l=1,dim1 - c(l,1,1)=a(1,l)*b(1,1,1) - enddo - do l=1,dim1 - do i=2,dim1 - c(l,1,1)=c(l,1,1)+a(i,l)*b(i,1,1) - enddo - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine qttxdz -! -! Multiplication of a transposed real quadratic matrix with a -! complex tensor of third order: -! a(j,l)*b(i,j,k) = c(i,l,k). -! -! Input-variables: a - real matrix -! b - complex tensor of third order -! Output-variables: c - resulting complex tensor -!----------------------------------------------------------------------- - - subroutine qttxdz (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1, dim2, & - dim3 - real(dop), dimension(dim2,dim2), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c - - If (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim2 - do i=1,dim1 - c(i,l,k)=a(1,l)*b(i,1,k) - enddo - enddo - enddo - do k=1,dim3 - do l=1,dim2 - do j=2,dim2 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+a(j,l)*b(i,j,k) - enddo - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim2 - c(1,l,k)=a(1,l)*b(1,1,k) - enddo - enddo - do k=1,dim3 - do l=1,dim2 - do j=2,dim2 - c(1,l,k)=c(1,l,k)+a(j,l)*b(1,j,k) - enddo - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do l=1,dim2 - do i=1,dim1 - c(i,l,1)=a(1,l)*b(i,1,1) - enddo - enddo - do l=1,dim2 - do j=2,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+a(j,l)*b(i,j,1) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do l=1,dim2 - c(1,l,1)=a(1,l)*b(1,1,1) - enddo - do l=1,dim2 - do j=2,dim2 - c(1,l,1)=c(1,l,1)+a(j,l)*b(1,j,1) - enddo - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine qt1xxzz -! -! Multiplication of a real quadratic matrix with the first index of a -! complex tensor of third order: -! a(l,i)*b(i,j,k) = c(l,j,k) . -! -! Input-variables: a - real matrix -! b - complex tensor of third order -! Output-variables: c - resulting complex tensor -!----------------------------------------------------------------------- - -! subroutine qt1xxzz (a,b,c,dim1,dim2,dim3) - -! implicit none - -! integer(long) :: i, j, k, l -! integer(long), intent(in) :: dim1, dim2, & -! dim3 -! complex(dop), dimension(dim1,dim1), intent(in) :: a -! complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b -! complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c - -! if (dim2.ne.1 .and. dim3.ne.1) then -! do k=1,dim3 -! do j=1,dim2 -! do l=1,dim1 -! c(l,j,k)=a(l,1)*b(1,j,k) -! enddo -! enddo -! enddo -! do k=1,dim3 -! do j=1,dim2 -! do i=2,dim1 -! do l=1,dim1 -! c(l,j,k)=c(l,j,k)+a(l,i)*b(i,j,k) -! enddo -! enddo -! enddo -! enddo -! else if (dim2.eq.1 .and. dim3.ne.1) then -! do k=1,dim3 -! do l=1,dim1 -! c(l,1,k)=a(l,1)*b(1,1,k) -! enddo -! enddo -! do k=1,dim3 -! do i=2,dim1 -! do l=1,dim1 -! c(l,1,k)=c(l,1,k)+a(l,i)*b(i,1,k) -! enddo -! enddo -! enddo -! else if (dim2.ne.1 .and. dim3.eq.1) then -! do j=1,dim2 -! do l=1,dim1 -! c(l,j,1)=a(l,1)*b(1,j,1) -! enddo -! enddo -! do j=1,dim2 -! do i=2,dim1 -! do l=1,dim1 -! c(l,j,1)=c(l,j,1)+a(l,i)*b(i,j,1) -! enddo -! enddo -! enddo -! else if (dim1.eq.1 .and. dim3.eq.1) then -! do l=1,dim1 -! c(l,1,1)=a(l,1)*b(1,1,1) -! enddo -! do i=2,dim1 -! do l=1,dim1 -! c(l,1,1)=c(l,1,1)+a(l,i)*b(i,1,1) -! enddo -! enddo -! endif - -! return -! end subroutine - -!----------------------------------------------------------------------- -! Library subroutine qttxzz -! -! Multiplication of a transposed complex quadratic matrix with a -! complex tensor of third order: -! a(j,l)*b(i,j,k) = c(i,l,k). -! -! Input-variables: a - real matrix -! b - real tensor of third order -! Output-variables: c - resulting real tensor -!----------------------------------------------------------------------- - - subroutine qttxzz (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1, dim2, & - dim3 - complex(dop), dimension(dim2,dim2), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c - - If (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim2 - do i=1,dim1 - c(i,l,k)=a(1,l)*b(i,1,k) - enddo - enddo - enddo - do k=1,dim3 - do l=1,dim2 - do j=2,dim2 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+a(j,l)*b(i,j,k) - enddo - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim2 - c(1,l,k)=a(1,l)*b(1,1,k) - enddo - enddo - do k=1,dim3 - do l=1,dim2 - do j=2,dim2 - c(1,l,k)=c(1,l,k)+a(j,l)*b(1,j,k) - enddo - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do l=1,dim2 - do i=1,dim1 - c(i,l,1)=a(1,l)*b(i,1,1) - enddo - enddo - do l=1,dim2 - do j=2,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+a(j,l)*b(i,j,1) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do l=1,dim2 - c(1,l,1)=a(1,l)*b(1,1,1) - enddo - do l=1,dim2 - do j=2,dim2 - c(1,l,1)=c(1,l,1)+a(j,l)*b(1,j,1) - enddo - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine qtxxyz -! -! Multiplication of a complex quadratic matrix with a complex tensor -! of third order, where the complex matrix is stored as two real -! matrices: -! a(l,j)*b(i,j,k) = c(i,l,k). -! -! Input-variables: a - complex matrix -! b - complex tensor of third order -! Output-variables: c - resulting complex tensor -!----------------------------------------------------------------------- - - subroutine qtxxyz (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1, dim2, & - dim3 - real(dop), dimension(dim2,dim2,2), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c - - if (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim2 - do i=1,dim1 - c(i,l,k)=dcmplx(a(l,1,1),a(l,1,2))*b(i,1,k) - enddo - enddo - enddo - do k=1,dim3 - do j=2,dim2 - do l=1,dim2 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+dcmplx(a(l,j,1),a(l,j,2))*b(i,j,k) - enddo - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim2 - c(1,l,k)=dcmplx(a(l,1,1),a(l,1,2))*b(1,1,k) - enddo - enddo - do k=1,dim3 - do j=2,dim2 - do l=1,dim2 - c(1,l,k)=c(1,l,k)+dcmplx(a(l,j,1),a(l,j,2))*b(1,j,k) - enddo - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do l=1,dim2 - do i=1,dim1 - c(i,l,1)=dcmplx(a(l,1,1),a(l,1,2))*b(i,1,1) - enddo - enddo - do j=2,dim2 - do l=1,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+dcmplx(a(l,j,1),a(l,j,2))*b(i,j,1) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do l=1,dim2 - c(1,l,1)=dcmplx(a(l,1,1),a(l,1,2))*b(1,1,1) - enddo - do j=2,dim2 - do l=1,dim2 - c(1,l,1)=c(1,l,1)+dcmplx(a(l,j,1),a(l,j,2))*b(1,j,1) - enddo - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine qttxyz -! -! Multiplication of the trabspose of a complex quadratic matrix with -! a complex tensor of third order, where the complex matrix is stored -! as two real matrices: -! a(j,l)*b(i,j,k) = c(i,l,k). -! -! Input-variables: a - complex matrix -! b - complex tensor of third order -! Output-variables: c - resulting complex tensor -!----------------------------------------------------------------------- - - subroutine qttxyz (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k, l - integer(long), intent(in) :: dim1, dim2, & - dim3 - real(dop), dimension(dim2,dim2,2), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c - - if (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim2 - do i=1,dim1 - c(i,l,k)=dcmplx(a(1,l,1),a(1,l,2))*b(i,1,k) - enddo - enddo - enddo - do k=1,dim3 - do j=2,dim2 - do l=1,dim2 - do i=1,dim1 - c(i,l,k)=c(i,l,k)+dcmplx(a(j,l,1),a(j,l,2))*b(i,j,k) - enddo - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do l=1,dim2 - c(1,l,k)=dcmplx(a(1,l,1),a(1,l,2))*b(1,1,k) - enddo - enddo - do k=1,dim3 - do j=2,dim2 - do l=1,dim2 - c(1,l,k)=c(1,l,k)+dcmplx(a(j,l,1),a(j,l,2))*b(1,j,k) - enddo - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do l=1,dim2 - do i=1,dim1 - c(i,l,1)=dcmplx(a(1,l,1),a(1,l,2))*b(i,1,1) - enddo - enddo - do j=2,dim2 - do l=1,dim2 - do i=1,dim1 - c(i,l,1)=c(i,l,1)+dcmplx(a(j,l,1),a(j,l,2))*b(i,j,1) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do l=1,dim2 - c(1,l,1)=dcmplx(a(1,l,1),a(1,l,2))*b(1,1,1) - enddo - do j=2,dim2 - do l=1,dim2 - c(1,l,1)=c(1,l,1)+dcmplx(a(j,l,1),a(j,l,2))*b(1,j,1) - enddo - enddo - endif - - return - end subroutine - - -!----------------------------------------------------------------------- -! Library subroutine dtxxyz -! -! Multiplication of a complex quadratic diagonal matrix with a complex -! tensor of third order, where the complex matrix is stored as two real -! matrices: -! a(j)*b(i,j,k) = c(i,l,k). -! -! Input-variables: a - complex matrix -! b - complex tensor of third order -! Output-variables: c - resulting complex tensor -!----------------------------------------------------------------------- - - subroutine dtxxyz (a,b,c,dim1,dim2,dim3) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1, dim2, & - dim3 - real(dop), dimension(dim2,2), intent(in) :: a - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c - - if (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - do i=1,dim1 - c(i,j,k)=dcmplx(a(j,1),a(j,2))*b(i,j,k) - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - c(1,j,k)=dcmplx(a(j,1),a(j,2))*b(1,j,k) - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do j=1,dim2 - do i=1,dim1 - c(i,j,1)=dcmplx(a(j,1),a(j,2))*b(i,j,1) - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do j=1,dim2 - c(1,j,1)=dcmplx(a(j,1),a(j,2))*b(1,j,1) - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine qtxxzz_s -! -! Multiplication of a complex quadratic matrix with a complex tensor -! of third order. The tensor is not completely stored, and the indices -! are managed by the index tensors: -! index(i,j,k)=x -! index1(i,l,k)=x1 -! a(l,j)*b(x) = c(x1). -! -! Input-variables: a - complex matrix -! b - complex tensor of third order -! Output-variables: c - resulting complex tensor -!----------------------------------------------------------------------- - - subroutine qtxxzz_s (a,b,c,dim1,dim2,dim3,index,index1) - - implicit none - - integer(long) :: i, j, k, l, & - x, x1 - integer(long), intent(in) :: dim1, dim2, & - dim3 - integer(long), dimension(dim1,dim2,dim3), intent(in) :: index - integer(long), dimension(dim1,dim2,dim3), intent(in) :: index1 - complex(dop), dimension(dim2,dim2), intent(in) :: a - complex(dop), dimension(*), intent(in) :: b - complex(dop), dimension(*), intent(out) :: c - - do k=1,dim3 - do l=1,dim2 - do i=1,dim1 - x1=index1(i,l,k) - if (x1 .ne. 0) c(x1)=0.0d0 - enddo - enddo - enddo - - if (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - do l=1,dim2 - do i=1,dim1 - x=index(i,j,k) - x1=index1(i,l,k) - if (x .ne. 0 .and. x1 .ne. 0) then - c(x1)=c(x1)+a(l,j)*b(x) - endif - enddo - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - do l=1,dim2 - x=index(1,j,k) - x1=index1(1,l,k) - if (x .ne. 0 .and. x1 .ne. 0) then - c(x1)=c(x1)+a(l,j)*b(x) - endif - enddo - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do j=1,dim2 - do l=1,dim2 - do i=1,dim1 - x=index(i,j,1) - x1=index1(i,l,1) - if (x .ne. 0 .and. x1 .ne. 0) then - c(x1)=c(x1)+a(l,j)*b(x) - endif - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do j=1,dim2 - do l=1,dim2 - x=index(1,j,1) - x1=index1(1,l,1) - if (x .ne. 0 .and. x1 .ne. 0) then - c(x1)=c(x1)+a(l,j)*b(x) - endif - enddo - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine mtxxzz_s -! -! Multiplication of a complex matrix with a complex tensor -! of third order. The tensor is not completely stored, and the indices -! are managed by the index tensors: -! index(i,j,k)=x -! index1(i,l,k)=x1 -! a(l,j)*b(x) = c(x1). -! -! Input-variables: a - complex matrix -! b - complex tensor of third order -! Output-variables: c - resulting complex tensor -!----------------------------------------------------------------------- - - subroutine mtxxzz_s (a,b,c,dim1,dim2,dim3,dim4,dim5,index,index1) - - implicit none - - integer(long) :: i, j, k, l, & - x, x1 - integer(long), intent(in) :: dim1, dim2, & - dim3, dim4, & - dim5 - integer(long), dimension(dim1,dim2,dim3), intent(in) :: index - integer(long), dimension(dim1,dim2,dim3), intent(in) :: index1 - complex(dop), dimension(dim5,dim4), intent(in) :: a - complex(dop), dimension(*), intent(in) :: b - complex(dop), dimension(*), intent(out) :: c - - do k=1,dim3 - do l=1,dim2 - do i=1,dim1 - x1=index1(i,l,k) - if (x1 .ne. 0) c(x1)=0.0d0 - enddo - enddo - enddo - - if (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim4 - do l=1,dim5 - do i=1,dim1 - x=index(i,j,k) - x1=index1(i,l,k) - if (x .ne. 0 .and. x1 .ne. 0) then - c(x1)=c(x1)+a(l,j)*b(x) - endif - enddo - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim4 - do l=1,dim5 - x=index(1,j,k) - x1=index1(1,l,k) - if (x .ne. 0 .and. x1 .ne. 0) then - c(x1)=c(x1)+a(l,j)*b(x) - endif - enddo - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do j=1,dim4 - do l=1,dim5 - do i=1,dim1 - x=index(i,j,1) - x1=index1(i,l,1) - if (x .ne. 0 .and. x1 .ne. 0) then - c(x1)=c(x1)+a(l,j)*b(x) - endif - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do j=1,dim4 - do l=1,dim5 - x=index(1,j,1) - x1=index1(1,l,1) - if (x .ne. 0 .and. x1 .ne. 0) then - c(x1)=c(x1)+a(l,j)*b(x) - endif - enddo - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine qttxzz_s -! -! Multiplication of a transposed complex quadratic matrix with a -! complex tensor c of third order. The tensor is not completely stored, -! and the indices are managed by the index tensors: -! index(i,j,k)=x -! index1(i,l,k)=x1 -! a(j,l)*b(x) = c(x1). -! -! Input-variables: a - complex matrix -! b - complex tensor of third order -! Output-variables: c - resulting complex tensor -!----------------------------------------------------------------------- - - subroutine qttxzz_s (a,b,c,dim1,dim2,dim3,index,index1) - - implicit none - - integer(long) :: i, j, k, l, & - x, x1 - integer(long), intent(in) :: dim1, dim2, & - dim3 - integer(long), dimension(dim1,dim2,dim3), intent(in) :: index - integer(long), dimension(dim1,dim2,dim3), intent(in) :: index1 - complex(dop), dimension(dim2,dim2), intent(in) :: a - complex(dop), dimension(*), intent(in) :: b - complex(dop), dimension(*), intent(out) :: c - - do k=1,dim3 - do l=1,dim2 - do i=1,dim1 - x1=index1(i,l,k) - if (x1 .ne. 0) c(x1)=0.0d0 - enddo - enddo - enddo - - if (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - do l=1,dim2 - do i=1,dim1 - x=index(i,j,k) - x1=index1(i,l,k) - if (x .ne. 0 .and. x1 .ne. 0) then - c(x1)=c(x1)+a(j,l)*b(x) - endif - enddo - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - do l=1,dim2 - x=index(1,j,k) - x1=index1(1,l,k) - if (x .ne. 0 .and. x1 .ne. 0) then - c(x1)=c(x1)+a(j,l)*b(x) - endif - enddo - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do j=1,dim2 - do l=1,dim2 - do i=1,dim1 - x=index(i,j,1) - x1=index1(i,l,1) - if (x .ne. 0 .and. x1 .ne. 0) then - c(x1)=c(x1)+a(j,l)*b(x) - endif - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do j=1,dim2 - do l=1,dim2 - x=index(1,j,1) - x1=index1(1,l,1) - if (x .ne. 0 .and. x1 .ne. 0) then - c(x1)=c(x1)+a(j,l)*b(x) - endif - enddo - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine qtxxzza_s -! -! Multiplication of a complex quadratic matrix with a complex tensor -! of third order and added to a different tensor. The tensors are not -! completely stored, and the indices are managed by the index tensors: -! index(i,j,k)=x -! index1(i,l,k)=x1 -! a(l,j)*b(x) + c(x1) = c(x1). -! -! Input-variables: a - complex matrix -! b - complex tensor of third order -! Output-variables: c - resulting complex tensor -! -! NB tensor c is overwritten on output -!----------------------------------------------------------------------- - - subroutine qtxxzza_s (a,b,c,dim1,dim2,dim3,index,index1) - - implicit none - - integer(long) :: i, j, k, l, & - x, x1 - integer(long), intent(in) :: dim1, dim2, & - dim3 - integer(long), dimension(dim1,dim2,dim3), intent(in) :: index - integer(long), dimension(dim1,dim2,dim3), intent(in) :: index1 - complex(dop), dimension(dim2,dim2), intent(in) :: a - complex(dop), dimension(*), intent(in) :: b - complex(dop), dimension(*), intent(out) :: c - - if (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - do l=1,dim2 - do i=1,dim1 - x=index(i,j,k) - x1=index1(i,l,k) - if (x .ne. 0 .and. x1 .ne. 0) then - c(x1)=c(x1)+a(l,j)*b(x) - endif - enddo - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - do l=1,dim2 - x=index(1,j,k) - x1=index1(1,l,k) - if (x .ne. 0 .and. x1 .ne. 0) then - c(x1)=c(x1)+a(l,j)*b(x) - endif - enddo - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do j=1,dim2 - do l=1,dim2 - do i=1,dim1 - x=index(i,j,1) - x1=index1(i,l,1) - if (x .ne. 0 .and. x1 .ne. 0) then - c(x1)=c(x1)+a(l,j)*b(x) - endif - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do j=1,dim2 - do l=1,dim2 - x=index(1,j,1) - x1=index1(1,l,1) - if (x .ne. 0 .and. x1 .ne. 0) then - c(x1)=c(x1)+a(l,j)*b(x) - endif - enddo - enddo - endif - - return - end subroutine - -!----------------------------------------------------------------------- -! Library subroutine qtxxzzr_s -! -! Multiplication of a complex quadratic matrix with a complex tensor -! of third order and subtracted from a different tensor. The tensors are -! not completely stored, and the indices are managed by the index tensors: -! index(i,j,k)=x -! index1(i,l,k)=x1 -! c(x1) - a(l,j)*b(x) = c(x1). -! -! Input-variables: a - complex matrix -! b - complex tensor of third order -! Output-variables: c - resulting complex tensor -! -! NB tensor c is overwritten on output -!----------------------------------------------------------------------- - - subroutine qtxxzzr_s (a,b,c,dim1,dim2,dim3,index,index1) - - implicit none - - integer(long) :: i, j, k, l, & - x, x1 - integer(long), intent(in) :: dim1, dim2, & - dim3 - integer(long), dimension(dim1,dim2,dim3), intent(in) :: index - integer(long), dimension(dim1,dim2,dim3), intent(in) :: index1 - complex(dop), dimension(dim2,dim2), intent(in) :: a - complex(dop), dimension(*), intent(in) :: b - complex(dop), dimension(*), intent(out) :: c - - if (dim1.ne.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - do l=1,dim2 - do i=1,dim1 - x=index(i,j,k) - x1=index1(i,l,k) - if (x .ne. 0 .and. x1 .ne. 0) then - c(x1)=c(x1)-a(l,j)*b(x) - endif - enddo - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.ne.1) then - do k=1,dim3 - do j=1,dim2 - do l=1,dim2 - x=index(1,j,k) - x1=index1(1,l,k) - if (x .ne. 0 .and. x1 .ne. 0) then - c(x1)=c(x1)-a(l,j)*b(x) - endif - enddo - enddo - enddo - else if (dim1.ne.1 .and. dim3.eq.1) then - do j=1,dim2 - do l=1,dim2 - do i=1,dim1 - x=index(i,j,1) - x1=index1(i,l,1) - if (x .ne. 0 .and. x1 .ne. 0) then - c(x1)=c(x1)-a(l,j)*b(x) - endif - enddo - enddo - enddo - else if (dim1.eq.1 .and. dim3.eq.1) then - do j=1,dim2 - do l=1,dim2 - x=index(1,j,1) - x1=index1(1,l,1) - if (x .ne. 0 .and. x1 .ne. 0) then - c(x1)=c(x1)-a(l,j)*b(x) - endif - enddo - enddo - endif - - return - end subroutine - - end module mtlib - - - - Index: source/lib/linear/mmomplib.f90 =================================================================== --- source/lib/linear/mmomplib.f90 (revision 854) +++ source/lib/linear/mmomplib.f90 (revision 855) @@ -1,350 +0,0 @@ -!---------------------------------------------------------------------- -! OpenMP generalisations of routines in the mmlib module. -! GWR 9/13 -!---------------------------------------------------------------------- - module mmomplib - -use decimal, only: dop, long, sip - - implicit none - private - public :: mmxtzzaomp,mmxtzzomp,mqxtzzomp,mmxxzzomp,mmxxzzaomp, & - mmaxzzomp,qqxxzzomp,mqxxzzomp - - contains -!----------------------------------------------------------------------- -! Library subroutine mmxtzzaomp -! -! Multiplication of a complex rectangular matrix with the transpose of -! a rectangular complex matrix -! a(j,k)*b(i,k) + c(j,i) = c(j,i) -!----------------------------------------------------------------------- - - subroutine mmxtzzaomp (a,b,c,dim1,dim2,dim3,ompthread) - - implicit none - - logical(kind=4) :: lord - integer(long) :: i, j, k - integer(long), intent(in) :: dim1,dim2,dim3,& - ompthread - complex(dop), dimension(dim1,dim2), intent(in) :: a - complex(dop), dimension(dim3,dim2), intent(in) :: b - complex(dop), dimension(dim1,dim3), intent(inout) :: c - - - lord = dim3.ge.dim1 - -!$omp parallel num_threads(ompthread) private(i,j,k) - if(lord)then -!$omp do - do i = 1,dim3 - do k = 1,dim2 - do j = 1,dim1 - c(j,i) = c(j,i)+a(j,k)*b(i,k) - enddo - enddo - enddo -!$omp end do - else -!$omp do - do j = 1,dim1 - do k = 1,dim2 - do i = 1,dim3 - c(j,i) = c(j,i)+a(j,k)*b(i,k) - enddo - enddo - enddo -!$omp end do - endif -!$omp end parallel - - return - end subroutine mmxtzzaomp - -!----------------------------------------------------------------------- -! Library subroutine mmxtzzomp -! -! Multiplication of a complex rectangular matrix with the transpose of -! a rectangular complex matrix -! a(j,k)*b(i,k) = c(j,i) -!----------------------------------------------------------------------- - - subroutine mmxtzzomp (a,b,c,dim1,dim2,dim3,ompthread) - - implicit none - - logical(kind=4) :: lord - integer(long) :: i, j, k - integer(long), intent(in) :: dim1,dim2,dim3,& - ompthread - complex(dop), dimension(dim1,dim2), intent(in) :: a - complex(dop), dimension(dim3,dim2), intent(in) :: b - complex(dop), dimension(dim1,dim3), intent(inout) :: c - - -! Initialise c - c = (0.0_dop,0.0_dop) - -! What's the better order? - lord = dim3.ge.dim1 - -!$omp parallel num_threads(ompthread) private(i,j,k) - if(lord)then -!$omp do - do i = 1,dim3 - do k = 1,dim2 - do j = 1,dim1 - c(j,i) = c(j,i)+a(j,k)*b(i,k) - enddo - enddo - enddo -!$omp end do - else -!$omp do - do j = 1,dim1 - do k = 1,dim2 - do i = 1,dim3 - c(j,i) = c(j,i)+a(j,k)*b(i,k) - enddo - enddo - enddo -!$omp end do - endif -!$omp end parallel - - return - end subroutine mmxtzzomp - -!----------------------------------------------------------------------- -! Library subroutine mqxtzz -! -! Multiplication of a complex rectangular matrix with the transpose of -! a quadratic complex matrix: -! a(j,k)*b(i,k) = c(j,i) -!----------------------------------------------------------------------- - - subroutine mqxtzzomp (a,b,c,dim1,dim2,ompthread) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1,dim2,ompthread - complex(dop), dimension(dim1,dim2), intent(in) :: a - complex(dop), dimension(dim2,dim2), intent(in) :: b - complex(dop), dimension(dim1,dim2), intent(out) :: c - -!$omp parallel num_threads(ompthread) private(i,j,k) -!$omp do - do i = 1,dim2 - do j = 1,dim1 - c(j,i) = a(j,1)*b(i,1) - enddo - enddo -!$omp end do -!$omp do - do i = 1,dim2 - do k = 2,dim2 - do j = 1,dim1 - c(j,i) = c(j,i)+a(j,k)*b(i,k) - enddo - enddo - enddo -!$omp end do -!$omp end parallel - - return - end subroutine mqxtzzomp - -!----------------------------------------------------------------------- -! Library subroutine mmxxzzomp -! -! Multiplication of two complex rectangular matrices: -! a(j,k)*b(k,i) = c(j,i) -!----------------------------------------------------------------------- - - subroutine mmxxzzomp (a,b,c,dim1,dim2,dim3,ompthread) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1,dim2,dim3,& - ompthread - complex(dop), dimension(dim1,dim2), intent(in) :: a - complex(dop), dimension(dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim3), intent(out) :: c - -!$omp parallel num_threads(ompthread) private(i,j,k) -!$omp do - do i=1,dim3 - do j=1,dim1 - c(j,i) = a(j,1)*b(1,i) - enddo - enddo -!$omp end do -!$omp do - do i = 1,dim3 - do k = 2,dim2 - do j = 1,dim1 - c(j,i) = c(j,i)+a(j,k)*b(k,i) - enddo - enddo - enddo -!$omp end do -!$omp end parallel - - return - end subroutine mmxxzzomp - -!----------------------------------------------------------------------- -! Library subroutine mmxxzzaomp -! -! Multiplication of a complex rectangular matrix with a rectangular -! complex matrix, the result of which is added to a further matrix. -! a(j,k)*b(k,i) +c(j,i) = c(j,i) -!----------------------------------------------------------------------- - - subroutine mmxxzzaomp (a,b,c,dim1,dim2,dim3,ompthread) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1,dim2,dim3,& - ompthread - complex(dop), dimension(dim1,dim2), intent(in) :: a - complex(dop), dimension(dim2,dim3), intent(in) :: b - complex(dop), dimension(dim1,dim3), intent(out) :: c - -!$omp parallel do num_threads(ompthread) private(i,j,k) - do i = 1,dim3 - do k = 1,dim2 - do j = 1,dim1 - c(j,i) = c(j,i)+a(j,k)*b(k,i) - enddo - enddo - enddo -!$omp end parallel do - - return - end subroutine mmxxzzaomp - -!----------------------------------------------------------------------- -! Library subroutine mmaxzzomp -! -! Multiplication of the adjoint of a complex rectangular matrix with -! a rectangular complex matrix -! dconjg(a(k,j))*b(k,i) = c(j,i) -! -! NB this routine can be used for the overlap of two sets of vectors in -! different spf bases -!----------------------------------------------------------------------- - - subroutine mmaxzzomp (a,b,c,dim1,dim2,dim3,ompthread) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1,dim2, & - dim3,ompthread - complex(dop), dimension(dim1,dim2), intent(in) :: a - complex(dop), dimension(dim1,dim3), intent(in) :: b - complex(dop), dimension(dim2,dim3), intent(out) :: c - -!$omp parallel do num_threads(ompthread) private(i,j,k) - do i = 1,dim3 - do j = 1,dim2 - c(j,i) = dconjg(a(1,j))*b(1,i) - do k = 2,dim1 - c(j,i) = c(j,i)+dconjg(a(k,j))*b(k,i) - enddo - enddo - enddo -!$omp end parallel do - - return - end subroutine mmaxzzomp - -!----------------------------------------------------------------------- -! Library subroutine qqxxzzomp -! -! Multiplication of two complex quadratic matrices: -! a(j,k)*b(k,i) = c(j,i) -!----------------------------------------------------------------------- - - subroutine qqxxzzomp (a,b,c,dim,ompthread) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim,ompthread - complex(dop), dimension(dim,dim), intent(in) :: a - complex(dop), dimension(dim,dim), intent(in) :: b - complex(dop), dimension(dim,dim), intent(out) :: c - -!$omp parallel num_threads(ompthread) private(i,j,k) -!$omp do - do i=1,dim - do j=1,dim - c(j,i) = a(j,1)*b(1,i) - enddo - enddo -!$omp end do -!$omp do - do i = 1,dim - do k = 2,dim - do j = 1,dim - c(j,i) = c(j,i)+a(j,k)*b(k,i) - enddo - enddo - enddo -!$omp end do -!$omp end parallel - - return - end subroutine qqxxzzomp - -!----------------------------------------------------------------------- -! Library subroutine mqxxzzomp -! -! Multiplication of a complex rectangular matrix with a quadratic -! complex matrix: -! a(j,k)*b(k,i) = c(j,i) -!----------------------------------------------------------------------- - - subroutine mqxxzzomp (a,b,c,dim1,dim2,ompthread) - - implicit none - - integer(long) :: i, j, k - integer(long), intent(in) :: dim1,dim2,ompthread - complex(dop), dimension(dim1,dim2), intent(in) :: a - complex(dop), dimension(dim2,dim2), intent(in) :: b - complex(dop), dimension(dim1,dim2), intent(out) :: c - -!$omp parallel num_threads(ompthread) private(i,j,k) -!$omp do - do i = 1,dim2 - do j = 1,dim1 - c(j,i) = a(j,1)*b(1,i) - enddo - enddo -!$omp end do -!$omp do - do i = 1,dim2 - do k = 2,dim2 - do j = 1,dim1 - c(j,i) = c(j,i)+a(j,k)*b(k,i) - enddo - enddo - enddo -!$omp end do -!$omp end parallel - - return - end subroutine mqxxzzomp - - end module mmomplib - - - - Index: source/lib/linear/rmomplib.f90 =================================================================== --- source/lib/linear/rmomplib.f90 (revision 854) +++ source/lib/linear/rmomplib.f90 (revision 855) @@ -1,250 +0,0 @@ - -!---------------------------------------------------------------------- -! OpenMP generalisations of routines in the rmlib module. -! GWR 9/13 -!---------------------------------------------------------------------- - module rmomplib - -use decimal, only: dop, long, sip - - implicit none - private - public :: rmhxxxzzomp,rmmxxxzzomp,rmmtxxzzomp - - contains -!----------------------------------------------------------------------- -! Library subroutine rmhxxxzzomp -! -! Formation of density type matrix by multiplication of two complex -! tensors of third order, where the matrix formed is hermitian: -! -! dconjg(bra(i,j,k))*ket(i,l,k) = mat(j,l). -! -!----------------------------------------------------------------------- - - subroutine rmhxxxzzomp (bra,ket,mat,dim1,dim2,dim3,ompthread) - - implicit none - - integer(long) :: i, j, & - k, l - integer(long), intent(in) :: dim1,dim2, & - dim3,ompthread - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: bra - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: ket - complex(dop), dimension(dim2,dim2), intent(out) :: mat - - mat=(0.0d0,0.0d0) - -!$omp parallel num_threads(ompthread) private(i,j,k,l) - if (dim1.ne.1 .and. dim3.ne.1) then -!$omp do - do l=1,dim2 - do k=1,dim3 - do j=l,dim2 - do i=1,dim1 - mat(j,l)=mat(j,l)+dconjg(bra(i,j,k))*ket(i,l,k) - enddo - enddo - enddo - enddo -!$omp end do - else if (dim1.eq.1 .and. dim3.ne.1) then -!$omp do - do l=1,dim2 - do k=1,dim3 - do j=l,dim2 - mat(j,l)=mat(j,l)+dconjg(bra(1,j,k))*ket(1,l,k) - enddo - enddo - enddo -!$omp end do - else if (dim1.ne.1 .and. dim3.eq.1) then -!$omp do - do l=1,dim2 - do j=l,dim2 - do i=1,dim1 - mat(j,l)=mat(j,l)+dconjg(bra(i,j,1))*ket(i,l,1) - enddo - enddo - enddo -!$omp end do - else if (dim1.eq.1 .and. dim3.eq.1) then -!$omp do - do l=1,dim2 - do j=l,dim2 - mat(j,l)=mat(j,l)+dconjg(bra(1,j,1))*ket(1,l,1) - enddo - enddo -!$omp end do - endif -! -! now form other half of matrix -! -!$omp do - do l=1,dim2 - mat(l,l)=dble(mat(l,l)) - enddo -!$omp end do -!$omp do - do l=1,dim2 - do j=1,l-1 - mat(j,l)=dconjg(mat(l,j)) - enddo - enddo -!$omp end do -!$omp end parallel - - return - end subroutine rmhxxxzzomp - -!----------------------------------------------------------------------- -! Library subroutine rmmxxxzz -! -! Formation of density type matrix by multiplication of two complex -! tensors of third order: -! -! dconjg(bra(i,j,k))*ket(i,l,k) = mat(j,l). -! -!----------------------------------------------------------------------- - - subroutine rmmxxxzzomp (bra,ket,mat,dim1,dim2,dim3,dim4,ompthread) - - implicit none - - integer(long) :: i, j, & - k, l - integer(long), intent(in) :: dim1,dim2, & - dim3,dim4,& - ompthread - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: bra - complex(dop), dimension(dim1,dim4,dim3), intent(in) :: ket - complex(dop), dimension(dim2,dim4), intent(out) :: mat - - mat=(0.0d0,0.0d0) - -!$omp parallel num_threads(ompthread) private(i,j,k,l) - if (dim1.ne.1 .and. dim3.ne.1) then -!$omp do - do l=1,dim4 - do k=1,dim3 - do j=1,dim2 - do i=1,dim1 - mat(j,l)=mat(j,l)+dconjg(bra(i,j,k))*ket(i,l,k) - enddo - enddo - enddo - enddo -!$omp end do - else if (dim1.eq.1 .and. dim3.ne.1) then -!$omp do - do l=1,dim4 - do k=1,dim3 - do j=1,dim2 - mat(j,l)=mat(j,l)+dconjg(bra(1,j,k))*ket(1,l,k) - enddo - enddo - enddo -!$omp end do - else if (dim1.ne.1 .and. dim3.eq.1) then -!$omp do - do l=1,dim4 - do j=1,dim2 - do i=1,dim1 - mat(j,l)=mat(j,l)+dconjg(bra(i,j,1))*ket(i,l,1) - enddo - enddo - enddo -!$omp end do - else if (dim1.eq.1 .and. dim3.eq.1) then -!$omp do - do l=1,dim4 - do j=1,dim2 - mat(j,l)=mat(j,l)+dconjg(bra(1,j,1))*ket(1,l,1) - enddo - enddo -!$omp end do - endif -!$omp end parallel - - return - end subroutine rmmxxxzzomp - -!----------------------------------------------------------------------- -! Library subroutine rmmtxxzz -! -! Formation of density type matrix by multiplication of two complex -! tensors of third order, where the transpose of the matrix is stored: -! -! dconjg(bra(i,j,k))*ket(i,l,k) = mat(l,j). -! -!----------------------------------------------------------------------- - - subroutine rmmtxxzzomp (bra,ket,mat,dim1,dim2,dim3,dim4,ompthread) - - implicit none - - integer(long) :: i, j, & - k, l - integer(long), intent(in) :: dim1,dim2, & - dim3,dim4,& - ompthread - complex(dop), dimension(dim1,dim2,dim3), intent(in) :: bra - complex(dop), dimension(dim1,dim4,dim3), intent(in) :: ket - complex(dop), dimension(dim4,dim2), intent(out) :: mat - - mat = (0.0_dop,0.0_dop) - -!$omp parallel num_threads(ompthread) private(i,j,k,l) - if (dim1.ne.1 .and. dim3.ne.1) then -!$omp do - do j=1,dim2 - do k=1,dim3 - do l=1,dim4 - do i=1,dim1 - mat(l,j)=mat(l,j)+dconjg(bra(i,j,k))*ket(i,l,k) - enddo - enddo - enddo - enddo -!$omp enddo - else if (dim1.eq.1 .and. dim3.ne.1) then -!$omp do - do j=1,dim2 - do k=1,dim3 - do l=1,dim4 - mat(l,j)=mat(l,j)+dconjg(bra(1,j,k))*ket(1,l,k) - enddo - enddo - enddo -!$omp enddo - else if (dim1.ne.1 .and. dim3.eq.1) then -!$omp do - do j=1,dim2 - do l=1,dim4 - do i=1,dim1 - mat(l,j)=mat(l,j)+dconjg(bra(i,j,1))*ket(i,l,1) - enddo - enddo - enddo -!$omp enddo - else if (dim1.eq.1 .and. dim3.eq.1) then -!$omp do - do j=1,dim2 - do l=1,dim4 - mat(l,j)=mat(l,j)+dconjg(bra(1,j,1))*ket(1,l,1) - enddo - enddo -!$omp enddo - endif - -!$omp end parallel - - return - end subroutine rmmtxxzzomp - - end module rmomplib - - - - Index: source/lib/linear/lalib.f90 =================================================================== --- source/lib/linear/lalib.f90 (revision 854) +++ source/lib/linear/lalib.f90 (revision 855) @@ -136,7 +136,7 @@ T=(0.0d0,0.0d0) endif -!$omp parallel do if(lompthread) num_threads(ompthread) private(i,j,k) +! $omp parallel do if(lompthread) num_threads(ompthread) private(i,j,k) do k=1,c do j=1,b do i=1,a @@ -144,7 +144,7 @@ enddo enddo enddo -!$omp end parallel do +! $omp end parallel do return end subroutine mktens Index: source/lib/linear/xvlib.f90 =================================================================== --- source/lib/linear/xvlib.f90 (revision 854) +++ source/lib/linear/xvlib.f90 (revision 855) @@ -312,6 +312,7 @@ module xvlib use decimal, only: dop, long +use openmpmod implicit none private @@ -798,9 +799,11 @@ complex(dop), dimension(dim), intent(in) :: v complex(dop), dimension(dim), intent(inout) :: w +!$omp parallel do num_threads(ompthread) do i = 1,dim w(i) = w(i)+x*v(i) enddo +!$omp end parallel do return end subroutine @@ -1190,11 +1193,13 @@ complex(dop), intent(in) :: x complex(dop), dimension(dim,dim), intent(inout) :: a +!$omp parallel do num_threads(ompthread) do i = 1,dim do j = 1,dim a(j,i) = x*a(j,i) enddo enddo +!$omp end parallel do return end subroutine @@ -1277,11 +1282,13 @@ complex(dop), dimension(dim1,dim2), intent(inout) :: a +!$omp parallel do num_threads(ompthread) do i = 1,dim2 do j = 1,dim1 a(j,i) = x*a(j,i) enddo enddo +!$omp end parallel do return end subroutine Index: source/lib/linear/op1lib.f90 =================================================================== --- source/lib/linear/op1lib.f90 (revision 854) +++ source/lib/linear/op1lib.f90 (revision 855) @@ -321,6 +321,7 @@ module op1lib use decimal, only: dop, long, sip +use openmpmod implicit none private @@ -1289,8 +1290,6 @@ return end subroutine - - !---------------------------------------------------------------------- ! Library subroutine cpqvzd ! @@ -1307,9 +1306,11 @@ complex(dop), dimension(dim1,dim1), intent(in) :: a real(dop), dimension(dim1), intent(out) :: c +!$omp parallel do num_threads(ompthread) do i = 1,dim1 c(i) = dble(a(i,i)) enddo +!$omp end parallel do return end subroutine @@ -1333,11 +1334,13 @@ complex(dop), dimension(dim1,dim2), intent(in) :: a complex(dop), dimension(dim1,dim2), intent(out) :: c +!$omp parallel do num_threads(ompthread) do i = 1,dim2 do j = 1,dim1 c(j,i) = a(j,i) enddo enddo +!$omp end parallel do return end subroutine @@ -1449,9 +1452,11 @@ complex(dop), dimension(dim), intent(in) :: v complex(dop), dimension(dim), intent(out) :: w +!$omp parallel do num_threads(ompthread) do i = 1,dim w(i) = v(i) enddo +!$omp end parallel do return end subroutine @@ -1558,9 +1563,11 @@ complex(dop), dimension(dim), intent(in) :: v real(dop), dimension(dim), intent(out) :: w +!$omp parallel do num_threads(ompthread) do i = 1,dim w(i) = dble(v(i)) enddo +!$omp end parallel do return end subroutine @@ -1579,9 +1586,11 @@ integer(long), dimension(dim), intent(in) :: v integer(long), dimension(dim), intent(out) :: w +!$omp parallel do num_threads(ompthread) do i = 1,dim w(i) = v(i) enddo +!$omp end parallel do return end subroutine Index: source/lib/linear/mtlib.F90 =================================================================== --- source/lib/linear/mtlib.F90 (revision 0) +++ source/lib/linear/mtlib.F90 (revision 855) @@ -0,0 +1,3800 @@ +! ********************************************************************** +! +! MTLIB +! +! Library module containing linear algebra routines that involve the +! multiplication of a tensor of third order with a matrix. +! +! Nomenclature: +! Each name has 6 basic characters: +! First 2 characters denote the objects being multiplied: +! q: quadratic matrix +! m: general (rectangular) matrix +! h: hermitian matrix +! p: positive definite matrix +! s: symmetric matrix +! u: unitary matrix +! d: diagonal matrix (only diagonal elements are supplied as a +! vector) +! t: 2nd index of tensor of third order +! t1: 1st index of tensor of third order +! v: vector +! x: scalar +! e.g. 'qt' denotes the operation (quadratic matrix * tensor 2nd +! index) +! e.g. 'qt1' denotes the operation (quadratic matrix * tensor 1st +! index) +! Character 3 denotes how first object is used: +! x: unchanged from input +! t: transpose of input +! a: adjoint of input +! c: complex conjugate of input +! v: as a vector +! Character 4 denotes how second object is used: +! see Character 3 above. +! Character 5, 6 denote data types of first, second object +! respectively: +! z: complex double precision (complex*16) +! c: complex single precision (complex*8) +! d: real double precision (real*8) +! r: real single precision (real*4) +! y: complex matrix stored as two double precision (real*8) +! matrices +! Further characters, if present, give more informaion: +! a: the result is added to a further object +! r: the result is subtracted (removed) from a further object +! c: the input matrices commute +! h: the resulting matrix is hermitian +! s: the resulting matrix is symmetric +! 1: the physical dimensions of the matrices differs from those +! used. +! +! The suffix _s after the name means that the routine works with a +! "selected" vector", i.e. not all elements are present. +! +! Contents: +! In the following list of available subroutines, matrices/tensors on +! the LHS of the definition are input, that on the RHS output. The +! usual summation convention is used i.e. a sum is made over repeated +! indices on the LHS. +! +! addtxxzz (a,b,dim1,dim2,dim3) +! Definition: a(j) + b(i,j,k) = b(i,j,k) . +! Dimensions: a(dim2),b(dim1,dim2,dim3) +! +! qtxxzz (a,b,c,dim1,dim2,dim3) +! Definition: a(l,j)*b(i,j,k) = c(i,l,k) . +! Dimensions: a(dim2,dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) +! +! qtxxzd (a,b,c,dim1,dim2,dim3) +! Definition: dble(a(l,j))*b(i,j,k) = c(i,l,k) . +! Dimensions: a(dim2,dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) +! +! qtxxzza (a,b,c,dim1,dim2,dim3) +! Definition: a(l,j)*b(i,j,k) + c(i,l,k) = c(i,l,k) . +! Dimensions: a(dim2,dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) +! +! qtxxzda (a,b,c,dim1,dim2,dim3) +! Definition: dble(a(l,j))*b(i,j,k) + c(i,l,k) = c(i,l,k) . +! Dimensions: a(dim2,dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) +! +! qttxzza (a,b,c,dim1,dim2,dim3) +! Definition: a(j,l)*b(i,j,k) + c(i,l,k) = c(i,l,k) . +! Dimensions: a(dim2,dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) +! +! qttxzzs (a,b,c,dim1,dim2,dim3) +! Definition: c(i,l,k) - a(j,l)*b(i,j,k) = c(i,l,k) . +! Dimensions: a(dim2,dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) +! +! qtxxzzr (a,b,c,dim1,dim2,dim3) +! Definition: c(i,l,k) - a(l,j)*b(i,j,k) = c(i,l,k) . +! Dimensions: a(dim2,dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) +! +! tqxxzza (a,b,c,dim1,dim2,dim3) +! Definition: a(i,j,k)*b(j,l) + c(i,l,k) = c(i,l,k) . +! Dimensions: a(dim1,dim2,dim3),b(dim2,dim2),c(dim1,dim2,dim3) +! +! tqxazza (a,b,c,dim1,dim2,dim3) +! Definition: a(i,j,k)*dconjg(b(l,j)) + c(i,l,k) = c(i,l,k) . +! Dimensions: a(dim1,dim2,dim3),b(dim2,dim2),c(dim1,dim2,dim3) +! +! tqxazz (a,b,c,dim1,dim2,dim3) +! Definition: a(i,j,k)*dconjg(b(l,j)) = c(i,l,k) . +! Dimensions: a(dim1,dim2,dim3),b(dim2,dim2),c(dim1,dim2,dim3) +! +! mtxxzz (a,b,c,dim1,dim2,dim3,dim4) +! Definition: a(l,j)*b(i,j,k) = c(i,l,k) . +! Dimensions: a(dim4,dim2),b(dim1,dim2,dim3),c(dim1,dim4,dim3) +! +! mtxxzd (a,b,c,dim1,dim2,dim3,dim4) +! Definition: a(l,j)*b(i,j,k) = c(i,l,k) . +! Dimensions: a(dim4,dim2),b(dim1,dim2,dim3),c(dim1,dim4,dim3) +! +! mtvxzz (a,b,c,dim1,dim2,dim3,dim4,p) +! Definition: a(p,j)*b(i,j,k) = c(i,k) . +! Dimensions: a(dim4,dim2),b(dim1,dim2,dim3),c(dim1,dim3) +! +! mtcxzz (a,b,c,dim1,dim2,dim3,dim4) +! Definition: conjg(a(l,j))*b(i,j,k) = c(i,l,k) . +! Dimensions: a(dim4,dim2),b(dim1,dim2,dim3),c(dim1,dim4,dim3) +! +! mtxxdz (a,b,c,dim1,dim2,dim3,dim4) +! Definition: a(l,j)*b(i,j,k) = c(i,l,k) . +! Dimensions: a(dim4,dim2),b(dim1,dim2,dim3),c(dim1,dim4,dim3) +! +! mttxzz (a,b,c,dim1,dim2,dim3,dim4) +! Definition: a(j,l)*b(i,j,k) = c(i,l,k) . +! Dimensions: a(dim2,dim4),b(dim1,dim2,dim3),c(dim1,dim4,dim3) +! +! mttxdd (a,b,c,dim1,dim2,dim3,dim4) +! Definition: a(j,l)*b(i,j,k) = c(i,l,k) . +! Dimensions: a(dim2,dim4),b(dim1,dim2,dim3),c(dim1,dim4,dim3) +! +! mttxdr (a,b,c,dim1,dim2,dim3,dim4) +! Definition: a(j,l)*b(i,j,k) = c(i,l,k) . +! Dimensions: a(dim2,dim4),b(dim1,dim2,dim3),c(dim1,dim4,dim3) +! +! mtxxdd (a,b,c,dim1,dim2,dim3,dim4) +! Definition: a(l,j)*b(i,j,k) = c(i,l,k) . +! Dimensions: a(dim4,dim2),b(dim1,dim2,dim3),c(dim1,dim4,dim3) +! +! mtaxzz (a,b,c,dim1,dim2,dim3,dim4) +! Definition: dconjg(a(j,l))*b(i,j,k) = c(i,l,k) . +! Dimensions: a(dim2,dim4),b(dim1,dim2,dim3),c(dim1,dim4,dim3) +! +!C qtxxdd (a,b,c,dim1,dim2,dim3) +!C Definition: a(l,j)*b(i,j,k) = c(i,l,k) . +!C Dimensions: a(dim2,dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) +! +! qtcxzz (a,b,c,dim1,dim2,dim3) +! Definition: dconjg(a(l,j))*b(i,j,k) = c(i,l,k) . +! Dimensions: a(dim2,dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) +! +! qttxdd (a,b,c,dim1,dim2,dim3) +! Definition: a(l,j)*b(i,j,k) = c(i,l,k) . +! Dimensions: a(dim2,dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) +! +! dtxxzz (a,b,c,dim1,dim2,dim3) +! Definition: a(j)*b(i,j,k) = c(i,j,k) . +! Dimensions: a(dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) +! +! dtxxzzo (a,b,dim1,dim2,dim3) +! Definition: a(j)*b(i,j,k) = b(i,j,k) . +! Dimensions: a(dim2),b(dim1,dim2,dim3) +! +! dtxxzzr (a,b,c,dim1,dim2,dim3) +! Definition: c(i,j,k) - a(j)*b(i,j,k) = c(i,j,k) . +! Dimensions: a(dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) +! +! dtxxdd (a,b,c,dim1,dim2,dim3) +! Definition: a(j)*b(i,j,k) = c(i,j,k) . +! Dimensions: a(dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) +! +! dtxxddo (a,b,dim1,dim2,dim3) +! Definition: a(j)*b(i,j,k) = b(i,j,k) . +! Dimensions: a(dim2),b(dim1,dim2,dim3) +! +! dtxxdz (a,b,c,dim1,dim2,dim3) +! Definition: a(j)*b(i,j,k) = c(i,j,k) . +! Dimensions: a(dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) +! +! dtxxdzo (a,b,dim1,dim2,dim3) +! Definition: a(j)*b(i,j,k) = b(i,j,k) . +! Dimensions: a(dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) +! +! qtaxzz (a,b,c,dim1,dim2,dim3) +! Definition: dconjg(a(j,l))*b(i,j,k) = c(i,l,k) . +! Dimensions: a(dim2,dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) +! +! qtxxdz (a,b,c,dim1,dim2,dim3) +! Definition: a(l,j)*b(i,j,k) = c(i,l,k) . +! Dimensions: a(dim2,dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) +! +! qtxxdza (a,b,c,dim1,dim2,dim3) +! Definition: a(l,j)*b(i,j,k) + c(i,l,k) = c(i,l,k) . +! Dimensions: a(dim2,dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) +! +! qt1xxdz (a,b,c,dim1,dim2,dim3) +! Definition: a(l,i)*b(i,j,k) = c(l,j,k) . +! Dimensions: a(dim1,dim1),b(dim1,dim2,dim3),c(dim1,dim2,dim3) +! +! dt1xxzz (a,b,c,dim1,dim2,dim3) +! Definition: a(i)*b(i,j,k) = c(i,j,k) . +! Dimensions: a(dim1),b(dim1,dim2,dim3),c(dim1,dim2,dim3) +! +! qt1txdz (a,b,c,dim1,dim2,dim3) +! Definition: a(i,l)*b(i,j,k) = c(l,j,k) . +! Dimensions: a(dim1,dim1),b(dim1,dim2,dim3),c(dim1,dim2,dim3) +! +! qttxdz (a,b,c,dim1,dim2,dim3) +! Definition: a(l,j)*b(i,j,k) = c(i,l,k) . +! Dimensions: a(dim2,dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) +! +! qttxzz (a,b,c,dim1,dim2,dim3) +! Definition: a(j,l)*b(i,j,k) = c(i,l,k) . +! Dimensions: a(dim2,dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) +! +! qtxxyz (a,b,c,dim1,dim2,dim3) +! Definition: a(l,j)*b(i,j,k) = c(i,l,k) . +! Dimensions: a(dim2,dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) +! +! qttxyz (a,b,c,dim1,dim2,dim3) +! Definition: a(j,l)*b(i,j,k) = c(i,l,k) . +! Dimensions: a(dim2,dim2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) +! +! dtxxyz (a,b,c,dim1,dim2,dim3) +! Definition: a(j,1)*b(i,j,k) + (0,1)*a(j,2)*b(i,j,k) = c(i,j,k) . +! Dimensions: a(dim2,2),b(dim1,dim2,dim3),c(dim1,dim2,dim3) +! +! qtxxzz_s (a,b,c,dim1,dim2,dim3,index,index1) +! Definition: index(i,j,k)=x +! index1(i,l,k)=x1 +! a(l,j)*b(x) = c(x1) . +! Dimensions: a(dim2,dim2),index(dim1,dim2,dim3), +! index1(dim1,dim2,dim3),b(max(x)),c(max(x1)) +! +! mtxxzz_s (a,b,c,dim1,dim2,dim3,dim4,dim5,index,index1) +! Definition: index(i,j,k)=x +! index1(i,l,k)=x1 +! a(l,j)*b(x) = c(x1) . +! Dimensions: a(dim4,dim5),index(dim1,dim2,dim3), +! index1(dim1,dim2,dim3),b(max(x)),c(max(x1)) +! +! qttxzz_s (a,b,c,dim1,dim2,dim3,index,index1) +! Definition: index(i,j,k)=x +! index1(i,l,k)=x1 +! a(j,l)*b(x) = c(x1) . +! Dimensions: a(dim2,dim2),index(dim1,dim2,dim3), +! index1(dim1,dim2,dim3),b(max(x)),c(max(x1)) +! +! qtxxzza_s (a,b,c,dim1,dim2,dim3,index,index1) +! Definition: index(i,j,k)=x +! index1(i,l,k)=x1 +! a(l,j)*b(x) + c(x1) = c(x1) . +! Dimensions: a(dim2,dim2),index(dim1,dim2,dim3), +! index1(dim1,dim2,dim3),b(max(x)),c(max(x1)) +! +! qtxxzzr_s (a,b,c,dim1,dim2,dim3,index,index1) +! Definition: index(i,j,k)=x +! index1(i,l,k)=x1 +! c(x1) - a(l,j)*b(x) = c(x1) . +! Dimensions: a(dim2,dim2),index(dim1,dim2,dim3), +! index1(dim1,dim2,dim3),b(max(x)),c(max(x1)) +! +! ********************************************************************** + module mtlib + +use decimal, only: dop, long, sip +use openmpmod +use omp_lib + + implicit none + private + public :: addtxxzz, qtxxzz, qtxxzd, qtxxzza, qtxxzda, qttxzza, & + qttxzzs, qtxxzzr, tqxxzza, tqxazza, tqxazz, mtxxzz, & + mtvxzz, mtxxzd, mtcxzz, mtxxdz, mttxzz, mttxdd, mttxdr, & + mtxxdd, mtaxzz, qtxxdd, qtcxzz, qttxdd, dtxxzz, & + dtxxzzo, dtxxzzr, dtxxdd, dtxxddo, dtxxdz, dtxxdzo, qtaxzz, & + qtxxdz, qtxxdza, qt1xxdz, dt1xxzz, qt1txdz, & + qttxdz, qttxzz, qtxxyz, qttxyz, dtxxyz, qtxxzz_s, & + mtxxzz_s, qttxzz_s, qtxxzza_s, qtxxzzr_s + + contains + +!----------------------------------------------------------------------- +! Library subroutine addtxxzz +! +! Multiplication of a complex quadratic matrix with a complex tensor +! of third order: +! a(j) + b(i,j,k) = b(i,j,k). +! +! Input-variables: a - complex vector +! b - complex tensor of third order +! Output-variables: b - resulting complex tensor +!----------------------------------------------------------------------- + + subroutine addtxxzz (a,b,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2, & + dim3 + complex(dop), dimension(dim2), intent(in) :: a + complex(dop), dimension(dim1,dim2,dim3), intent(inout) :: b + + do k=1,dim3 + do j=1,dim2 + do i=1,dim1 + b(i,j,k)=b(i,j,k)+a(j) + enddo + enddo + enddo + + return + end subroutine + + +!----------------------------------------------------------------------- +! Library subroutine qtxxzz +! +! Multiplication of a complex quadratic matrix with a complex tensor +! of third order: +! a(l,j)*b(i,j,k) = c(i,l,k). +! +! Input-variables: a - complex matrix +! b - complex tensor of third order +! Output-variables: c - resulting complex tensor +!----------------------------------------------------------------------- + + subroutine qtxxzz (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k, l + integer(long), intent(in) :: dim1, dim2, & + dim3 + complex(dop), dimension(dim2,dim2), intent(in) :: a + complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b + complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c + complex(dop) :: ctmp + +#ifdef OMP + +!$omp parallel num_threads(ompthread) private(i,j,k,l) if (lompthread) +!$omp do + do k=1,dim3 + do i=1,dim1 + do l=1,dim2 + c(i,l,k) = 0.0d0 + do j=1,dim2 + c(i,l,k)=c(i,l,k)+a(l,j)*b(i,j,k) + enddo + enddo + enddo + enddo +!$omp end do +!$omp end parallel + +#else + + c(:,:,:) = 0.0d0 + + if (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do l=1,dim2 + do i=1,dim1 + c(i,l,k)=c(i,l,k)+a(l,j)*b(i,j,k) + enddo + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do l=1,dim2 + c(1,l,k)=c(1,l,k)+a(l,j)*b(1,j,k) + enddo + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do j=1,dim2 + do l=1,dim2 + do i=1,dim1 + c(i,l,1)=c(i,l,1)+a(l,j)*b(i,j,1) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do j=1,dim2 + do l=1,dim2 + c(1,l,1)=c(1,l,1)+a(l,j)*b(1,j,1) + enddo + enddo + endif + +#endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine qtxxzd +! +! Multiplication of a complex quadratic matrix with a real tensor +! of third order: +! dble(a(l,j))*b(i,j,k) = c(i,l,k). +! +! Input-variables: a - complex matrix (only real part used) +! b - real tensor of third order +! Output-variables: c - resulting real tensor +!----------------------------------------------------------------------- + + subroutine qtxxzd (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k, l + integer(long), intent(in) :: dim1, dim2, & + dim3 + real(dop), dimension(dim1,dim2,dim3), intent(in) :: b + real(dop), dimension(dim1,dim2,dim3), intent(out) :: c + complex(dop), dimension(dim2,dim2), intent(in) :: a + + if (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim2 + do i=1,dim1 + c(i,l,k)=dble(a(l,1))*b(i,1,k) + enddo + enddo + enddo + do k=1,dim3 + do j=2,dim2 + do l=1,dim2 + do i=1,dim1 + c(i,l,k)=c(i,l,k)+dble(a(l,j))*b(i,j,k) + enddo + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim2 + c(1,l,k)=dble(a(l,1))*b(1,1,k) + enddo + enddo + do k=1,dim3 + do j=2,dim2 + do l=1,dim2 + c(1,l,k)=c(1,l,k)+dble(a(l,j))*b(1,j,k) + enddo + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do l=1,dim2 + do i=1,dim1 + c(i,l,1)=dble(a(l,1))*b(i,1,1) + enddo + enddo + do j=2,dim2 + do l=1,dim2 + do i=1,dim1 + c(i,l,1)=c(i,l,1)+dble(a(l,j))*b(i,j,1) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do l=1,dim2 + c(1,l,1)=dble(a(l,1))*b(1,1,1) + enddo + do j=2,dim2 + do l=1,dim2 + c(1,l,1)=c(1,l,1)+dble(a(l,j))*b(1,j,1) + enddo + enddo + endif + + return + end subroutine + + +!----------------------------------------------------------------------- +! Library subroutine qtxxzza +! +! Multiplication of a complex quadratic matrix with a complex tensor +! of third order and added to a different tensor: +! a(l,j)*b(i,j,k) + c(i,l,k) = c(i,l,k). +! +! Input-variables: a - complex matrix +! b - complex tensor of third order +! c - complex tensor of third order +! Output-variables: c - resulting complex tensor +! +! NB input c matrix is overwritten on output. +!----------------------------------------------------------------------- + + subroutine qtxxzza (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k, l + integer(long), intent(in) :: dim1, dim2, & + dim3 + complex(dop), dimension(dim2,dim2), intent(in) :: a + complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b + complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c + + if (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do l=1,dim2 + do i=1,dim1 + c(i,l,k)=c(i,l,k)+a(l,j)*b(i,j,k) + enddo + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do l=1,dim2 + c(1,l,k)=c(1,l,k)+a(l,j)*b(1,j,k) + enddo + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do j=1,dim2 + do l=1,dim2 + do i=1,dim1 + c(i,l,1)=c(i,l,1)+a(l,j)*b(i,j,1) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do j=1,dim2 + do l=1,dim2 + c(1,l,1)=c(1,l,1)+a(l,j)*b(1,j,1) + enddo + enddo + endif + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine qtxxzda +! +! Multiplication of a complex quadratic matrix with a complex tensor +! of third order and added to a different tensor: +! dble(a(l,j))*b(i,j,k) + c(i,l,k) = c(i,l,k). +! +! Input-variables: a - complex matrix +! b - real tensor of third order +! c - real tensor of third order +! Output-variables: c - resulting complex tensor +! +! NB input ! matrix is overwritten on output. +!----------------------------------------------------------------------- + + subroutine qtxxzda (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k, l + integer(long), intent(in) :: dim1, dim2, & + dim3 + real(dop), dimension(dim1,dim2,dim3), intent(in) :: b + real(dop), dimension(dim1,dim2,dim3), intent(inout) :: c + complex(dop), dimension(dim2,dim2), intent(in) :: a + + if (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do l=1,dim2 + do i=1,dim1 + c(i,l,k)=c(i,l,k)+dble(a(l,j))*b(i,j,k) + enddo + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do l=1,dim2 + c(1,l,k)=c(1,l,k)+dble(a(l,j))*b(1,j,k) + enddo + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do j=1,dim2 + do l=1,dim2 + do i=1,dim1 + c(i,l,1)=c(i,l,1)+dble(a(l,j))*b(i,j,1) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do j=1,dim2 + do l=1,dim2 + c(1,l,1)=c(1,l,1)+dble(a(l,j))*b(1,j,1) + enddo + enddo + endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine qttxzza +! +! Multiplication of a complex quadratic matrix with a complex tensor +! of third order and added to a different tensor: +! a(j,l)*b(i,j,k) + c(i,l,k) = c(i,l,k). +! +! Input-variables: a - complex matrix +! b - complex tensor of third order +! c - complex tensor of third order +! Output-variables: c - resulting complex tensor +! +! NB input ! matrix is overwritten on output. +!----------------------------------------------------------------------- + + subroutine qttxzza (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k, l + integer(long), intent(in) :: dim1, dim2, & + dim3 + complex(dop), dimension(dim2,dim2), intent(in) :: a + complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b + complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c + + if (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do l=1,dim2 + do i=1,dim1 + c(i,l,k)=c(i,l,k)+a(j,l)*b(i,j,k) + enddo + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do l=1,dim2 + c(1,l,k)=c(1,l,k)+a(j,l)*b(1,j,k) + enddo + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do j=1,dim2 + do l=1,dim2 + do i=1,dim1 + c(i,l,1)=c(i,l,1)+a(j,l)*b(i,j,1) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do j=1,dim2 + do l=1,dim2 + c(1,l,1)=c(1,l,1)+a(j,l)*b(1,j,1) + enddo + enddo + endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine qtxxzzs +! +! Multiplication of a complex quadratic matrix with a complex tensor +! of third order and subtracted from a different tensor: +! c(i,l,k) - a(l,j)*b(i,j,k) = c(i,l,k). +! +! Input-variables: a - complex matrix +! b - complex tensor of third order +! c - complex tensor of third order +! Output-variables: c - resulting complex tensor +! +! NB input ! matrix is overwritten on output. +!----------------------------------------------------------------------- + +! subroutine qtxxzzs (a,b,c,dim1,dim2,dim3) + +! implicit none + +! integer(long) :: i, j, k, l +! integer(long), intent(in) :: dim1, dim2, & +! dim3 +! complex(dop), dimension(dim2,dim2), intent(in) :: a +! complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b +! complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c + +! if (dim1.ne.1 .and. dim3.ne.1) then +! do k=1,dim3 +! do j=1,dim2 +! do l=1,dim2 +! do i=1,dim1 +! c(i,l,k)=c(i,l,k)-a(l,j)*b(i,j,k) +! enddo +! enddo +! enddo +! enddo +! else if (dim1.eq.1 .and. dim3.ne.1) then +! do k=1,dim3 +! do j=1,dim2 +! do l=1,dim2 +! c(1,l,k)=c(1,l,k)-a(l,j)*b(1,j,k) +! enddo +! enddo +! enddo +! else if (dim1.ne.1 .and. dim3.eq.1) then +! do j=1,dim2 +! do l=1,dim2 +! do i=1,dim1 +! c(i,l,1)=c(i,l,1)-a(l,j)*b(i,j,1) +! enddo +! enddo +! enddo +! else if (dim1.eq.1 .and. dim3.eq.1) then +! do j=1,dim2 +! do l=1,dim2 +! c(1,l,1)=c(1,l,1)-a(l,j)*b(1,j,1) +! enddo +! enddo +! endif + +! return +! end subroutine + + +!----------------------------------------------------------------------- +! Library subroutine qttxzzs +! +! Multiplication of a complex quadratic matrix with a complex tensor +! of third order and substracted from a different tensor: +! c(i,l,k) - a(j,l)*b(i,j,k) = c(i,l,k). +! +! Input-variables: a - complex matrix +! b - complex tensor of third order +! c - complex tensor of third order +! Output-variables: c - resulting complex tensor +! +! NB input ! matrix is overwritten on output. +!----------------------------------------------------------------------- + + subroutine qttxzzs (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k, l + integer(long), intent(in) :: dim1, dim2, & + dim3 + complex(dop), dimension(dim2,dim2), intent(in) :: a + complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b + complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c + + if (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do l=1,dim2 + do i=1,dim1 + c(i,l,k)=c(i,l,k)-a(j,l)*b(i,j,k) + enddo + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do l=1,dim2 + c(1,l,k)=c(1,l,k)-a(j,l)*b(1,j,k) + enddo + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do j=1,dim2 + do l=1,dim2 + do i=1,dim1 + c(i,l,1)=c(i,l,1)-a(j,l)*b(i,j,1) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do j=1,dim2 + do l=1,dim2 + c(1,l,1)=c(1,l,1)-a(j,l)*b(1,j,1) + enddo + enddo + endif + + return + end subroutine + + +!----------------------------------------------------------------------- +! Library subroutine qtxxzzr +! +! Multiplication of a complex quadratic matrix with a complex tensor +! of third order and subtracted from a different tensor: +! c(i,l,k) - a(l,j)*b(i,j,k) = c(i,l,k). +! +! Input-variables: a - complex matrix +! b - complex tensor of third order +! c - complex tensor of third order +! Output-variables: c - resulting complex tensor +!----------------------------------------------------------------------- + + subroutine qtxxzzr (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k, l + integer(long), intent(in) :: dim1, dim2, & + dim3 + complex(dop), dimension(dim2,dim2), intent(in) :: a + complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b + complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c + + if (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do l=1,dim2 + do i=1,dim1 + c(i,l,k)=c(i,l,k)-a(l,j)*b(i,j,k) + enddo + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do l=1,dim2 + c(1,l,k)=c(1,l,k)-a(l,j)*b(1,j,k) + enddo + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do j=1,dim2 + do l=1,dim2 + do i=1,dim1 + c(i,l,1)=c(i,l,1)-a(l,j)*b(i,j,1) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do j=1,dim2 + do l=1,dim2 + c(1,l,1)=c(1,l,1)-a(l,j)*b(1,j,1) + enddo + enddo + endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine tqxxzza +! +! Multiplication of a complex quadratic matrix with a complex tensor +! of third order and added to a different tensor: +! a(i,j,k)*b(j,l) + c(i,l,k) = c(i,l,k). +! +! Input-variables: a - complex tensor of third order +! b - complex matrix +! c - complex tensor of third order +! Output-variables: c - resulting complex tensor +! +! NB input ! matrix is overwritten on output. +!----------------------------------------------------------------------- + + subroutine tqxxzza (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k, l + integer(long), intent(in) :: dim1, dim2, & + dim3 + complex(dop), dimension(dim1,dim2,dim3), intent(in) :: a + complex(dop), dimension(dim2,dim2), intent(in) :: b + complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c + + if (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim2 + do j=1,dim2 + do i=1,dim1 + c(i,l,k)=c(i,l,k)+a(i,j,k)*b(j,l) + enddo + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim2 + do j=1,dim2 + c(1,l,k)=c(1,l,k)+a(1,j,k)*b(j,l) + enddo + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do l=1,dim2 + do j=1,dim2 + do i=1,dim1 + c(i,l,1)=c(i,l,1)+a(i,j,1)*b(j,l) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do l=1,dim2 + do j=1,dim2 + c(1,l,1)=c(1,l,1)+a(1,j,1)*b(j,l) + enddo + enddo + endif + + return + end subroutine + + + +!----------------------------------------------------------------------- +! Library subroutine tqxazza +! +! Multiplication of a complex quadratic matrix with a complex tensor +! of third order and added to a different tensor: +! a(i,j,k)*dconjg(b(l,j)) + c(i,l,k) = c(i,l,k). +! +! Input-variables: a - complex tensor of third order +! b - complex matrix +! c - complex tensor of third order +! Output-variables: c - resulting complex tensor +! +! NB input ! matrix is overwritten on output. +!----------------------------------------------------------------------- + + subroutine tqxazza (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k, l + integer(long), intent(in) :: dim1, dim2, & + dim3 + complex(dop), dimension(dim1,dim2,dim3), intent(in) :: a + complex(dop), dimension(dim2,dim2), intent(in) :: b + complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c + + if (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim2 + do j=1,dim2 + do i=1,dim1 + c(i,l,k)=c(i,l,k)+a(i,j,k)*dconjg(b(l,j)) + enddo + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim2 + do j=1,dim2 + c(1,l,k)=c(1,l,k)+a(1,j,k)*dconjg(b(l,j)) + enddo + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do l=1,dim2 + do j=1,dim2 + do i=1,dim1 + c(i,l,1)=c(i,l,1)+a(i,j,1)*dconjg(b(l,j)) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do l=1,dim2 + do j=1,dim2 + c(1,l,1)=c(1,l,1)+a(1,j,1)*dconjg(b(l,j)) + enddo + enddo + endif + + return + end subroutine + + + +!----------------------------------------------------------------------- +! Library subroutine tqxazz +! +! Multiplication of a complex quadratic matrix with a complex tensor +! of third order: +! a(i,j,k)*dconjg(b(l,j)) = c(i,l,k). +! +! Input-variables: a - complex tensor of third order +! b - complex matrix +! +! Output-variables: c - resulting complex tensor +! +!----------------------------------------------------------------------- + + subroutine tqxazz (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k, l + integer(long), intent(in) :: dim1, dim2, & + dim3 + complex(dop), dimension(dim1,dim2,dim3), intent(in) :: a + complex(dop), dimension(dim2,dim2), intent(in) :: b + complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c + + If (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim2 + do i=1,dim1 + c(i,l,k)=a(i,1,k)*dconjg(b(l,1)) + enddo + enddo + enddo + do k=1,dim3 + do l=1,dim2 + do j=2,dim2 + do i=1,dim1 + c(i,l,k)=c(i,l,k)+a(i,j,k)*dconjg(b(l,j)) + enddo + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim2 + c(1,l,k)=a(1,1,k)*dconjg(b(l,1)) + enddo + enddo + do k=1,dim3 + do l=1,dim2 + do j=2,dim2 + c(1,l,k)=c(1,l,k)+a(1,j,k)*dconjg(b(l,j)) + enddo + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do l=1,dim2 + do i=1,dim1 + c(i,l,1)=a(i,1,1)*dconjg(b(l,1)) + enddo + enddo + do l=1,dim2 + do j=2,dim2 + do i=1,dim1 + c(i,l,1)=c(i,l,1)+a(i,j,1)*dconjg(b(l,j)) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do l=1,dim2 + c(1,l,1)=a(1,1,1)*dconjg(b(l,1)) + enddo + do l=1,dim2 + do j=2,dim2 + c(1,l,1)=c(1,l,1)+a(1,j,1)*dconjg(b(l,j)) + enddo + enddo + endif + + return + end subroutine + + +!----------------------------------------------------------------------- +! Library subroutine mtxxzz +! +! Multiplication of a complex rectangular matrix with a complex tensor +! of third order: +! a(l,j)*b(i,j,k) = c(i,l,k) . +! +! Input-variables: a - complex matrix +! b - complex tensor of third order +! Output-variables: c - resulting complex tensor +!----------------------------------------------------------------------- + + subroutine mtxxzz (a,b,c,dim1,dim2,dim3,dim4) + + implicit none + + integer(long) :: i, j, k, l,ithr + integer(long), intent(in) :: dim1, dim2, & + dim3, dim4 + complex(dop), dimension(dim4,dim2), intent(in) :: a + complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b + complex(dop), dimension(dim1,dim4,dim3), intent(out) :: c + +#ifdef OMP +!$omp parallel num_threads(ompthread) private(i,j,k,l) if (lompthread) +!$omp do + do k=1,dim3 + do i=1,dim1 + do l=1,dim4 + c(i,l,k) = 0.0d0 + do j=1,dim2 + c(i,l,k)=c(i,l,k)+a(l,j)*b(i,j,k) + enddo + enddo + enddo + enddo +!$omp end do +!$omp end parallel + +#else + c(:,:,:) = 0.0d0 + if (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do l=1,dim4 + do i=1,dim1 + c(i,l,k)=c(i,l,k)+a(l,j)*b(i,j,k) + enddo + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do l=1,dim4 + c(1,l,k)=c(1,l,k)+a(l,j)*b(1,j,k) + enddo + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do j=1,dim2 + do l=1,dim4 + do i=1,dim1 + c(i,l,1)=c(i,l,1)+a(l,j)*b(i,j,1) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do j=1,dim2 + do l=1,dim4 + c(1,l,1)=c(1,l,1)+a(l,j)*b(1,j,1) + enddo + enddo + endif + +#endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine mtvxzz +! +! Multiplication of a complex rectangular matrix with a complex tensor +! of third order witth p fixed (matrix used as a vector): +! a(p,j)*b(i,j,k) = c(i,k) . +! +! Input-variables: a - complex matrix +! b - complex tensor of third order +! Output-variables: c - resulting complex tensor +!----------------------------------------------------------------------- + + subroutine mtvxzz (a,b,c,dim1,dim2,dim3,dim4,p) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2, & + dim3, dim4, p + complex(dop), dimension(dim4,dim2), intent(in) :: a + complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b + complex(dop), dimension(dim1,dim3), intent(out) :: c + + If (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do i=1,dim1 + c(i,k)=a(p,1)*b(i,1,k) + enddo + enddo + do k=1,dim3 + do j=2,dim2 + do i=1,dim1 + c(i,k)=c(i,k)+a(p,j)*b(i,j,k) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + c(1,k)=a(p,1)*b(1,1,k) + enddo + do k=1,dim3 + do j=2,dim2 + c(1,k)=c(1,k)+a(p,j)*b(1,j,k) + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do i=1,dim1 + c(i,1)=a(p,1)*b(i,1,1) + enddo + do j=2,dim2 + do i=1,dim1 + c(i,1)=c(i,1)+a(p,j)*b(i,j,1) + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + c(1,1)=a(p,1)*b(1,1,1) + do j=2,dim2 + c(1,1)=c(1,1)+a(p,j)*b(1,j,1) + enddo + endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine mtxxzd +! +! Multiplication of a complex rectangular matrix with a real tensor +! of third order: +! dble(a(l,j))*b(i,j,k) = c(i,l,k) . +! +! Input-variables: a - complex matrix +! b - real tensor of third order +! Output-variables: c - resulting real tensor +!----------------------------------------------------------------------- + + subroutine mtxxzd (a,b,c,dim1,dim2,dim3,dim4) + + implicit none + + integer(long) :: i, j, k, l + integer(long), intent(in) :: dim1, dim2, & + dim3, dim4 + real(dop), dimension(dim1,dim2,dim3), intent(in) :: b + real(dop), dimension(dim1,dim4,dim3), intent(out) :: c + complex(dop), dimension(dim4,dim2), intent(in) :: a + + If (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim4 + do i=1,dim1 + c(i,l,k)=dble(a(l,1))*b(i,1,k) + enddo + enddo + enddo + do k=1,dim3 + do j=2,dim2 + do l=1,dim4 + do i=1,dim1 + c(i,l,k)=c(i,l,k)+dble(a(l,j))*b(i,j,k) + enddo + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim4 + c(1,l,k)=dble(a(l,1))*b(1,1,k) + enddo + enddo + do k=1,dim3 + do j=2,dim2 + do l=1,dim4 + c(1,l,k)=c(1,l,k)+dble(a(l,j))*b(1,j,k) + enddo + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do l=1,dim4 + do i=1,dim1 + c(i,l,1)=dble(a(l,1))*b(i,1,1) + enddo + enddo + do j=2,dim2 + do l=1,dim4 + do i=1,dim1 + c(i,l,1)=c(i,l,1)+dble(a(l,j))*b(i,j,1) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do l=1,dim4 + c(1,l,1)=dble(a(l,1))*b(1,1,1) + enddo + do j=2,dim2 + do l=1,dim4 + c(1,l,1)=c(1,l,1)+dble(a(l,j))*b(1,j,1) + enddo + enddo + endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine mtcxzz +! +! Multiplication of a complex rectangular matrix with a complex tensor +! of third order: +! conjg(a(l,j))*b(i,j,k) = c(i,l,k) . +! +! Input-variables: a - complex matrix +! b - complex tensor of third order +! Output-variables: c - resulting complex tensor +!----------------------------------------------------------------------- + + subroutine mtcxzz (a,b,c,dim1,dim2,dim3,dim4) + + implicit none + + integer(long) :: i, j, k, l + integer(long), intent(in) :: dim1, dim2, & + dim3, dim4 + complex(dop), dimension(dim4,dim2), intent(in) :: a + complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b + complex(dop), dimension(dim1,dim4,dim3), intent(out) :: c + + If (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim4 + do i=1,dim1 + c(i,l,k)=conjg(a(l,1))*b(i,1,k) + enddo + enddo + enddo + do k=1,dim3 + do j=2,dim2 + do l=1,dim4 + do i=1,dim1 + c(i,l,k)=c(i,l,k)+conjg(a(l,j))*b(i,j,k) + enddo + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim4 + c(1,l,k)=conjg(a(l,1))*b(1,1,k) + enddo + enddo + do k=1,dim3 + do j=2,dim2 + do l=1,dim4 + c(1,l,k)=c(1,l,k)+conjg(a(l,j))*b(1,j,k) + enddo + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do l=1,dim4 + do i=1,dim1 + c(i,l,1)=conjg(a(l,1))*b(i,1,1) + enddo + enddo + do j=2,dim2 + do l=1,dim4 + do i=1,dim1 + c(i,l,1)=c(i,l,1)+conjg(a(l,j))*b(i,j,1) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do l=1,dim4 + c(1,l,1)=conjg(a(l,1))*b(1,1,1) + enddo + do j=2,dim2 + do l=1,dim4 + c(1,l,1)=c(1,l,1)+conjg(a(l,j))*b(1,j,1) + enddo + enddo + endif + + return + end subroutine + + +!----------------------------------------------------------------------- +! Library subroutine mtxxdz +! +! Multiplication of a real rectangular matrix with a complex tensor +! of third order: +! a(l,j)*b(i,j,k) = c(i,l,k) . +! +! Input-variables: a - real rectangular matrix +! b - complex tensor of third order +! Output-variables: c - resulting complex tensor +!----------------------------------------------------------------------- + + subroutine mtxxdz (a,b,c,dim1,dim2,dim3,dim4) + + implicit none + + integer(long) :: i, j, k, l + integer(long), intent(in) :: dim1, dim2, & + dim3, dim4 + real(dop), dimension(dim4,dim2), intent(in) :: a + complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b + complex(dop), dimension(dim1,dim4,dim3), intent(out) :: c + + If (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim4 + do i=1,dim1 + c(i,l,k)=a(l,1)*b(i,1,k) + enddo + enddo + enddo + do k=1,dim3 + do j=2,dim2 + do l=1,dim4 + do i=1,dim1 + c(i,l,k)=c(i,l,k)+a(l,j)*b(i,j,k) + enddo + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim4 + c(1,l,k)=a(l,1)*b(1,1,k) + enddo + enddo + do k=1,dim3 + do j=2,dim2 + do l=1,dim4 + c(1,l,k)=c(1,l,k)+a(l,j)*b(1,j,k) + enddo + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do l=1,dim4 + do i=1,dim1 + c(i,l,1)=a(l,1)*b(i,1,1) + enddo + enddo + do j=2,dim2 + do l=1,dim4 + do i=1,dim1 + c(i,l,1)=c(i,l,1)+a(l,j)*b(i,j,1) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do l=1,dim4 + c(1,l,1)=a(l,1)*b(1,1,1) + enddo + do j=2,dim2 + do l=1,dim4 + c(1,l,1)=c(1,l,1)+a(l,j)*b(1,j,1) + enddo + enddo + endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine mttxzz +! +! Multiplication of a transposed complex rectangular matrix with a +! complex tensor of third order: +! a(j,l)*b(i,j,k) = c(i,l,k). +! +! Input-variables: a - complex matrix +! b - complex tensor of third order +! Output-variables: c - resulting complex tensor +!----------------------------------------------------------------------- + + subroutine mttxzz (a,b,c,dim1,dim2,dim3,dim4) + + implicit none + + integer(long) :: i, j, k, l + integer(long), intent(in) :: dim1, dim2, & + dim3, dim4 + complex(dop), dimension(dim2,dim4), intent(in) :: a + complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b + complex(dop), dimension(dim1,dim4,dim3), intent(out) :: c + + If (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim4 + do i=1,dim1 + c(i,l,k)=a(1,l)*b(i,1,k) + enddo + enddo + enddo + do k=1,dim3 + do l=1,dim4 + do j=2,dim2 + do i=1,dim1 + c(i,l,k)=c(i,l,k)+a(j,l)*b(i,j,k) + enddo + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim4 + c(1,l,k)=a(1,l)*b(1,1,k) + enddo + enddo + do k=1,dim3 + do l=1,dim4 + do j=2,dim2 + c(1,l,k)=c(1,l,k)+a(j,l)*b(1,j,k) + enddo + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do l=1,dim4 + do i=1,dim1 + c(i,l,1)=a(1,l)*b(i,1,1) + enddo + enddo + do l=1,dim4 + do j=2,dim2 + do i=1,dim1 + c(i,l,1)=c(i,l,1)+a(j,l)*b(i,j,1) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do l=1,dim4 + c(1,l,1)=a(1,l)*b(1,1,1) + enddo + do l=1,dim4 + do j=2,dim2 + c(1,l,1)=c(1,l,1)+a(j,l)*b(1,j,1) + enddo + enddo + endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine mttxdd +! +! Multiplication of a transposed real rectangular matrix with a +! real tensor of third order: +! a(j,l)*b(i,j,k) = c(i,l,k). +! +! Input-variables: a - real matrix +! b - real tensor of third order +! Output-variables: c - resulting real tensor +!----------------------------------------------------------------------- + + subroutine mttxdd (a,b,c,dim1,dim2,dim3,dim4) + + implicit none + + integer(long) :: i, j, k, l + integer(long), intent(in) :: dim1, dim2, & + dim3, dim4 + real(dop), dimension(dim2,dim4), intent(in) :: a + real(dop), dimension(dim1,dim2,dim3), intent(in) :: b + real(dop), dimension(dim1,dim4,dim3), intent(out) :: c + + If (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim4 + do i=1,dim1 + c(i,l,k)=a(1,l)*b(i,1,k) + enddo + enddo + enddo + do k=1,dim3 + do l=1,dim4 + do j=2,dim2 + do i=1,dim1 + c(i,l,k)=c(i,l,k)+a(j,l)*b(i,j,k) + enddo + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim4 + c(1,l,k)=a(1,l)*b(1,1,k) + enddo + enddo + do k=1,dim3 + do l=1,dim4 + do j=2,dim2 + c(1,l,k)=c(1,l,k)+a(j,l)*b(1,j,k) + enddo + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do l=1,dim4 + do i=1,dim1 + c(i,l,1)=a(1,l)*b(i,1,1) + enddo + enddo + do l=1,dim4 + do j=2,dim2 + do i=1,dim1 + c(i,l,1)=c(i,l,1)+a(j,l)*b(i,j,1) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do l=1,dim4 + c(1,l,1)=a(1,l)*b(1,1,1) + enddo + do l=1,dim4 + do j=2,dim2 + c(1,l,1)=c(1,l,1)+a(j,l)*b(1,j,1) + enddo + enddo + endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine mttxdr +! +! Multiplication of a transposed real rectangular matrix with a +! real tensor of third order: +! a(j,l)*b(i,j,k) = c(i,l,k). +! +! Input-variables: a - real matrix +! b - real tensor of third order +! Output-variables: c - resulting real tensor +!----------------------------------------------------------------------- + + subroutine mttxdr (a,b,c,dim1,dim2,dim3,dim4) + + implicit none + + integer(long) :: i, j, k, l + integer(long), intent(in) :: dim1, dim2, & + dim3, dim4 + real(sip), dimension(dim1,dim2,dim3), intent(in) :: b + real(dop), dimension(dim2,dim4), intent(in) :: a + real(dop), dimension(dim1,dim4,dim3), intent(out) :: c + + If (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim4 + do i=1,dim1 + c(i,l,k)=a(1,l)*b(i,1,k) + enddo + enddo + enddo + do k=1,dim3 + do l=1,dim4 + do j=2,dim2 + do i=1,dim1 + c(i,l,k)=c(i,l,k)+a(j,l)*b(i,j,k) + enddo + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim4 + c(1,l,k)=a(1,l)*b(1,1,k) + enddo + enddo + do k=1,dim3 + do l=1,dim4 + do j=2,dim2 + c(1,l,k)=c(1,l,k)+a(j,l)*b(1,j,k) + enddo + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do l=1,dim4 + do i=1,dim1 + c(i,l,1)=a(1,l)*b(i,1,1) + enddo + enddo + do l=1,dim4 + do j=2,dim2 + do i=1,dim1 + c(i,l,1)=c(i,l,1)+a(j,l)*b(i,j,1) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do l=1,dim4 + c(1,l,1)=a(1,l)*b(1,1,1) + enddo + do l=1,dim4 + do j=2,dim2 + c(1,l,1)=c(1,l,1)+a(j,l)*b(1,j,1) + enddo + enddo + endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine mtxxdd +! +! Multiplication of a real rectangular matrix with a real tensor +! of third order: +! a(l,j)*b(i,j,k) = c(i,l,k) . +! +! Input-variables: a - real matrix +! b - real tensor of third order +! Output-variables: c - resulting real tensor +!----------------------------------------------------------------------- + + subroutine mtxxdd (a,b,c,dim1,dim2,dim3,dim4) + + implicit none + + integer(long) :: i, j, k, l + integer(long), intent(in) :: dim1, dim2, & + dim3, dim4 + real(dop), dimension(dim4,dim2), intent(in) :: a + real(dop), dimension(dim1,dim2,dim3), intent(in) :: b + real(dop), dimension(dim1,dim4,dim3), intent(out) :: c + + If (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim4 + do i=1,dim1 + c(i,l,k)=a(l,1)*b(i,1,k) + enddo + enddo + enddo + do k=1,dim3 + do j=2,dim2 + do l=1,dim4 + do i=1,dim1 + c(i,l,k)=c(i,l,k)+a(l,j)*b(i,j,k) + enddo + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim4 + c(1,l,k)=a(l,1)*b(1,1,k) + enddo + enddo + do k=1,dim3 + do j=2,dim2 + do l=1,dim4 + c(1,l,k)=c(1,l,k)+a(l,j)*b(1,j,k) + enddo + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do l=1,dim4 + do i=1,dim1 + c(i,l,1)=a(l,1)*b(i,1,1) + enddo + enddo + do j=2,dim2 + do l=1,dim4 + do i=1,dim1 + c(i,l,1)=c(i,l,1)+a(l,j)*b(i,j,1) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do l=1,dim4 + c(1,l,1)=a(l,1)*b(1,1,1) + enddo + do j=2,dim2 + do l=1,dim4 + c(1,l,1)=c(1,l,1)+a(l,j)*b(1,j,1) + enddo + enddo + endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine mtaxzz +! +! Multiplication of the adjoint of a complex rectangular matrix with a +! complex tensor of third order: +! dconj(a(j,l))*b(i,j,k) = c(i,l,k). +! +! Input-variables: a - complex matrix +! b - complex tensor of third order +! Output-variables: c - resulting complex tensor +!----------------------------------------------------------------------- + + subroutine mtaxzz (a,b,c,dim1,dim2,dim3,dim4) + + implicit none + + integer(long) :: i, j, k, l + integer(long), intent(in) :: dim1, dim2, & + dim3, dim4 + complex(dop), dimension(dim2,dim4), intent(in) :: a + complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b + complex(dop), dimension(dim1,dim4,dim3), intent(out) :: c + + If (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim4 + do i=1,dim1 + c(i,l,k)=dconjg(a(1,l))*b(i,1,k) + enddo + enddo + enddo + do k=1,dim3 + do l=1,dim4 + do j=2,dim2 + do i=1,dim1 + c(i,l,k)=c(i,l,k)+dconjg(a(j,l))*b(i,j,k) + enddo + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim4 + c(1,l,k)=dconjg(a(1,l))*b(1,1,k) + enddo + enddo + do k=1,dim3 + do l=1,dim4 + do j=2,dim2 + c(1,l,k)=c(1,l,k)+dconjg(a(j,l))*b(1,j,k) + enddo + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do l=1,dim4 + do i=1,dim1 + c(i,l,1)=dconjg(a(1,l))*b(i,1,1) + enddo + enddo + do l=1,dim4 + do j=2,dim2 + do i=1,dim1 + c(i,l,1)=c(i,l,1)+dconjg(a(j,l))*b(i,j,1) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do l=1,dim4 + c(1,l,1)=dconjg(a(1,l))*b(1,1,1) + enddo + do l=1,dim4 + do j=2,dim2 + c(1,l,1)=c(1,l,1)+dconjg(a(j,l))*b(1,j,1) + enddo + enddo + endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine qtxxdd +! +! Multiplication of a real quadratic matrix with a real tensor +! of third order: +! a(l,j)*b(i,j,k) = c(i,l,k) . +! +! Input-variables: a - real matrix +! b - real tensor of third order +! Output-variables: c - resulting real tensor +!----------------------------------------------------------------------- + + subroutine qtxxdd (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k, l + integer(long), intent(in) :: dim1, dim2, & + dim3 + real(dop), dimension(dim2,dim2), intent(in) :: a + real(dop), dimension(dim1,dim2,dim3), intent(in) :: b + real(dop), dimension(dim1,dim2,dim3), intent(out) :: c + + if (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim2 + do i=1,dim1 + c(i,l,k)=a(l,1)*b(i,1,k) + enddo + enddo + enddo + do k=1,dim3 + do j=2,dim2 + do l=1,dim2 + do i=1,dim1 + c(i,l,k)=c(i,l,k)+a(l,j)*b(i,j,k) + enddo + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim2 + c(1,l,k)=a(l,1)*b(1,1,k) + enddo + enddo + do k=1,dim3 + do j=2,dim2 + do l=1,dim2 + c(1,l,k)=c(1,l,k)+a(l,j)*b(1,j,k) + enddo + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do l=1,dim2 + do i=1,dim1 + c(i,l,1)=a(l,1)*b(i,1,1) + enddo + enddo + do j=2,dim2 + do l=1,dim2 + do i=1,dim1 + c(i,l,1)=c(i,l,1)+a(l,j)*b(i,j,1) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do l=1,dim2 + c(1,l,1)=a(l,1)*b(1,1,1) + enddo + do j=2,dim2 + do l=1,dim2 + c(1,l,1)=c(1,l,1)+a(l,j)*b(1,j,1) + enddo + enddo + endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine qtcxzz + +! Multiplication of the complex conjugate of a complex quadratic matrix +! with a complex tensor of third order: +! dconjg(a(l,j))*b(i,j,k) = c(i,l,k) . + +! Input-variables: a - complex matrix +! b - complex tensor of third order +! Output-variables: c - resulting complex tensor +!----------------------------------------------------------------------- + + subroutine qtcxzz (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k, l + integer(long), intent(in) :: dim1, dim2, & + dim3 + complex(dop), dimension(dim2,dim2), intent(in) :: a + complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b + complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c + + if (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim2 + do i=1,dim1 + c(i,l,k)=dconjg(a(l,1))*b(i,1,k) + enddo + enddo + enddo + do k=1,dim3 + do j=2,dim2 + do l=1,dim2 + do i=1,dim1 + c(i,l,k)=c(i,l,k)+dconjg(a(l,j))*b(i,j,k) + enddo + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim2 + c(1,l,k)=dconjg(a(l,1))*b(1,1,k) + enddo + enddo + do k=1,dim3 + do j=2,dim2 + do l=1,dim2 + c(1,l,k)=c(1,l,k)+dconjg(a(l,j))*b(1,j,k) + enddo + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do l=1,dim2 + do i=1,dim1 + c(i,l,1)=dconjg(a(l,1))*b(i,1,1) + enddo + enddo + do j=2,dim2 + do l=1,dim2 + do i=1,dim1 + c(i,l,1)=c(i,l,1)+dconjg(a(l,j))*b(i,j,1) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do l=1,dim2 + c(1,l,1)=dconjg(a(l,1))*b(1,1,1) + enddo + do j=2,dim2 + do l=1,dim2 + c(1,l,1)=c(1,l,1)+dconjg(a(l,j))*b(1,j,1) + enddo + enddo + endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine qttxdd +! +! Multiplication of a transposed real quadratic matrix with a +! real tensor of third order: +! a(j,l)*b(i,j,k) = c(i,l,k). +! +! Input-variables: a - real matrix +! b - real tensor of third order +! Output-variables: c - resulting real tensor +!----------------------------------------------------------------------- + + subroutine qttxdd (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k, l + integer(long), intent(in) :: dim1, dim2, & + dim3 + real(dop), dimension(dim2,dim2), intent(in) :: a + real(dop), dimension(dim1,dim2,dim3), intent(in) :: b + real(dop), dimension(dim1,dim2,dim3), intent(out) :: c + + If (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim2 + do i=1,dim1 + c(i,l,k)=a(1,l)*b(i,1,k) + enddo + enddo + enddo + do k=1,dim3 + do l=1,dim2 + do j=2,dim2 + do i=1,dim1 + c(i,l,k)=c(i,l,k)+a(j,l)*b(i,j,k) + enddo + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim2 + c(1,l,k)=a(1,l)*b(1,1,k) + enddo + enddo + do k=1,dim3 + do l=1,dim2 + do j=2,dim2 + c(1,l,k)=c(1,l,k)+a(j,l)*b(1,j,k) + enddo + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do l=1,dim2 + do i=1,dim1 + c(i,l,1)=a(1,l)*b(i,1,1) + enddo + enddo + do l=1,dim2 + do j=2,dim2 + do i=1,dim1 + c(i,l,1)=c(i,l,1)+a(j,l)*b(i,j,1) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do l=1,dim2 + c(1,l,1)=a(1,l)*b(1,1,1) + enddo + do l=1,dim2 + do j=2,dim2 + c(1,l,1)=c(1,l,1)+a(j,l)*b(1,j,1) + enddo + enddo + endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine dtxxzz +! +! Multiplication of a complex diagonal matrix with a complex tensor +! of third order. Only diagonal matrix elements are given as a vector: +! a(j)*b(i,j,k) = c(i,j,k) . +! +! Input-variables: a - complex vector with diagonal matrix elements +! b - complex tensor of third order +! Output-variables: c - resulting complex tensor +!----------------------------------------------------------------------- + + subroutine dtxxzz (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2, & + dim3 + complex(dop), dimension(dim2), intent(in) :: a + complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b + complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c + + if (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do i=1,dim1 + c(i,j,k)=a(j)*b(i,j,k) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + c(1,j,k)=a(j)*b(1,j,k) + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do j=1,dim2 + do i=1,dim1 + c(i,j,1)=a(j)*b(i,j,1) + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do j=1,dim2 + c(1,j,1)=a(j)*b(1,j,1) + enddo + endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine dtxxzzo +! +! Multiplication of a complex diagonal matrix with a complex tensor +! of third order. Only diagonal matrix elements are given as a vector, +! and the result is stored in the input tensor: +! a(j)*b(i,j,k) = b(i,j,k) . +! +! Input-variables: a - complex vector with diagonal matrix elements +! b - complex tensor of third order +! Output-variables: b - resulting complex tensor +!----------------------------------------------------------------------- + + subroutine dtxxzzo (a,b,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2, & + dim3 + complex(dop), dimension(dim2), intent(in) :: a + complex(dop), dimension(dim1,dim2,dim3), intent(inout) :: b + + if (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do i=1,dim1 + b(i,j,k)=a(j)*b(i,j,k) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + b(1,j,k)=a(j)*b(1,j,k) + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do j=1,dim2 + do i=1,dim1 + b(i,j,1)=a(j)*b(i,j,1) + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do j=1,dim2 + b(1,j,1)=a(j)*b(1,j,1) + enddo + endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine dtxxzzr +! +! Multiplication of a complex diagonal matrix with a complex tensor +! of third order and subtracted from a different tensor: +! c(i,l,k) - a(j)*b(i,j,k) = c(i,l,k). +! +! Input-variables: a - complex vector with diagonal matrix elements +! b - complex tensor of third order +! c - complex tensor of third order +! Output-variables: c - resulting complex tensor +!----------------------------------------------------------------------- + + subroutine dtxxzzr (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2, & + dim3 + complex(dop), dimension(dim2), intent(in) :: a + complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b + complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c + + if (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do i=1,dim1 + c(i,j,k)=c(i,j,k)-a(j)*b(i,j,k) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + c(1,j,k)=c(1,j,k)-a(j)*b(1,j,k) + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do j=1,dim2 + do i=1,dim1 + c(i,j,1)=c(i,j,1)-a(j)*b(i,j,1) + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do j=1,dim2 + c(1,j,1)=c(1,j,1)-a(j)*b(1,j,1) + enddo + endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine dtxxdd +! +! Multiplication of a real diagonal matrix with a real tensor +! of third order. Only diagonal matrix elements are given as a vector: +! a(j)*b(i,j,k) = c(i,j,k) . +! +! Input-variables: a - real vector with diagonal matrix elements +! b - real tensor of third order +! Output-variables: c - resulting real tensor +!----------------------------------------------------------------------- + + subroutine dtxxdd (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2, & + dim3 + real(dop), dimension(dim2), intent(in) :: a + real(dop), dimension(dim1,dim2,dim3), intent(in) :: b + real(dop), dimension(dim1,dim2,dim3), intent(out) :: c + + if (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do i=1,dim1 + c(i,j,k)=a(j)*b(i,j,k) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + c(1,j,k)=a(j)*b(1,j,k) + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do j=1,dim2 + do i=1,dim1 + c(i,j,1)=a(j)*b(i,j,1) + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do j=1,dim2 + c(1,j,1)=a(j)*b(1,j,1) + enddo + endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine dtxxddo +! +! Multiplication of a real diagonal matrix with a real tensor +! of third order. Only diagonal matrix elements are given as a vector, +! and the result is stored in the input tensor: +! a(j)*b(i,j,k) = b(i,j,k) . +! +! Input-variables: a - real vector with diagonal matrix elements +! b - real tensor of third order +! Output-variables: b - resulting real tensor +!----------------------------------------------------------------------- + + subroutine dtxxddo (a,b,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2, & + dim3 + real(dop), dimension(dim2), intent(in) :: a + real(dop), dimension(dim1,dim2,dim3), intent(out) :: b + + if (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do i=1,dim1 + b(i,j,k)=a(j)*b(i,j,k) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + b(1,j,k)=a(j)*b(1,j,k) + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do j=1,dim2 + do i=1,dim1 + b(i,j,1)=a(j)*b(i,j,1) + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do j=1,dim2 + b(1,j,1)=a(j)*b(1,j,1) + enddo + endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine dtxxdz +! +! Multiplication of a real diagonal matrix with a complex tensor +! of third order. Only diagonal matrix elements are given as a vector: +! a(j)*b(i,j,k) = c(i,j,k) . +! +! Input-variables: a - real vector with diagonal matrix elements +! b - complex tensor of third order +! Output-variables: c - resulting complex tensor +!----------------------------------------------------------------------- + + subroutine dtxxdz (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2, & + dim3 + real(dop), dimension(dim2), intent(in) :: a + complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b + complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c + + if (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do i=1,dim1 + c(i,j,k)=a(j)*b(i,j,k) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + c(1,j,k)=a(j)*b(1,j,k) + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do j=1,dim2 + do i=1,dim1 + c(i,j,1)=a(j)*b(i,j,1) + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do j=1,dim2 + c(1,j,1)=a(j)*b(1,j,1) + enddo + endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine dtxxdzo +! +! Multiplication of a real diagonal matrix with a complex tensor +! of third order. Only diagonal matrix elements are given as a vector, +! and the result is stored in the input tensor: +! a(j)*b(i,j,k) = b(i,j,k) . +! +! Input-variables: a - complex vector with diagonal matrix elements +! b - complex tensor of third order +! Output-variables: b - resulting complex tensor +!----------------------------------------------------------------------- + + subroutine dtxxdzo (a,b,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2, & + dim3 + real(dop), dimension(dim2), intent(in) :: a + complex(dop), dimension(dim1,dim2,dim3), intent(out) :: b + + if (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do i=1,dim1 + b(i,j,k)=a(j)*b(i,j,k) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + b(1,j,k)=a(j)*b(1,j,k) + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do j=1,dim2 + do i=1,dim1 + b(i,j,1)=a(j)*b(i,j,1) + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do j=1,dim2 + b(1,j,1)=a(j)*b(1,j,1) + enddo + endif + + return + end subroutine + + +!----------------------------------------------------------------------- +! Library subroutine qtaxzz +! +! Multiplication of the adjoint of a complex quadratic matrix with a +! complex tensor of third order: +! dconj(a(j,l))*b(i,j,k) = c(i,l,k). +! +! Input-variables: a - complex matrix +! b - complex tensor of third order +! Output-variables: c - resulting complex tensor +!----------------------------------------------------------------------- + + subroutine qtaxzz (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k, l + integer(long), intent(in) :: dim1, dim2, & + dim3 + complex(dop), dimension(dim2,dim2), intent(in) :: a + complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b + complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c + + If (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim2 + do i=1,dim1 + c(i,l,k)=dconjg(a(1,l))*b(i,1,k) + enddo + enddo + enddo + do k=1,dim3 + do l=1,dim2 + do j=2,dim2 + do i=1,dim1 + c(i,l,k)=c(i,l,k)+dconjg(a(j,l))*b(i,j,k) + enddo + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim2 + c(1,l,k)=dconjg(a(1,l))*b(1,1,k) + enddo + enddo + do k=1,dim3 + do l=1,dim2 + do j=2,dim2 + c(1,l,k)=c(1,l,k)+dconjg(a(j,l))*b(1,j,k) + enddo + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do l=1,dim2 + do i=1,dim1 + c(i,l,1)=dconjg(a(1,l))*b(i,1,1) + enddo + enddo + do l=1,dim2 + do j=2,dim2 + do i=1,dim1 + c(i,l,1)=c(i,l,1)+dconjg(a(j,l))*b(i,j,1) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do l=1,dim2 + c(1,l,1)=dconjg(a(1,l))*b(1,1,1) + enddo + do l=1,dim2 + do j=2,dim2 + c(1,l,1)=c(1,l,1)+dconjg(a(j,l))*b(1,j,1) + enddo + enddo + endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine qtxxdz +! +! Multiplication of a real quadratic matrix with a complex tensor +! of third order: +! a(l,j)*b(i,j,k) = c(i,l,k). +! +! Input-variables: a - real matrix +! b - complex tensor of third order +! Output-variables: c - resulting complex tensor +!----------------------------------------------------------------------- + + subroutine qtxxdz (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k, l + integer(long), intent(in) :: dim1, dim2, & + dim3 + real(dop), dimension(dim2,dim2), intent(in) :: a + complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b + complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c + + if (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim2 + do i=1,dim1 + c(i,l,k)=a(l,1)*b(i,1,k) + enddo + enddo + enddo + do k=1,dim3 + do j=2,dim2 + do l=1,dim2 + do i=1,dim1 + c(i,l,k)=c(i,l,k)+a(l,j)*b(i,j,k) + enddo + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim2 + c(1,l,k)=a(l,1)*b(1,1,k) + enddo + enddo + do k=1,dim3 + do j=2,dim2 + do l=1,dim2 + c(1,l,k)=c(1,l,k)+a(l,j)*b(1,j,k) + enddo + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do l=1,dim2 + do i=1,dim1 + c(i,l,1)=a(l,1)*b(i,1,1) + enddo + enddo + do j=2,dim2 + do l=1,dim2 + do i=1,dim1 + c(i,l,1)=c(i,l,1)+a(l,j)*b(i,j,1) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do l=1,dim2 + c(1,l,1)=a(l,1)*b(1,1,1) + enddo + do j=2,dim2 + do l=1,dim2 + c(1,l,1)=c(1,l,1)+a(l,j)*b(1,j,1) + enddo + enddo + endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine qtxxdza +! +! Multiplication of a real quadratic matrix with a complex tensor +! of third order: +! a(l,j)*b(i,j,k) + c(i,l,k) = c(i,l,k). +! +! Input-variables: a - real matrix +! b - complex tensor of third order +! Output-variables: c - resulting complex tensor +!----------------------------------------------------------------------- + + subroutine qtxxdza (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k, l + integer(long), intent(in) :: dim1, dim2, & + dim3 + real(dop), dimension(dim2,dim2), intent(in) :: a + complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b + complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c + + if (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do l=1,dim2 + do i=1,dim1 + c(i,l,k)=c(i,l,k)+a(l,j)*b(i,j,k) + enddo + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do l=1,dim2 + c(1,l,k)=c(1,l,k)+a(l,j)*b(1,j,k) + enddo + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do j=1,dim2 + do l=1,dim2 + do i=1,dim1 + c(i,l,1)=c(i,l,1)+a(l,j)*b(i,j,1) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do j=1,dim2 + do l=1,dim2 + c(1,l,1)=c(1,l,1)+a(l,j)*b(1,j,1) + enddo + enddo + endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine qt1xxdz +! +! Multiplication of a real quadratic matrix with the first index of a +! complex tensor of third order: +! a(l,i)*b(i,j,k) = c(l,j,k) . +! +! Input-variables: a - real matrix +! b - complex tensor of third order +! Output-variables: c - resulting complex tensor +!----------------------------------------------------------------------- + + subroutine qt1xxdz (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k, l + integer(long), intent(in) :: dim1, dim2, & + dim3 + real(dop), dimension(dim1,dim1), intent(in) :: a + complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b + complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c + + if (dim2.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do l=1,dim1 + c(l,j,k)=a(l,1)*b(1,j,k) + enddo + enddo + enddo + do k=1,dim3 + do j=1,dim2 + do i=2,dim1 + do l=1,dim1 + c(l,j,k)=c(l,j,k)+a(l,i)*b(i,j,k) + enddo + enddo + enddo + enddo + else if (dim2.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim1 + c(l,1,k)=a(l,1)*b(1,1,k) + enddo + enddo + do k=1,dim3 + do i=2,dim1 + do l=1,dim1 + c(l,1,k)=c(l,1,k)+a(l,i)*b(i,1,k) + enddo + enddo + enddo + else if (dim2.ne.1 .and. dim3.eq.1) then + do j=1,dim2 + do l=1,dim1 + c(l,j,1)=a(l,1)*b(1,j,1) + enddo + enddo + do j=1,dim2 + do i=2,dim1 + do l=1,dim1 + c(l,j,1)=c(l,j,1)+a(l,i)*b(i,j,1) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do l=1,dim1 + c(l,1,1)=a(l,1)*b(1,1,1) + enddo + do i=2,dim1 + do l=1,dim1 + c(l,1,1)=c(l,1,1)+a(l,i)*b(i,1,1) + enddo + enddo + endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine dt1xxzz +! +! Multiplication of a complex diagonal matrix with the first index of a +! complex tensor of third order. Only diagonal matrix elements are +! supplied as vector: +! a(i)*b(i,j,k) = c(i,j,k) . +! +! Input-variables: a - complex matrix +! b - complex tensor of third order +! Output-variables: c - resulting complex tensor +!----------------------------------------------------------------------- + + subroutine dt1xxzz (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2, & + dim3 + complex(dop), dimension(dim1), intent(in) :: a + complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b + complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c + + + if (dim2.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do i=1,dim1 + c(i,j,k)=a(i)*b(i,j,k) + enddo + enddo + enddo + else if (dim2.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do i=1,dim1 + c(i,1,k)=a(i)*b(i,1,k) + enddo + enddo + else if (dim2.ne.1 .and. dim3.eq.1) then + do j=1,dim2 + do i=1,dim1 + c(i,j,1)=a(i)*b(i,j,1) + enddo + enddo + else if (dim2.eq.1 .and. dim3.eq.1) then + do i=1,dim1 + c(i,1,1)=a(i)*b(i,1,1) + enddo + endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine qt1txdz +! +! Multiplication of a transposed real quadratic matrix with the +! first index of a complex tensor of third order: +! a(i,l)*b(i,j,k) = c(l,j,k) . +! +! Input-variables: a - real matrix +! b - complex tensor of third order +! Output-variables: c - resulting complex tensor +!----------------------------------------------------------------------- + + subroutine qt1txdz (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k, l + integer(long), intent(in) :: dim1, dim2, & + dim3 + real(dop), dimension(dim1,dim1), intent(in) :: a + complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b + complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c + + if (dim2.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do l=1,dim1 + c(l,j,k)=a(1,l)*b(1,j,k) + enddo + enddo + enddo + do k=1,dim3 + do j=1,dim2 + do l=1,dim1 + do i=2,dim1 + c(l,j,k)=c(l,j,k)+a(i,l)*b(i,j,k) + enddo + enddo + enddo + enddo + else if (dim2.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim1 + c(l,1,k)=a(1,l)*b(1,1,k) + enddo + enddo + do k=1,dim3 + do l=1,dim1 + do i=2,dim1 + c(l,1,k)=c(l,1,k)+a(i,l)*b(i,1,k) + enddo + enddo + enddo + else if (dim2.ne.1 .and. dim3.eq.1) then + do j=1,dim2 + do l=1,dim1 + c(l,j,1)=a(1,l)*b(1,j,1) + enddo + enddo + do j=1,dim2 + do l=1,dim1 + do i=2,dim1 + c(l,j,1)=c(l,j,1)+a(i,l)*b(i,j,1) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do l=1,dim1 + c(l,1,1)=a(1,l)*b(1,1,1) + enddo + do l=1,dim1 + do i=2,dim1 + c(l,1,1)=c(l,1,1)+a(i,l)*b(i,1,1) + enddo + enddo + endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine qttxdz +! +! Multiplication of a transposed real quadratic matrix with a +! complex tensor of third order: +! a(j,l)*b(i,j,k) = c(i,l,k). +! +! Input-variables: a - real matrix +! b - complex tensor of third order +! Output-variables: c - resulting complex tensor +!----------------------------------------------------------------------- + + subroutine qttxdz (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k, l + integer(long), intent(in) :: dim1, dim2, & + dim3 + real(dop), dimension(dim2,dim2), intent(in) :: a + complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b + complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c + + If (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim2 + do i=1,dim1 + c(i,l,k)=a(1,l)*b(i,1,k) + enddo + enddo + enddo + do k=1,dim3 + do l=1,dim2 + do j=2,dim2 + do i=1,dim1 + c(i,l,k)=c(i,l,k)+a(j,l)*b(i,j,k) + enddo + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim2 + c(1,l,k)=a(1,l)*b(1,1,k) + enddo + enddo + do k=1,dim3 + do l=1,dim2 + do j=2,dim2 + c(1,l,k)=c(1,l,k)+a(j,l)*b(1,j,k) + enddo + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do l=1,dim2 + do i=1,dim1 + c(i,l,1)=a(1,l)*b(i,1,1) + enddo + enddo + do l=1,dim2 + do j=2,dim2 + do i=1,dim1 + c(i,l,1)=c(i,l,1)+a(j,l)*b(i,j,1) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do l=1,dim2 + c(1,l,1)=a(1,l)*b(1,1,1) + enddo + do l=1,dim2 + do j=2,dim2 + c(1,l,1)=c(1,l,1)+a(j,l)*b(1,j,1) + enddo + enddo + endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine qt1xxzz +! +! Multiplication of a real quadratic matrix with the first index of a +! complex tensor of third order: +! a(l,i)*b(i,j,k) = c(l,j,k) . +! +! Input-variables: a - real matrix +! b - complex tensor of third order +! Output-variables: c - resulting complex tensor +!----------------------------------------------------------------------- + +! subroutine qt1xxzz (a,b,c,dim1,dim2,dim3) + +! implicit none + +! integer(long) :: i, j, k, l +! integer(long), intent(in) :: dim1, dim2, & +! dim3 +! complex(dop), dimension(dim1,dim1), intent(in) :: a +! complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b +! complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c + +! if (dim2.ne.1 .and. dim3.ne.1) then +! do k=1,dim3 +! do j=1,dim2 +! do l=1,dim1 +! c(l,j,k)=a(l,1)*b(1,j,k) +! enddo +! enddo +! enddo +! do k=1,dim3 +! do j=1,dim2 +! do i=2,dim1 +! do l=1,dim1 +! c(l,j,k)=c(l,j,k)+a(l,i)*b(i,j,k) +! enddo +! enddo +! enddo +! enddo +! else if (dim2.eq.1 .and. dim3.ne.1) then +! do k=1,dim3 +! do l=1,dim1 +! c(l,1,k)=a(l,1)*b(1,1,k) +! enddo +! enddo +! do k=1,dim3 +! do i=2,dim1 +! do l=1,dim1 +! c(l,1,k)=c(l,1,k)+a(l,i)*b(i,1,k) +! enddo +! enddo +! enddo +! else if (dim2.ne.1 .and. dim3.eq.1) then +! do j=1,dim2 +! do l=1,dim1 +! c(l,j,1)=a(l,1)*b(1,j,1) +! enddo +! enddo +! do j=1,dim2 +! do i=2,dim1 +! do l=1,dim1 +! c(l,j,1)=c(l,j,1)+a(l,i)*b(i,j,1) +! enddo +! enddo +! enddo +! else if (dim1.eq.1 .and. dim3.eq.1) then +! do l=1,dim1 +! c(l,1,1)=a(l,1)*b(1,1,1) +! enddo +! do i=2,dim1 +! do l=1,dim1 +! c(l,1,1)=c(l,1,1)+a(l,i)*b(i,1,1) +! enddo +! enddo +! endif + +! return +! end subroutine + +!----------------------------------------------------------------------- +! Library subroutine qttxzz +! +! Multiplication of a transposed complex quadratic matrix with a +! complex tensor of third order: +! a(j,l)*b(i,j,k) = c(i,l,k). +! +! Input-variables: a - real matrix +! b - real tensor of third order +! Output-variables: c - resulting real tensor +!----------------------------------------------------------------------- + + subroutine qttxzz (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k, l + integer(long), intent(in) :: dim1, dim2, & + dim3 + complex(dop), dimension(dim2,dim2), intent(in) :: a + complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b + complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c + + If (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim2 + do i=1,dim1 + c(i,l,k)=a(1,l)*b(i,1,k) + enddo + enddo + enddo + do k=1,dim3 + do l=1,dim2 + do j=2,dim2 + do i=1,dim1 + c(i,l,k)=c(i,l,k)+a(j,l)*b(i,j,k) + enddo + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim2 + c(1,l,k)=a(1,l)*b(1,1,k) + enddo + enddo + do k=1,dim3 + do l=1,dim2 + do j=2,dim2 + c(1,l,k)=c(1,l,k)+a(j,l)*b(1,j,k) + enddo + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do l=1,dim2 + do i=1,dim1 + c(i,l,1)=a(1,l)*b(i,1,1) + enddo + enddo + do l=1,dim2 + do j=2,dim2 + do i=1,dim1 + c(i,l,1)=c(i,l,1)+a(j,l)*b(i,j,1) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do l=1,dim2 + c(1,l,1)=a(1,l)*b(1,1,1) + enddo + do l=1,dim2 + do j=2,dim2 + c(1,l,1)=c(1,l,1)+a(j,l)*b(1,j,1) + enddo + enddo + endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine qtxxyz +! +! Multiplication of a complex quadratic matrix with a complex tensor +! of third order, where the complex matrix is stored as two real +! matrices: +! a(l,j)*b(i,j,k) = c(i,l,k). +! +! Input-variables: a - complex matrix +! b - complex tensor of third order +! Output-variables: c - resulting complex tensor +!----------------------------------------------------------------------- + + subroutine qtxxyz (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k, l + integer(long), intent(in) :: dim1, dim2, & + dim3 + real(dop), dimension(dim2,dim2,2), intent(in) :: a + complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b + complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c + + if (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim2 + do i=1,dim1 + c(i,l,k)=dcmplx(a(l,1,1),a(l,1,2))*b(i,1,k) + enddo + enddo + enddo + do k=1,dim3 + do j=2,dim2 + do l=1,dim2 + do i=1,dim1 + c(i,l,k)=c(i,l,k)+dcmplx(a(l,j,1),a(l,j,2))*b(i,j,k) + enddo + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim2 + c(1,l,k)=dcmplx(a(l,1,1),a(l,1,2))*b(1,1,k) + enddo + enddo + do k=1,dim3 + do j=2,dim2 + do l=1,dim2 + c(1,l,k)=c(1,l,k)+dcmplx(a(l,j,1),a(l,j,2))*b(1,j,k) + enddo + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do l=1,dim2 + do i=1,dim1 + c(i,l,1)=dcmplx(a(l,1,1),a(l,1,2))*b(i,1,1) + enddo + enddo + do j=2,dim2 + do l=1,dim2 + do i=1,dim1 + c(i,l,1)=c(i,l,1)+dcmplx(a(l,j,1),a(l,j,2))*b(i,j,1) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do l=1,dim2 + c(1,l,1)=dcmplx(a(l,1,1),a(l,1,2))*b(1,1,1) + enddo + do j=2,dim2 + do l=1,dim2 + c(1,l,1)=c(1,l,1)+dcmplx(a(l,j,1),a(l,j,2))*b(1,j,1) + enddo + enddo + endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine qttxyz +! +! Multiplication of the trabspose of a complex quadratic matrix with +! a complex tensor of third order, where the complex matrix is stored +! as two real matrices: +! a(j,l)*b(i,j,k) = c(i,l,k). +! +! Input-variables: a - complex matrix +! b - complex tensor of third order +! Output-variables: c - resulting complex tensor +!----------------------------------------------------------------------- + + subroutine qttxyz (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k, l + integer(long), intent(in) :: dim1, dim2, & + dim3 + real(dop), dimension(dim2,dim2,2), intent(in) :: a + complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b + complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c + + if (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim2 + do i=1,dim1 + c(i,l,k)=dcmplx(a(1,l,1),a(1,l,2))*b(i,1,k) + enddo + enddo + enddo + do k=1,dim3 + do j=2,dim2 + do l=1,dim2 + do i=1,dim1 + c(i,l,k)=c(i,l,k)+dcmplx(a(j,l,1),a(j,l,2))*b(i,j,k) + enddo + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do l=1,dim2 + c(1,l,k)=dcmplx(a(1,l,1),a(1,l,2))*b(1,1,k) + enddo + enddo + do k=1,dim3 + do j=2,dim2 + do l=1,dim2 + c(1,l,k)=c(1,l,k)+dcmplx(a(j,l,1),a(j,l,2))*b(1,j,k) + enddo + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do l=1,dim2 + do i=1,dim1 + c(i,l,1)=dcmplx(a(1,l,1),a(1,l,2))*b(i,1,1) + enddo + enddo + do j=2,dim2 + do l=1,dim2 + do i=1,dim1 + c(i,l,1)=c(i,l,1)+dcmplx(a(j,l,1),a(j,l,2))*b(i,j,1) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do l=1,dim2 + c(1,l,1)=dcmplx(a(1,l,1),a(1,l,2))*b(1,1,1) + enddo + do j=2,dim2 + do l=1,dim2 + c(1,l,1)=c(1,l,1)+dcmplx(a(j,l,1),a(j,l,2))*b(1,j,1) + enddo + enddo + endif + + return + end subroutine + + +!----------------------------------------------------------------------- +! Library subroutine dtxxyz +! +! Multiplication of a complex quadratic diagonal matrix with a complex +! tensor of third order, where the complex matrix is stored as two real +! matrices: +! a(j)*b(i,j,k) = c(i,l,k). +! +! Input-variables: a - complex matrix +! b - complex tensor of third order +! Output-variables: c - resulting complex tensor +!----------------------------------------------------------------------- + + subroutine dtxxyz (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2, & + dim3 + real(dop), dimension(dim2,2), intent(in) :: a + complex(dop), dimension(dim1,dim2,dim3), intent(in) :: b + complex(dop), dimension(dim1,dim2,dim3), intent(out) :: c + + if (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do i=1,dim1 + c(i,j,k)=dcmplx(a(j,1),a(j,2))*b(i,j,k) + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + c(1,j,k)=dcmplx(a(j,1),a(j,2))*b(1,j,k) + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do j=1,dim2 + do i=1,dim1 + c(i,j,1)=dcmplx(a(j,1),a(j,2))*b(i,j,1) + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do j=1,dim2 + c(1,j,1)=dcmplx(a(j,1),a(j,2))*b(1,j,1) + enddo + endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine qtxxzz_s +! +! Multiplication of a complex quadratic matrix with a complex tensor +! of third order. The tensor is not completely stored, and the indices +! are managed by the index tensors: +! index(i,j,k)=x +! index1(i,l,k)=x1 +! a(l,j)*b(x) = c(x1). +! +! Input-variables: a - complex matrix +! b - complex tensor of third order +! Output-variables: c - resulting complex tensor +!----------------------------------------------------------------------- + + subroutine qtxxzz_s (a,b,c,dim1,dim2,dim3,index,index1) + + implicit none + + integer(long) :: i, j, k, l, & + x, x1 + integer(long), intent(in) :: dim1, dim2, & + dim3 + integer(long), dimension(dim1,dim2,dim3), intent(in) :: index + integer(long), dimension(dim1,dim2,dim3), intent(in) :: index1 + complex(dop), dimension(dim2,dim2), intent(in) :: a + complex(dop), dimension(*), intent(in) :: b + complex(dop), dimension(*), intent(out) :: c + + do k=1,dim3 + do l=1,dim2 + do i=1,dim1 + x1=index1(i,l,k) + if (x1 .ne. 0) c(x1)=0.0d0 + enddo + enddo + enddo + + if (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do l=1,dim2 + do i=1,dim1 + x=index(i,j,k) + x1=index1(i,l,k) + if (x .ne. 0 .and. x1 .ne. 0) then + c(x1)=c(x1)+a(l,j)*b(x) + endif + enddo + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do l=1,dim2 + x=index(1,j,k) + x1=index1(1,l,k) + if (x .ne. 0 .and. x1 .ne. 0) then + c(x1)=c(x1)+a(l,j)*b(x) + endif + enddo + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do j=1,dim2 + do l=1,dim2 + do i=1,dim1 + x=index(i,j,1) + x1=index1(i,l,1) + if (x .ne. 0 .and. x1 .ne. 0) then + c(x1)=c(x1)+a(l,j)*b(x) + endif + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do j=1,dim2 + do l=1,dim2 + x=index(1,j,1) + x1=index1(1,l,1) + if (x .ne. 0 .and. x1 .ne. 0) then + c(x1)=c(x1)+a(l,j)*b(x) + endif + enddo + enddo + endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine mtxxzz_s +! +! Multiplication of a complex matrix with a complex tensor +! of third order. The tensor is not completely stored, and the indices +! are managed by the index tensors: +! index(i,j,k)=x +! index1(i,l,k)=x1 +! a(l,j)*b(x) = c(x1). +! +! Input-variables: a - complex matrix +! b - complex tensor of third order +! Output-variables: c - resulting complex tensor +!----------------------------------------------------------------------- + + subroutine mtxxzz_s (a,b,c,dim1,dim2,dim3,dim4,dim5,index,index1) + + implicit none + + integer(long) :: i, j, k, l, & + x, x1 + integer(long), intent(in) :: dim1, dim2, & + dim3, dim4, & + dim5 + integer(long), dimension(dim1,dim2,dim3), intent(in) :: index + integer(long), dimension(dim1,dim2,dim3), intent(in) :: index1 + complex(dop), dimension(dim5,dim4), intent(in) :: a + complex(dop), dimension(*), intent(in) :: b + complex(dop), dimension(*), intent(out) :: c + + do k=1,dim3 + do l=1,dim2 + do i=1,dim1 + x1=index1(i,l,k) + if (x1 .ne. 0) c(x1)=0.0d0 + enddo + enddo + enddo + + if (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim4 + do l=1,dim5 + do i=1,dim1 + x=index(i,j,k) + x1=index1(i,l,k) + if (x .ne. 0 .and. x1 .ne. 0) then + c(x1)=c(x1)+a(l,j)*b(x) + endif + enddo + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim4 + do l=1,dim5 + x=index(1,j,k) + x1=index1(1,l,k) + if (x .ne. 0 .and. x1 .ne. 0) then + c(x1)=c(x1)+a(l,j)*b(x) + endif + enddo + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do j=1,dim4 + do l=1,dim5 + do i=1,dim1 + x=index(i,j,1) + x1=index1(i,l,1) + if (x .ne. 0 .and. x1 .ne. 0) then + c(x1)=c(x1)+a(l,j)*b(x) + endif + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do j=1,dim4 + do l=1,dim5 + x=index(1,j,1) + x1=index1(1,l,1) + if (x .ne. 0 .and. x1 .ne. 0) then + c(x1)=c(x1)+a(l,j)*b(x) + endif + enddo + enddo + endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine qttxzz_s +! +! Multiplication of a transposed complex quadratic matrix with a +! complex tensor c of third order. The tensor is not completely stored, +! and the indices are managed by the index tensors: +! index(i,j,k)=x +! index1(i,l,k)=x1 +! a(j,l)*b(x) = c(x1). +! +! Input-variables: a - complex matrix +! b - complex tensor of third order +! Output-variables: c - resulting complex tensor +!----------------------------------------------------------------------- + + subroutine qttxzz_s (a,b,c,dim1,dim2,dim3,index,index1) + + implicit none + + integer(long) :: i, j, k, l, & + x, x1 + integer(long), intent(in) :: dim1, dim2, & + dim3 + integer(long), dimension(dim1,dim2,dim3), intent(in) :: index + integer(long), dimension(dim1,dim2,dim3), intent(in) :: index1 + complex(dop), dimension(dim2,dim2), intent(in) :: a + complex(dop), dimension(*), intent(in) :: b + complex(dop), dimension(*), intent(out) :: c + + do k=1,dim3 + do l=1,dim2 + do i=1,dim1 + x1=index1(i,l,k) + if (x1 .ne. 0) c(x1)=0.0d0 + enddo + enddo + enddo + + if (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do l=1,dim2 + do i=1,dim1 + x=index(i,j,k) + x1=index1(i,l,k) + if (x .ne. 0 .and. x1 .ne. 0) then + c(x1)=c(x1)+a(j,l)*b(x) + endif + enddo + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do l=1,dim2 + x=index(1,j,k) + x1=index1(1,l,k) + if (x .ne. 0 .and. x1 .ne. 0) then + c(x1)=c(x1)+a(j,l)*b(x) + endif + enddo + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do j=1,dim2 + do l=1,dim2 + do i=1,dim1 + x=index(i,j,1) + x1=index1(i,l,1) + if (x .ne. 0 .and. x1 .ne. 0) then + c(x1)=c(x1)+a(j,l)*b(x) + endif + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do j=1,dim2 + do l=1,dim2 + x=index(1,j,1) + x1=index1(1,l,1) + if (x .ne. 0 .and. x1 .ne. 0) then + c(x1)=c(x1)+a(j,l)*b(x) + endif + enddo + enddo + endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine qtxxzza_s +! +! Multiplication of a complex quadratic matrix with a complex tensor +! of third order and added to a different tensor. The tensors are not +! completely stored, and the indices are managed by the index tensors: +! index(i,j,k)=x +! index1(i,l,k)=x1 +! a(l,j)*b(x) + c(x1) = c(x1). +! +! Input-variables: a - complex matrix +! b - complex tensor of third order +! Output-variables: c - resulting complex tensor +! +! NB tensor c is overwritten on output +!----------------------------------------------------------------------- + + subroutine qtxxzza_s (a,b,c,dim1,dim2,dim3,index,index1) + + implicit none + + integer(long) :: i, j, k, l, & + x, x1 + integer(long), intent(in) :: dim1, dim2, & + dim3 + integer(long), dimension(dim1,dim2,dim3), intent(in) :: index + integer(long), dimension(dim1,dim2,dim3), intent(in) :: index1 + complex(dop), dimension(dim2,dim2), intent(in) :: a + complex(dop), dimension(*), intent(in) :: b + complex(dop), dimension(*), intent(out) :: c + + if (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do l=1,dim2 + do i=1,dim1 + x=index(i,j,k) + x1=index1(i,l,k) + if (x .ne. 0 .and. x1 .ne. 0) then + c(x1)=c(x1)+a(l,j)*b(x) + endif + enddo + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do l=1,dim2 + x=index(1,j,k) + x1=index1(1,l,k) + if (x .ne. 0 .and. x1 .ne. 0) then + c(x1)=c(x1)+a(l,j)*b(x) + endif + enddo + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do j=1,dim2 + do l=1,dim2 + do i=1,dim1 + x=index(i,j,1) + x1=index1(i,l,1) + if (x .ne. 0 .and. x1 .ne. 0) then + c(x1)=c(x1)+a(l,j)*b(x) + endif + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do j=1,dim2 + do l=1,dim2 + x=index(1,j,1) + x1=index1(1,l,1) + if (x .ne. 0 .and. x1 .ne. 0) then + c(x1)=c(x1)+a(l,j)*b(x) + endif + enddo + enddo + endif + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine qtxxzzr_s +! +! Multiplication of a complex quadratic matrix with a complex tensor +! of third order and subtracted from a different tensor. The tensors are +! not completely stored, and the indices are managed by the index tensors: +! index(i,j,k)=x +! index1(i,l,k)=x1 +! c(x1) - a(l,j)*b(x) = c(x1). +! +! Input-variables: a - complex matrix +! b - complex tensor of third order +! Output-variables: c - resulting complex tensor +! +! NB tensor c is overwritten on output +!----------------------------------------------------------------------- + + subroutine qtxxzzr_s (a,b,c,dim1,dim2,dim3,index,index1) + + implicit none + + integer(long) :: i, j, k, l, & + x, x1 + integer(long), intent(in) :: dim1, dim2, & + dim3 + integer(long), dimension(dim1,dim2,dim3), intent(in) :: index + integer(long), dimension(dim1,dim2,dim3), intent(in) :: index1 + complex(dop), dimension(dim2,dim2), intent(in) :: a + complex(dop), dimension(*), intent(in) :: b + complex(dop), dimension(*), intent(out) :: c + + if (dim1.ne.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do l=1,dim2 + do i=1,dim1 + x=index(i,j,k) + x1=index1(i,l,k) + if (x .ne. 0 .and. x1 .ne. 0) then + c(x1)=c(x1)-a(l,j)*b(x) + endif + enddo + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.ne.1) then + do k=1,dim3 + do j=1,dim2 + do l=1,dim2 + x=index(1,j,k) + x1=index1(1,l,k) + if (x .ne. 0 .and. x1 .ne. 0) then + c(x1)=c(x1)-a(l,j)*b(x) + endif + enddo + enddo + enddo + else if (dim1.ne.1 .and. dim3.eq.1) then + do j=1,dim2 + do l=1,dim2 + do i=1,dim1 + x=index(i,j,1) + x1=index1(i,l,1) + if (x .ne. 0 .and. x1 .ne. 0) then + c(x1)=c(x1)-a(l,j)*b(x) + endif + enddo + enddo + enddo + else if (dim1.eq.1 .and. dim3.eq.1) then + do j=1,dim2 + do l=1,dim2 + x=index(1,j,1) + x1=index1(1,l,1) + if (x .ne. 0 .and. x1 .ne. 0) then + c(x1)=c(x1)-a(l,j)*b(x) + endif + enddo + enddo + endif + + return + end subroutine + + end module mtlib + + + + Index: source/lib/linear/op2lib.f90 =================================================================== --- source/lib/linear/op2lib.f90 (revision 854) +++ source/lib/linear/op2lib.f90 (revision 855) @@ -125,6 +125,7 @@ module op2lib use decimal, only: dop, long +use openmpmod implicit none private @@ -384,9 +385,11 @@ complex(dop), dimension(dim), intent(in) :: a complex(dop), dimension(dim), intent(inout) :: b +!$omp parallel do num_threads(ompthread) do i = 1,dim b(i) = a(i) + b(i) enddo +!$omp end parallel do return end subroutine addvxxzo Index: source/lib/linear/mmlib.F90 =================================================================== --- source/lib/linear/mmlib.F90 (revision 0) +++ source/lib/linear/mmlib.F90 (revision 855) @@ -0,0 +1,2266 @@ +! ********************************************************************** +! +! MMLIB +! +! Library module containing linear algebra routines that involve the +! multiplication of matrices +! +! Nomenclature: +! Each name has 6 basic characters: +! First 2 characters denote the objects being multiplied: +! q: quadratic matrix +! m: general (rectangular) matrix +! h: hermitian matrix +! p: positive definite matrix +! s: symmetric matrix +! u: unitary matrix +! d: diagonal matrix (only diagonal elements are supplied as a +! vector) +! t: tensor of third order +! v: vector +! x: scalar +! e.g. 'qm' denotes the operation (quadratic matrix * rectangular +! matrix) +! Character 3 denotes how first object is used: +! x: unchanged from input +! t: transpose of input +! a: adjoint of input +! c: complex conjugate of input +! v: as a vector +! Character 4 denotes how second object is used: +! see Character 3 above. +! Character 5, 6 denote data types of first, second object +! respectively: +! z: complex double precision (complex*16) +! c: complex single precision (complex*8) +! d: real double precision (real*8) +! r: real single precision (real*4) +! Further characters, if present, give more informaion: +! a: the result is added to a further object +! r: the result is subtracted (removed) from a further object +! c: the input matrices commute +! h: the resulting matrix is hermitian +! h1: the resulting matrix is anti-hermitian +! s: the resulting matrix is symmetric +! 1: the physical dimensions of the matrices differs from those +! used. +! +! Contents: +! In the following list of available subroutines, matrices on the LHS +! of the definition are input, that on the RHS output. The usual +! summation convention is used i.e. a sum is made over repeated indices +! on the LHS (NOTE: there is only elementwise multiplication and +! no subsequent summation if a diagonal matrix is involved !!!). +! +! qqxxdd (a,b,c,dim) +! Definition: a(j,k)*b(k,i) = c(j,i) . +! Dimensions: a(dim,dim),b(dim,dim),c(dim,dim) +! +! qqxxzd (a,b,c,dim) +! Definition: a(j,k)*b(k,i) = c(j,i) . +! Dimensions: a(dim,dim),b(dim,dim),c(dim,dim) +! +! mmxxzz (a,b,c,dim1,dim2,dim3) +! Definition: a(j,k)*b(k,i) = c(j,i) . +! Dimensions: a(dim1,dim2),b(dim2,dim3),c(dim1,dim3) +! +! mmvxzz (a,b,c,dim1,dim2,dim3,p) +! Definition: a(p,k)*b(k,i) = c(i) +! Dimensions: a(dim1,dim2),b(dim2,dim3),c(dim3) +! +! mmxtzz (a,b,c,dim1,dim2,dim3) +! Definition: a(j,k)*b(i,k) = c(j,i) . +! Dimensions: a(dim1,dim2),b(dim3,dim2),c(dim1,dim3) +! +! mmtczz (a,b,c,dim1,dim2,dim3) +! Definition: a(k,j)*dconjg(b(k,i)) = c(j,i) . +! Dimensions: a(dim1,dim2),b(dim1,dim3),c(dim2,dim3) +! +! mmxxzza (a,b,c,dim1,dim2,dim3) +! Definition: a(j,k)*b(k,i) + c(j,i) = c(j,i) . +! Dimensions: a(dim1,dim2),b(dim2,dim3),c(dim1,dim3) +! +! dmxxzz (a,b,c,dim1,dim2) +! Definition: a(j)*b(j,i) = c(j,i) . +! Dimensions: a(dim1),b(dim1,dim2),c(dim1,dim2) +! +! dmxxzza (a,b,c,dim1,dim2) +! Definition: a(j)*b(j,i) + c(j,i) = c(j,i) . +! Dimensions: a(dim1),b(dim1,dim2),c(dim1,dim2) +! +! dmxxdz (a,b,c,dim1,dim2) +! Definition: a(j)*b(j,i) = c(j,i) . +! Dimensions: a(dim1),b(dim1,dim2),c(dim1,dim2) +! +! dmxxdd (a,b,c,dim1,dim2) +! Definition: a(j)*b(j,i) = c(j,i) . +! Dimensions: a(dim1),b(dim1,dim2),c(dim1,dim2) +! +! ddxxdd (a,b,c,dim) +! Definition: a(j)*b(j) = c(j) . +! Dimensions: a(dim),b(dim),c(dim) +! +! ddxxdz (a,b,c,dim) +! Definition: a(j)*b(j) = c(j) . +! Dimensions: a(dim),b(dim),c(dim) +! +! dqxxzz (a,b,c,dim) +! Definition: a(j)*b(j,i) = c(j,i) . +! Dimensions: a(dim),b(dim,dim),c(dim,dim) +! +! dqxxdd (a,b,c,dim) +! Definition: a(j)*b(j,i) = c(j,i) . +! Dimensions: a(dim),b(dim,dim),c(dim,dim) +! +! dqxxdd1 (a,b,c,phdim,dim) +! Definition: a(j)*b(j,i) = c(j,i) . +! Dimensions: a(dim),b(phdim,dim),c(phdim,dim) +! +! dqxxdz (a,v,w,dim) +! Definition: a(i)*v(i,j) = w(i,j) . +! Dimensions: a(dim),v(dim,dim),w(dim,dim) +! +! dqxxdz2 (a,v,w,dim) +! Definition: a(j)*v(i,j) = w(i,j) . +! Dimensions: a(dim),v(dim,dim),w(dim,dim) +! +!C mmxxdz (a,b,c,dim1,dim2,dim3) +!C Definition: a(j,k)*b(k,i) = c(j,i) . +!C Dimensions: a(dim1,dim2),b(dim2,dim3),c(dim1,dim3) +! +! mmtxdd (a,b,c,dim1,dim2,dim3) +! Definition: a(k,j)*b(k,i) = c(j,i) . +! Dimensions: a(dim2,dim1),b(dim2,dim3),c(dim1,dim3) +! +! mmtxdd1 (a,b,c,phdim,dim1,dim2,dim3) +! Definition: a(k,j)*b(k,i) = c(j,i) . +! Dimensions: a(dim2,dim1),b(dim2,dim3),c(dim1,dim3) (= used dim.) +! Dimensions: a,b,c(phdim,phdim) (= allocated dimension) +! +! mmxtdd (a,b,c,dim1,dim2,dim3) +! Definition: a(j,k)*b(i,k) = c(j,i) . +! Dimensions: a(dim1,dim2),b(dim3,dim2),c(dim1,dim3) +! +! mmxxdd (a,b,c,dim1,dim2,dim3) +! Definition: a(j,k)*b(k,i) = c(j,i) . +! Dimensions: a(dim1,dim2),b(dim2,dim3),c(dim1,dim3) +! +! mmxxdd1 (a,b,c,phdim,dim1,dim2,dim3) +! Definition: a(j,k)*b(k,i) = c(j,i) . +! Dimensions: a(dim1,dim2),b(dim2,dim3),c(dim1,dim3) (= used dim.) +! Dimensions: a,b,c(phdim,phdim) (= allocated dimension) +! +! qqxtdd (a,b,c,dim) +! Definition: a(j,k)*b(i,k) = c(j,i) . +! Dimensions: a(dim,dim),b(dim,dim),c(dim,dim) +! +! qqxtdd1 (a,b,c,phdim,dim) +! Definition: a(j,k)*b(i,k) = c(j,i) ; 1 <= i,j,k <= dim . +! Dimensions: a(phdim,dim),b(phdim,dim),c(phdim,dim) +! +! qqtxdd (a,b,c,dim) +! Definition: a(k,j)*b(k,i) = c(j,i) . +! Dimensions: a(dim,dim),b(dim,dim),c(dim,dim) +! +! qdxxzz (a,b,c,dim) +! Definition: a(j,i)*b(i) = c(j,i) . +! Dimensions: a(dim,dim),b(dim),c(dim,dim) +! +! qdxxdd (a,b,c,dim) +! Definition: a(j,i)*b(i) = c(j,i) . +! Dimensions: a(dim,dim),b(dim),c(dim,dim) +! +! qdxxdd1 (a,b,c,phdim,dim) +! Definition: a(j,i)*b(i) = c(j,i) ; 1 <= i,j <= dim . +! Dimensions: a(phdim,dim),b(dim),c(phdim,dim) +! +! hhxtzzc (a,b,c,dim) +! Definition: a(j,k)*b(i,k) = c(j,i) . +! Dimensions: a(dim,dim),b(dim,dim),c(dim,dim) +! +! mmaxzzh (a,b,c,dim1,dim2) +! Definition: dconjg(a(k,j))*b(k,i) = c(j,i) . +! Dimensions: a(dim1,dim2),b(dim1,dim2),c(dim2,dim2) +! +! mmaxzzh1 (a,b,c,dim1,dim2) +! Definition: dconjg(a(k,j))*b(k,i) = c(j,i) . +! Dimensions: a(dim1,dim2),b(dim1,dim2),c(dim2,dim2) +! +! mmtxzzs (a,b,c,dim1,dim2) +! Definition: a(k,j)*b(k,i) = c(j,i) . +! Dimensions: a(dim1,dim2),b(dim1,dim2),c(dim2,dim2) +! +! qmxxzz (a,b,c,dim1,dim2) +! Definition: a(j,k)*b(k,i) = c(j,i) . +! Dimensions: a(dim1,dim1),b(dim1,dim2),c(dim1,dim2) +! +! qqxxdd1 (a,b,c,phdim,dim) +! Definition: a(j,k)*b(k,i) = c(j,i) ; 1 <= i,j,k <= dim . +! Dimensions: a(phdim,dim),b(phdim,dim),c(phdim,dim) +! +!C mmxxzz1 (a,b,c,phdim1,phdim2,phdim3,dim1,dim2,dim3) +!C Definition: a(j,k)*b(k,i) = c(j,i) . +!C Dimensions: a(phdim1,phdim2),b(phdim2,phdim3),c(phdim1,phdim3) +! +! mmaxzz (a,b,c,dim1,dim2,dim3) +! Definition: dconjg(a(k,j))*b(k,i) = c(j,i) . +! Dimensions: a(dim1,dim2),b(dim1,dim3),c(dim2,dim3) +! +! mmcxzz (a,b,c,dim1,dim2,dim3) +! Definition: dconjg(a(j,k))*b(k,i) = c(j,i) . +! Dimensions: a(dim1,dim2),b(dim2,dim3),c(dim1,dim3) +! +! qqcxzz (a,b,c,dim) +! Definition: dconjg(a(j,k))*b(k,i) = c(j,i) . +! Dimensions: a(dim,dim),b(dim,dim),c(dim,dim) +! +! mmxazz (a,b,c,dim1,dim2,dim3) +! Definition: a(j,k)*dconjg(b(i,k)) = c(j,i) . +! Dimensions: a(dim1,dim2),b(dim3,dim2),c(dim1,dim3) +! +! mmxtzza (a,b,c,dim1,dim2,dim3) +! Definition: a(j,k)*b(i,k) +c(j,i) = c(j,i) . +! Dimensions: a(dim1,dim2),b(dim3,dim2),c(dim1,dim3) +! +! mqxtzza (a,b,c,dim1,dim2) +! Definition: a(j,k)*b(i,k) +c(j,i) = c(j,i) . +! Dimensions: a(dim1,dim2),b(dim2,dim2),c(dim1,dim2) +! +! mmcazza (a,b,c,dim1,dim2,dim3) +! Definition: conjg(a(j,k))*conjg(b(i,k)) + c(j,i) = c(j,i) +! Dimensions: a(dim1,dim2),b(dim3,dim2),c(dim1,dim3/) +! +! mqxxzza (a,b,c,dim1,dim2) +! Definition: a(j,k)*b(k,i) +c(j,i) = c(j,i) . +! Dimensions: a(dim1,dim2),b(dim2,dim2),c(dim1,dim2) +! +! mqxtzd (a,b,c,dim1,dim2) +! Definition: a(j,k)*b(i,k) = c(j,i) . +! Dimensions: a(dim1,dim2),b(dim2,dim2),c(dim1,dim2) +! +! qqtxzz (a,b,c,dim) +! Definition: a(k,j)*b(k,i) = c(j,i) . +! Dimensions: a(dim,dim),b(dim,dim),c(dim,dim) +! +! mqxazz (a,b,c,dim1,dim2) +! Definition: a(j,k)*dconjg(b(i,k)) = c(j,i) . +! Dimensions: a(dim1,dim2),b(dim2,dim2),c(dim1,dim2) +! +! qmxxdz (a,b,c,dim1,dim2) +! Definition: a(j,k)*b(k,i) = c(j,i) . +! Dimensions: a(dim1,dim1),b(dim1,dim2),c(dim1,dim2) +! +! qmtxdz (a,b,c,dim1,dim2) +! Definition: a(k,j)*b(k,i) = c(j,i) . +! Dimensions: a(dim1,dim1),b(dim1,dim2),c(dim1,dim2) +! +! qqxxzz (a,b,c,dim) +! Definition: a(j,k)*b(k,i) = c(j,i) . +! Dimensions: a(dim,dim),b(dim,dim),c(dim,dim) +! +! mqxtzz (a,b,c,dim1,dim2) +! Definition: a(j,k)*b(i,k) = c(j,i) . +! Dimensions: a(dim1,dim2),b(dim2,dim2),c(dim1,dim2) +! +! mqxxzz (a,b,c,dim1,dim2) +! Definition: a(j,k)*b(k,i) = c(j,i) . +! Dimensions: a(dim1,dim2),b(dim2,dim2),c(dim1,dim2) +! +! mmtxzz (a,b,c,dim1,dim2,dim3) +! Definition: a(k,j)*b(k,i) = c(j,i) . +! Dimensions: a(dim1,dim2),b(dim1,dim3),c(dim2,dim3) +! +! mmtxzza (a,b,c,dim1,dim2,dim3) +! Definition: a(k,j)*b(k,i) + c(j,i) = c(j,i) . +! Dimensions: a(dim1,dim2),b(dim1,dim3),c(dim2,dim3) +! +! mmxczz (a,b,c,dim1,dim2,dim3) +! Definition: a(j,k)*dconjg(b(k,i)) = c(j,i) . +! Dimensions: a(dim1,dim2),b(dim2,dim3),c(dim1,dim3) +! +! mqxczz (a,b,c,dim1,dim2) +! Definition: a(j,k)*dconjg(b(k,i)) = c(j,i) . +! Dimensions: a(dim1,dim2),b(dim2,dim2),c(dim1,dim2) +! +! qqaxzz (a,b,c,dim) +! Definition: dconjg(a(k,j))*b(k,i) = c(j,i) . +! Dimensions: a(dim,dim),b(dim,dim),c(dim,dim) +! +! qqxazz (a,b,c,dim) +! Definition: a(j,k)*dconjg(b(i,k)) = c(j,i) . +! Dimensions: a(dim,dim),b(dim,dim),c(dim,dim) +! +! msqzz (a,b,dim1,dim2,dim3) +! Definition: Local control: generating vibrational wavefuntion +! Dimensions: a(dim1,dim2),b(dim1,dim2) +!*********************************************************************** + + module mmlib + + use decimal, only: dop, long + + implicit none + private + public :: qqxxdd, qqxxzd, mmxxzz, mmvxzz, mmxtzz, mmtczz, & + mmxxzza, dmxxzz, dmxxzza, dmxxdz, dmxxdd, & + ddxxdd, ddxxdz,dqxxzz, dqxxdd, dqxxdd1, dqxxdz, dqxxdz2, & + mmtxdd, mmtxdd1, mmxtdd, mmxxdd, mmxxdd1, & + qqxtdd, qqxtdd1, qqtxdd, qdxxzz, qdxxdd, qdxxdd1, & + hhxtzzc, mmaxzzh, mmaxzzh1, mmtxzzs, qmxxzz,qqxxdd1, & + mmaxzz, mmcxzz, qqcxzz, mmxazz, mmxtzza, qdxxdz, & + mmcazza, mqxxzz, mqxxzza, mqxtzd, qqtxzz, & + mqxazz, qmxxdz, qmtxdz, qqxxzz, mqxtzz, mmtxzz, & + mmtxzza, mmxczz, mqxczz, qqaxzz, qqxazz, msqzz +! mmxxdz, mmxxzz1, mqxtzza + contains + +!----------------------------------------------------------------------- +! Library subroutine qqxxdd +! +! Multiplication of two real quadratic matrices: +! a(j,k)*b(k,i) = c(j,i) +!----------------------------------------------------------------------- + + subroutine qqxxdd (a,b,c,dim) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim + real(dop), dimension(dim,dim), intent(in) :: a + real(dop), dimension(dim,dim), intent(in) :: b + real(dop), dimension(dim,dim), intent(out) :: c + + do i=1,dim + do j=1,dim + c(j,i) = a(j,1)*b(1,i) + enddo + enddo + do i = 1,dim + do k = 2,dim + do j = 1,dim + c(j,i) = c(j,i)+a(j,k)*b(k,i) + enddo + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine qqxxzd +! +! Multiplication of a complex quadratic matrix with a real quadratic +! matrix: +! a(j,k)*b(k,i) = c(j,i) +!----------------------------------------------------------------------- + + subroutine qqxxzd (a,b,c,dim) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim + real(dop), dimension(dim,dim), intent(in) :: b + complex(dop), dimension(dim,dim), intent(in) :: a + complex(dop), dimension(dim,dim), intent(out) :: c + + do i=1,dim + do j=1,dim + c(j,i) = a(j,1)*b(1,i) + enddo + enddo + do i = 1,dim + do k = 2,dim + do j = 1,dim + c(j,i) = c(j,i)+a(j,k)*b(k,i) + enddo + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine mmxxzz +! +! Multiplication of two complex rectangular matrices: +! a(j,k)*b(k,i) = c(j,i) +!----------------------------------------------------------------------- + + subroutine mmxxzz (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2, dim3 + complex(dop), dimension(dim1,dim2), intent(in) :: a + complex(dop), dimension(dim2,dim3), intent(in) :: b + complex(dop), dimension(dim1,dim3), intent(out) :: c + + do i=1,dim3 + do j=1,dim1 + c(j,i) = a(j,1)*b(1,i) + enddo + enddo + do i = 1,dim3 + do k = 2,dim2 + do j = 1,dim1 + c(j,i) = c(j,i)+a(j,k)*b(k,i) + enddo + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! subroutine mmvxzz +! +! Multiplication of two complex rectangular matrices with p fixed (uses +! first matrix as a vector): +! +! a(p,k)*b(k,i) = c(i) +!----------------------------------------------------------------------- + + subroutine mmvxzz (a,b,c,dim1,dim2,dim3,p) + + implicit none + + integer(long) :: i, p, k + integer(long), intent(in) :: dim1, dim2, dim3 + complex(dop), dimension(dim1,dim2), intent(in) :: a + complex(dop), dimension(dim2,dim3), intent(in) :: b + complex(dop), dimension(dim3), intent(out) :: c + + do i=1,dim3 + c(i) = a(p,1)*b(1,i) + enddo + do i = 1,dim3 + do k = 2,dim2 + c(i) = c(i)+a(p,k)*b(k,i) + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine mmxtzz +! +! Multiplication of a complex rectangular matrix with the transpose of +! a rectangular complex matrix +! a(j,k)*b(i,k) = c(j,i) +!----------------------------------------------------------------------- + + subroutine mmxtzz (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2, dim3 + complex(dop), dimension(dim1,dim2), intent(in) :: a + complex(dop), dimension(dim3,dim2), intent(in) :: b + complex(dop), dimension(dim1,dim3), intent(out) :: c + + do i=1,dim3 + do j=1,dim1 + c(j,i) = a(j,1)*b(i,1) + enddo + enddo + + do i = 1,dim3 + do k = 2,dim2 + do j = 1,dim1 + c(j,i) = c(j,i)+a(j,k)*b(i,k) + enddo + enddo + enddo + + return + end subroutine + + +!----------------------------------------------------------------------- +! Library subroutine mmxxzza +! +! Multiplication of a complex rectangular matrix with a rectangular +! complex matrix, the result of which is added to a further matrix. +! a(j,k)*b(k,i) +c(j,i) = c(j,i) +!----------------------------------------------------------------------- + + subroutine mmxxzza (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2, dim3 + complex(dop), dimension(dim1,dim2), intent(in) :: a + complex(dop), dimension(dim2,dim3), intent(in) :: b + complex(dop), dimension(dim1,dim3), intent(out) :: c + + do k = 1,dim2 + do i = 1,dim3 + do j = 1,dim1 + c(j,i) = c(j,i)+a(j,k)*b(k,i) + enddo + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine dmxxzz +! +! Multiplication of a diagonal complex matrix with a complex rectangular +! matrix: +! a(j)*b(j,i) = c(j,i) +!----------------------------------------------------------------------- + + subroutine dmxxzz (a,b,c,dim1,dim2) + + implicit none + + integer(long) :: i, j + integer(long), intent(in) :: dim1, dim2 + complex(dop), dimension(dim1), intent(in) :: a + complex(dop), dimension(dim1,dim2), intent(in) :: b + complex(dop), dimension(dim1,dim2), intent(out) :: c + + do i = 1,dim2 + do j = 1,dim1 + c(j,i) = a(j)*b(j,i) + enddo + enddo + + return + end subroutine + + +!----------------------------------------------------------------------- +! Library subroutine dmxxzza +! +! Multiplication of a diagonal complex matrix with a complex rectangular +! matrix: +! a(j)*b(j,i) + c(j,i) = c(j,i) +!----------------------------------------------------------------------- + + subroutine dmxxzza (a,b,c,dim1,dim2) + + implicit none + + integer(long) :: i, j + integer(long), intent(in) :: dim1, dim2 + complex(dop), dimension(dim1), intent(in) :: a + complex(dop), dimension(dim1,dim2), intent(in) :: b + complex(dop), dimension(dim1,dim2), intent(inout) :: c + + do i = 1,dim2 + do j = 1,dim1 + c(j,i) = c(j,i) + a(j)*b(j,i) + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine dmxxdz +! +! Multiplication of a diagonal real matrix with a real rectangular +! matrix: +! a(j)*b(j,i) = c(j,i) +!----------------------------------------------------------------------- + + subroutine dmxxdz (a,b,c,dim1,dim2) + + implicit none + + integer(long) :: i, j + integer(long), intent(in) :: dim1, dim2 + real(dop), dimension(dim1), intent(in) :: a + complex(dop), dimension(dim1,dim2), intent(in) :: b + complex(dop), dimension(dim1,dim2), intent(out) :: c + + do i = 1,dim2 + do j = 1,dim1 + c(j,i) = a(j)*b(j,i) + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine dmxxdd +! +! Multiplication of a diagonal real matrix with a real rectangular +! matrix: +! a(j)*b(j,i) = c(j,i) +!----------------------------------------------------------------------- + + subroutine dmxxdd (a,b,c,dim1,dim2) + + implicit none + + integer(long) :: i, j + integer(long), intent(in) :: dim1, dim2 + real(dop), dimension(dim1), intent(in) :: a + real(dop), dimension(dim1,dim2), intent(in) :: b + real(dop), dimension(dim1,dim2), intent(out) :: c + + do i = 1,dim2 + do j = 1,dim1 + c(j,i) = a(j)*b(j,i) + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine dqxxzz +! +! Multiplication of a diagonal complex matrix with a complex quadratic +! matrix: +! a(j)*b(j,i) = c(j,i) +!----------------------------------------------------------------------- + + subroutine dqxxzz (a,b,c,dim) + + implicit none + + integer(long) :: i, j + integer(long), intent(in) :: dim + complex(dop), dimension(dim), intent(in) :: a + complex(dop), dimension(dim,dim), intent(in) :: b + complex(dop), dimension(dim,dim), intent(out) :: c + + do i = 1,dim + do j = 1,dim + c(j,i) = a(j)*b(j,i) + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine ddxxdd +! +! Multiplication of a diagonal real matrix with a diagonal real matrix: +! a(j)*b(j) = c(j) +!----------------------------------------------------------------------- + + subroutine ddxxdd (a,b,c,dim) + + implicit none + + integer(long) :: j + integer(long), intent(in) :: dim + real(dop), dimension(dim), intent(in) :: a + real(dop), dimension(dim), intent(in) :: b + real(dop), dimension(dim), intent(out) :: c + + do j = 1,dim + c(j) = a(j)*b(j) + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine ddxxdz +! +! Multiplication of a diagonal real matrix with a diagonal complex matrix: +! a(j)*b(j) = c(j) +!----------------------------------------------------------------------- + + subroutine ddxxdz (a,b,c,dim) + + implicit none + + integer(long) :: j + integer(long), intent(in) :: dim + real(dop), dimension(dim), intent(in) :: a + complex(dop), dimension(dim), intent(in) :: b + complex(dop), dimension(dim), intent(out) :: c + + do j = 1,dim + c(j) = a(j)*b(j) + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine dqxxdd +! +! Multiplication of a diagonal real matrix with a real quadratic matrix: +! a(j)*b(j,i) = c(j,i) +!----------------------------------------------------------------------- + + subroutine dqxxdd (a,b,c,dim) + + implicit none + + integer(long) :: i, j + integer(long), intent(in) :: dim + real(dop), dimension(dim), intent(in) :: a + real(dop), dimension(dim,dim), intent(in) :: b + real(dop), dimension(dim,dim), intent(out) :: c + + do i = 1,dim + do j = 1,dim + c(j,i) = a(j)*b(j,i) + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine dqxxdd1 +! +! Multiplication of a diagonal real matrix with a real quadratic matrix: +! a(j)*b(j,i) = c(j,i) +! +! NB phdim is physical (leading) dimension, dim is used dimension +!----------------------------------------------------------------------- + + subroutine dqxxdd1 (a,b,c,phdim,dim) + + implicit none + + integer(long) :: i, j + integer(long), intent(in) :: dim, phdim + real(dop), dimension(dim), intent(in) :: a + real(dop), dimension(phdim,dim), intent(in) :: b + real(dop), dimension(phdim,dim), intent(out) :: c + + do i = 1,dim + do j = 1,dim + c(j,i) = a(j)*b(j,i) + enddo + enddo + + return + end subroutine + +! ---------------------------------------------------------------------- +! Library subroutine dqxxdz +! +! Multiplication of a diagonal real matrix with a complex matrix +! a(i)*v(i,j)=w(i,j) +!----------------------------------------------------------------------- + + subroutine dqxxdz (a,v,w,dim) + + implicit none + + integer(long) :: i, j + integer(long), intent(in) :: dim + real(dop), dimension(dim), intent(in) :: a + complex(dop), dimension(dim,dim), intent(in) :: v + complex(dop), dimension(dim,dim), intent(out) :: w + + do j=1,dim + do i=1,dim + w(i,j) = a(i)*v(i,j) + enddo + enddo + + return + end subroutine + + +! ---------------------------------------------------------------------- +! Library subroutine dqxxdz2 +! +! Multiplication of a diagonal real matrix with a complex matrix +! a(j)*v(i,j)=w(i,j) +!----------------------------------------------------------------------- + + subroutine dqxxdz2 (a,v,w,dim) + + implicit none + + integer(long) :: i, j + integer(long), intent(in) :: dim + real(dop), dimension(dim), intent(in) :: a + complex(dop), dimension(dim,dim), intent(in) :: v + complex(dop), dimension(dim,dim), intent(out) :: w + + do j=1,dim + do i=1,dim + w(i,j) = a(j)*v(i,j) + enddo + enddo + + return + end subroutine + + +!----------------------------------------------------------------------- +! Library subroutine mmxxdz +! +! Multiplication of a rectangular real matrix with a rectangular complex +! matrix: +! a(j,k)*b(k,i) = c(j,i) +!----------------------------------------------------------------------- + +! subroutine mmxxdz (a,b,c,dim1,dim2,dim3) + +! implicit none + +! integer(long) :: i, j, k +! integer(long), intent(in) :: dim1, dim2, dim3 +! real(dop), dimension(dim1,dim2), intent(in) :: a +! complex(dop), dimension(dim2,dim3), intent(in) :: b +! complex(dop), dimension(dim1,dim3), intent(out) :: c + +! do i=1,dim3 +! do j=1,dim1 +! c(j,i) = a(j,1)*b(1,i) +! enddo +! enddo +! do i = 1,dim3 +! do k = 2,dim2 +! do j = 1,dim1 +! c(j,i) = c(j,i)+a(j,k)*b(k,i) +! enddo +! enddo +! enddo + +! return +! end subroutine + +!----------------------------------------------------------------------- +! Library subroutine mmtxdd +! +! Multiplication of the transpose of a rectangular real matrix with a +! rectangular real matrix: +! a(k,j)*b(k,i) = c(j,i) +!----------------------------------------------------------------------- + + subroutine mmtxdd (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2, dim3 + real(dop), dimension(dim2,dim1), intent(in) :: a + real(dop), dimension(dim2,dim3), intent(in) :: b + real(dop), dimension(dim1,dim3), intent(out) :: c + + do i = 1,dim3 + do j = 1,dim1 + c(j,i) = a(1,j)*b(1,i) + do k = 2,dim2 + c(j,i) = c(j,i)+a(k,j)*b(k,i) + enddo + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine mmxtdd +! +! Multiplication of the rectangular real matrix with the transpose of a +! rectangular real matrix: +! a(j,k)*b(i,k) = c(j,i) +!----------------------------------------------------------------------- + + subroutine mmxtdd(a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2, dim3 + real(dop), dimension(dim1,dim2), intent(in) :: a + real(dop), dimension(dim3,dim2), intent(in) :: b + real(dop), dimension(dim1,dim3), intent(out) :: c + + do i = 1,dim3 + do j = 1,dim1 + c(j,i) = a(j,1)*b(i,1) + do k = 2,dim2 + c(j,i) = c(j,i)+a(j,k)*b(i,k) + enddo + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine mmtxdd1 +! +! Multiplication of the transpose of a rectangular real matrix with a +! rectangular real matrix: +! a(k,j)*b(k,i) = c(j,i) +! +! NB phdim is physical (leading) dimension, dim1-3 is used dimension +!----------------------------------------------------------------------- + + subroutine mmtxdd1 (a,b,c,phdim,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: phdim, dim1, dim2, & + dim3 + real(dop), dimension(phdim,phdim), intent(in) :: a + real(dop), dimension(phdim,phdim), intent(in) :: b + real(dop), dimension(phdim,phdim), intent(out) :: c + + do i = 1,dim3 + do j = 1,dim1 + c(j,i) = a(1,j)*b(1,i) + do k = 2,dim2 + c(j,i) = c(j,i)+a(k,j)*b(k,i) + enddo + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine mmxxdd +! +! Multiplication of two real rectangular matrices: +! a(j,k)*b(k,i) = c(j,i) +!----------------------------------------------------------------------- + + subroutine mmxxdd (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2, dim3 + real(dop), dimension(dim1,dim2), intent(in) :: a + real(dop), dimension(dim2,dim3), intent(in) :: b + real(dop), dimension(dim1,dim3), intent(out) :: c + + do i=1,dim3 + do j=1,dim1 + c(j,i) = a(j,1)*b(1,i) + enddo + enddo + do i = 1,dim3 + do k = 2,dim2 + do j = 1,dim1 + c(j,i) = c(j,i)+a(j,k)*b(k,i) + enddo + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine mmxxdd1 +! +! Multiplication of two real rectangular matrices: +! a(j,k)*b(k,i) = c(j,i) +! +! NB phdim is physical (leading) dimension, dim1-3 is used dimension +!----------------------------------------------------------------------- + + subroutine mmxxdd1 (a,b,c,phdim,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: phdim, dim1, dim2, & + dim3 + real(dop), dimension(phdim,phdim), intent(in) :: a + real(dop), dimension(phdim,phdim), intent(in) :: b + real(dop), dimension(phdim,phdim), intent(out) :: c + + do i=1,dim3 + do j=1,dim1 + c(j,i) = a(j,1)*b(1,i) + enddo + enddo + do i = 1,dim3 + do k = 2,dim2 + do j = 1,dim1 + c(j,i) = c(j,i)+a(j,k)*b(k,i) + enddo + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine qqxtdd +! +! Multiplication of a real quadratic matrix with the transpose of a real +! quadratic matrix: +! a(j,k)*b(i,k) = c(j,i) +!----------------------------------------------------------------------- + + subroutine qqxtdd (a,b,c,dim) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim + real(dop), dimension(dim,dim), intent(in) :: a + real(dop), dimension(dim,dim), intent(in) :: b + real(dop), dimension(dim,dim), intent(out) :: c + + do i = 1,dim + do j = 1,dim + c(j,i) = a(j,1)*b(i,1) + enddo + enddo + do k = 2,dim + do i = 1,dim + do j = 1,dim + c(j,i) = c(j,i)+a(j,k)*b(i,k) + enddo + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine qqxtdd1 +! +! Multiplication of a real quadratic matrix with the transpose of a real +! quadratic matrix: +! a(j,k)*b(i,k) = c(j,i) +! +! NB phdim is physical (leading) dimension, dim is used dimension +!----------------------------------------------------------------------- + + subroutine qqxtdd1 (a,b,c,phdim,dim) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: phdim, dim + real(dop), dimension(phdim,dim), intent(in) :: a + real(dop), dimension(phdim,dim), intent(in) :: b + real(dop), dimension(phdim,dim), intent(out) :: c + + do i = 1,dim + do j = 1,dim + c(j,i) = a(j,1)*b(i,1) + enddo + enddo + do k = 2,dim + do i = 1,dim + do j = 1,dim + c(j,i) = c(j,i)+a(j,k)*b(i,k) + enddo + enddo + enddo + + return + end subroutine + +! ---------------------------------------------------------------------- +! Library subroutine qqtxdd +! +! Multiplication of the transpose of a real quadratic matrix with a +! real quadratic matrix: +! a(k,j)*b(k,i) = c(j,i) +!----------------------------------------------------------------------- + + subroutine qqtxdd (a,b,c,dim) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim + real(dop), dimension(dim,dim), intent(in) :: a + real(dop), dimension(dim,dim), intent(in) :: b + real(dop), dimension(dim,dim), intent(out) :: c + + do i = 1,dim + do j = 1,dim + c(j,i) = a(1,j)*b(1,i) + do k = 2,dim + c(j,i) = c(j,i)+a(k,j)*b(k,i) + enddo + enddo + enddo + + return + end subroutine + +!---------------------------------------------------------------------- +! Library subroutine qdxxzz +! +! Multiplication of a complex quadratic matrix with a diagonal complex +! matrix: +! a(j,i)*b(i) = c(j,i) +!----------------------------------------------------------------------- + + subroutine qdxxzz (a,b,c,dim) + + implicit none + + integer(long) :: i, j + integer(long), intent(in) :: dim + complex(dop), dimension(dim,dim), intent(in) :: a + complex(dop), dimension(dim), intent(in) :: b + complex(dop), dimension(dim,dim), intent(out) :: c + + do i = 1,dim + do j = 1,dim + c(j,i) = a(j,i)*b(i) + enddo + enddo + + return + end subroutine + +!---------------------------------------------------------------------- +! Library subroutine qdxxdz +! +! Multiplication of a complex quadratic matrix with a diagonal real +! matrix: +! a(j,i)*b(i) = c(j,i) +!----------------------------------------------------------------------- + + subroutine qdxxdz (a,b,c,dim) + + implicit none + + integer(long) :: i, j + integer(long), intent(in) :: dim + real(dop), dimension(dim), intent(in) :: b + complex(dop), dimension(dim,dim), intent(in) :: a + complex(dop), dimension(dim,dim), intent(out) :: c + + do i = 1,dim + do j = 1,dim + c(j,i) = a(j,i)* b(i) + enddo + enddo + + return + end subroutine + +!---------------------------------------------------------------------- +! Library subroutine qdxxdd +! +! Multiplication of a real quadratic matrix with a diagonal real matrix: +! a(j,i)*b(i) = c(j,i) +!----------------------------------------------------------------------- + + subroutine qdxxdd (a,b,c,dim) + + implicit none + + integer(long) :: i, j + integer(long), intent(in) :: dim + real(dop), dimension(dim,dim), intent(in) :: a + real(dop), dimension(dim), intent(in) :: b + real(dop), dimension(dim,dim), intent(out) :: c + + do i = 1,dim + do j = 1,dim + c(j,i) = a(j,i)*b(i) + enddo + enddo + + return + end subroutine + +!---------------------------------------------------------------------- +! Library subroutine qdxxdd1 +! +! Multiplication of a real quadratic matrix with a diagonal real matrix: +! a(j,i)*b(i) = c(j,i) +! +! NB phdim is physical (leading) dimension, dim is used dimension +!----------------------------------------------------------------------- + + subroutine qdxxdd1 (a,b,c,phdim,dim) + + implicit none + + integer(long) :: i, j + integer(long), intent(in) :: phdim, dim + real(dop), dimension(phdim,dim), intent(in) :: a + real(dop), dimension(dim), intent(in) :: b + real(dop), dimension(phdim,dim), intent(out) :: c + + do i = 1,dim + do j = 1,dim + c(j,i) = a(j,i)*b(i) + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine hhxtzzc +! +! Multiplication of a complex hermitian matrix with the transpose of a +! complex hermitian matrix, where the two matrices commute: +! a(j,k)*b(i,k) = c(j,i) +! +! NB The fact that the two matrices commute means that the result of +! the multiplication is also hermitian +!----------------------------------------------------------------------- + + subroutine hhxtzzc (a,b,c,dim) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim + complex(dop), dimension(dim,dim), intent(in) :: a + complex(dop), dimension(dim,dim), intent(in) :: b + complex(dop), dimension(dim,dim), intent(out) :: c + + do i = 1,dim + do j = i,dim + c(j,i) = a(j,1)*b(i,1) + enddo + enddo + do k = 2,dim + do i = 1,dim + do j = i,dim + c(j,i) = c(j,i)+a(j,k)*b(i,k) + enddo + enddo + enddo + do i = 1,dim + do j = 1,i-1 + c(j,i) = dconjg(c(i,j)) + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine mmaxzzh +! +! Multiplication of the adjoint of a complex rectangular matrix with +! a rectangular complex matrix, where the result is a hermitian matrix +! dconjg(a(k,j))*b(k,i) = c(j,i) +! +! NB this routine can be used for the overlap of two sets of "spfs" in +! the same basis +!----------------------------------------------------------------------- + + subroutine mmaxzzh (a,b,c,dim1,dim2) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2 + complex(dop), dimension(dim1,dim2), intent(in) :: a + complex(dop), dimension(dim1,dim2), intent(in) :: b + complex(dop), dimension(dim2,dim2), intent(out) :: c + + do i = 1,dim2 + do j = i,dim2 + c(j,i) = dconjg(a(1,j))*b(1,i) + do k = 2,dim1 + c(j,i) = c(j,i)+dconjg(a(k,j))*b(k,i) + enddo + enddo + enddo +! +! now fill in other half of hermitian matrix +! + do i=1,dim2 + c(i,i)=dble(c(i,i)) + enddo + do i=1,dim2 + do j=1,i-1 + c(j,i)=dconjg(c(i,j)) + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine mmaxzzh1 +! +! Multiplication of the adjoint of a complex rectangular matrix with +! a rectangular complex matrix, where the result is an anti- hermitian +! matrix +! dconjg(a(k,j))*b(k,i) = c(j,i) +! +!----------------------------------------------------------------------- + + subroutine mmaxzzh1 (a,b,c,dim1,dim2) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2 + real(dop) :: x + complex(dop), dimension(dim1,dim2), intent(in) :: a + complex(dop), dimension(dim1,dim2), intent(in) :: b + complex(dop), dimension(dim2,dim2), intent(out) :: c + + do i = 1,dim2 + do j = i,dim2 + c(j,i) = dconjg(a(1,j))*b(1,i) + do k = 2,dim1 + c(j,i) = c(j,i)+dconjg(a(k,j))*b(k,i) + enddo + enddo + enddo +! +! now fill in other half of anti-hermitian matrix +! + do i=1,dim2 + x=dimag(c(i,i)) + c(i,i)=dcmplx(0.0d0,x) + enddo + do i=1,dim2 + do j=1,i-1 + c(j,i)=-dconjg(c(i,j)) + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine mmtxzzs +! +! Multiplication of a transposed complex rectangular matrix with +! a rectangular complex matrix, where the result is a symmetric matrix +! a(k,j)*b(k,i) = c(j,i) +!----------------------------------------------------------------------- + + subroutine mmtxzzs (a,b,c,dim1,dim2) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2 + complex(dop), dimension(dim1,dim2), intent(in) :: a + complex(dop), dimension(dim1,dim2), intent(in) :: b + complex(dop), dimension(dim2,dim2), intent(out) :: c + + do i = 1,dim2 + do j = i,dim2 + c(j,i) = a(1,j)*b(1,i) + do k = 2,dim1 + c(j,i) = c(j,i)+a(k,j)*b(k,i) + enddo + enddo + enddo +! +! now fill in other half of symmetric matrix +! + do i=1,dim2 + do j=1,i-1 + c(j,i)=c(i,j) + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine qmxxzz +! +! Multiplication of a complex quadratic matrix with a complex +! rectangular matrix: +! a(j,k)*b(k,i) = c(j,i) +!----------------------------------------------------------------------- + + subroutine qmxxzz (a,b,c,dim1,dim2) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2 + complex(dop), dimension(dim1,dim1), intent(in) :: a + complex(dop), dimension(dim1,dim2), intent(in) :: b + complex(dop), dimension(dim1,dim2), intent(out) :: c + + do i = 1,dim2 + do j = 1,dim1 + c(j,i) = a(j,1)*b(1,i) + enddo + enddo + do i = 1,dim2 + do k = 2,dim1 + do j = 1,dim1 + c(j,i) = c(j,i)+a(j,k)*b(k,i) + enddo + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine qqxxdd1 +! +! Multiplication of two real quadratic matrices: +! a(j,k)*b(k,i) = c(j,i) +! +! NB phdim is physical (leading) dimension, dim is used dimension +!----------------------------------------------------------------------- + + subroutine qqxxdd1 (a,b,c,phdim,dim) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: phdim, dim + real(dop), dimension(phdim,dim), intent(in) :: a + real(dop), dimension(phdim,dim), intent(in) :: b + real(dop), dimension(phdim,dim), intent(out) :: c + + do i = 1,dim + do j = 1,dim + c(j,i) = a(j,1)*b(1,i) + enddo + enddo + do i = 1,dim + do k = 2,dim + do j = 1,dim + c(j,i) = c(j,i)+a(j,k)*b(k,i) + enddo + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine mmxxzz1 +! +! Multiplication of two complex rectangular matrices: +! a(j,k)*b(k,i) = c(j,i) +! +! NB phdims are physical dimensions, dims are used dimensions +!----------------------------------------------------------------------- + +! subroutine mmxxzz1 (phdim1,phdim2,phdim3,dim1,dim2,dim3,a,b,c) + +! implicit none + +! integer(long) :: i, j, k +! integer(long), intent(in) :: phdim1, phdim2, & +! phdim3, dim1, & +! dim2, dim3 +! complex(dop), dimension(phdim1,phdim2), intent(in) :: a +! complex(dop), dimension(phdim2,phdim3), intent(in) :: b +! complex(dop). dimension(phdim1,phdim3), intent(out) :: c + +! do i = 1,dim3 +! do j = i,dim1 +! c(j,i) = a(j,1)*b(1,i) +! enddo +! enddo +! do i = 1,dim3 +! do k = 2,dim2 +! do j = 1,dim1 +! c(j,i) = c(j,i)+a(j,k)*b(k,i) +! enddo +! enddo +! enddo + +! return +! end subroutine + +!----------------------------------------------------------------------- +! Library subroutine mmaxzz +! +! Multiplication of the adjoint of a complex rectangular matrix with +! a rectangular complex matrix +! dconjg(a(k,j))*b(k,i) = c(j,i) +! +! NB this routine can be used for the overlap of two sets of vectors in +! different spf bases +!----------------------------------------------------------------------- + + subroutine mmaxzz (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2, & + dim3 + complex(dop), dimension(dim1,dim2), intent(in) :: a + complex(dop), dimension(dim1,dim3), intent(in) :: b + complex(dop), dimension(dim2,dim3), intent(out) :: c + + do i = 1,dim3 + do j = 1,dim2 + c(j,i) = dconjg(a(1,j))*b(1,i) + do k = 2,dim1 + c(j,i) = c(j,i)+dconjg(a(k,j))*b(k,i) + enddo + enddo + enddo + + return + end subroutine + + +!----------------------------------------------------------------------- +! Library subroutine mmtczz +! +! Multiplication of the transpose of a complex rectangular matrix with +! the complex conjugate of a rectangular complex matrix +! a(k,j)*dconjg(b(k,i)) = c(j,i) +! +!----------------------------------------------------------------------- + subroutine mmtczz (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2, & + dim3 + complex(dop), dimension(dim1,dim2), intent(in) :: a + complex(dop), dimension(dim1,dim3), intent(in) :: b + complex(dop), dimension(dim2,dim3), intent(out) :: c + + do i = 1,dim3 + do j = 1,dim2 + c(j,i) = a(1,j)*dconjg(b(1,i)) + do k = 2,dim1 + c(j,i) = c(j,i)+a(k,j)*dconjg(b(k,i)) + enddo + enddo + enddo + + return + end subroutine + + +!----------------------------------------------------------------------- +! Library subroutine mmaczz +! +! Multiplication of the adjoint of a complex rectangular matrix with +! a adjoint of a rectangular complex matrix +! dconjg(a(k,j))*dconjg(b(k,i)) = c(j,i) +! +! NB this routine can be used for the overlap of two sets of vectors in +! different spf bases +!----------------------------------------------------------------------- +! subroutine mmaczz (a,b,c,dim1,dim2,dim3) + +! implicit none + +! integer(long) :: i, j, k +! integer(long), intent(in) :: dim1, dim2, & +! dim3 +! complex(dop), dimension(dim1,dim2), intent(in) :: a +! complex(dop), dimension(dim1,dim3), intent(in) :: b +! complex(dop), dimension(dim2,dim3), intent(out) :: c + +! do i = 1,dim3 +! do j = 1,dim2 +! c(j,i) = dconjg(a(1,j))*dconjg(b(1,i)) +! do k = 2,dim1 +! c(j,i) = c(j,i)+dconjg(a(k,j))*dconjg(b(k,i)) +! enddo +! enddo +! enddo + +! return +! end subroutine + + +!----------------------------------------------------------------------- +! Library subroutine mmcxzz +! +! Multiplication of the adjoint of a complex rectangular matrix with +! a rectangular complex matrix +! dconjg(a(j,k))*b(k,i) = c(j,i) +! +! NB this routine can be used for the overlap of two sets of vectors in +! different spf bases +!----------------------------------------------------------------------- + subroutine mmcxzz (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2, & + dim3 + complex(dop), dimension(dim1,dim2), intent(in) :: a + complex(dop), dimension(dim2,dim3), intent(in) :: b + complex(dop), dimension(dim1,dim3), intent(out) :: c + + do i = 1,dim3 + do j = 1,dim1 + c(j,i) = dconjg(a(j,1))*b(1,i) + do k = 2,dim2 + c(j,i) = c(j,i)+dconjg(a(j,k))*b(k,i) + enddo + enddo + enddo + + return + end subroutine + + +!----------------------------------------------------------------------- +! Library subroutine qqcxzz +! +! Multiplication of the adjoint of a complex quadratic matrix with +! a quadratic complex matrix +! dconjg(a(j,k))*b(k,i) = c(j,i) +! +!----------------------------------------------------------------------- + subroutine qqcxzz (a,b,c,dim) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim + complex(dop), dimension(dim,dim), intent(in) :: a + complex(dop), dimension(dim,dim), intent(in) :: b + complex(dop), dimension(dim,dim), intent(out) :: c + + do i = 1,dim + do j = 1,dim + c(j,i) = dconjg(a(j,1))*b(1,i) + do k = 2,dim + c(j,i) = c(j,i)+dconjg(a(j,k))*b(k,i) + enddo + enddo + enddo + + return + end subroutine + + +!----------------------------------------------------------------------- +! Library subroutine mmaxzz +! +! Multiplication of the adjoint of a complex rectangular matrix with +! a rectangular complex matrix +! a(j,k)*dconjg(b(i,k)) = c(j,i) +! +! NB this routine can be used for the overlap of two sets of vectors in +! different spf bases +!----------------------------------------------------------------------- + + subroutine mmxazz (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2, & + dim3 + complex(dop), dimension(dim1,dim2), intent(in) :: a + complex(dop), dimension(dim3,dim2), intent(in) :: b + complex(dop), dimension(dim1,dim3), intent(out) :: c + + do i = 1,dim3 + do j = 1,dim1 + c(j,i) = 0.0d0 + enddo + enddo + + do i = 1,dim3 + do j = 1,dim1 + do k = 1,dim2 + c(j,i) = c(j,i)+a(j,k)*dconjg(b(i,k)) + enddo + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine mmxtzza +! +! Multiplication of a complex rectangular matrix with the transpose of +! a rectangular complex matrix, the result of which is added to a +! further matrix. +! a(j,k)*b(i,k) + c(j,i) = c(j,i) +!----------------------------------------------------------------------- + + subroutine mmxtzza (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2, & + dim3 + complex(dop), dimension(dim1,dim2), intent(in) :: a + complex(dop), dimension(dim3,dim2), intent(in) :: b + complex(dop), dimension(dim1,dim3), intent(inout) :: c + + do k = 1,dim2 + do i = 1,dim3 + do j = 1,dim1 + c(j,i) = c(j,i)+a(j,k)*b(i,k) + enddo + enddo + enddo + + return + end subroutine + + +!----------------------------------------------------------------------- +! Library subroutine mmcazza +! +! Multiplication of a conjugated complex rectangular matrix with the +! adjoint of a quadratic complex matrix, the result of which is added +! to a further rectangular matrix. +! conjg(a(j,k))*conjg(b(i,k)) + c(j,i) = c(j,i) +!----------------------------------------------------------------------- + subroutine mmcazza (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2, & + dim3 + complex(dop), dimension(dim1,dim2), intent(in) :: a + complex(dop), dimension(dim3,dim2), intent(in) :: b + complex(dop), dimension(dim1,dim3), intent(inout) :: c + + do k = 1,dim2 + do i = 1,dim3 + do j = 1,dim1 + c(j,i) = c(j,i)+conjg(a(j,k))*conjg(b(i,k)) + enddo + enddo + enddo + + return + end subroutine + + +!----------------------------------------------------------------------- +! Library subroutine mqxxzza +! +! Multiplication of a complex rectangular matrix with a quadratic +! complex matrix, the result of which is added to a further rectangular +! matrix. +! a(j,k)*b(k,i) + c(j,i) = c(j,i) +!----------------------------------------------------------------------- + + subroutine mqxxzza (a,b,c,dim1,dim2) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2 + complex(dop), dimension(dim1,dim2), intent(in) :: a + complex(dop), dimension(dim2,dim2), intent(in) :: b + complex(dop), dimension(dim1,dim2), intent(inout) :: c + + do i = 1,dim2 + do k = 1,dim2 + do j = 1,dim1 + c(j,i) = c(j,i)+a(j,k)*b(k,i) + enddo + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine mqxtzd +! +! Multiplication of a rectangular complex matrix with the transpose of +! a quadratic real matrix: +! a(j,k)*b(i,k) = c(j,i) +!----------------------------------------------------------------------- + + subroutine mqxtzd (a,b,c,dim1,dim2) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2 + real(dop), dimension(dim2,dim2), intent(in) :: b + complex(dop), dimension(dim1,dim2), intent(in) :: a + complex(dop), dimension(dim1,dim2), intent(out) :: c + + do j=1,dim1 + do i=1,dim2 + c(j,i) = a(j,1)*b(i,1) + enddo + enddo + do k=2,dim2 + do j=1,dim1 + do i=1,dim2 + c(j,i) = c(j,i)+a(j,k)*b(i,k) + enddo + enddo + enddo + + return + end subroutine + +!---------------------------------------------------------------------- +! Library subroutine qqtxzz +! +! Multiplication of the transpose of a complex quadratic matrix with a +! complex quadratic matrix: +! a(k,j)*b(k,i) = c(j,i) +!----------------------------------------------------------------------- + + subroutine qqtxzz (a,b,c,dim) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim + complex(dop), dimension(dim,dim), intent(in) :: a + complex(dop), dimension(dim,dim), intent(in) :: b + complex(dop), dimension(dim,dim), intent(out) :: c + + do i = 1,dim + do j = 1,dim + c(j,i) = a(1,j)*b(1,i) + do k = 2,dim + c(j,i) = c(j,i)+a(k,j)*b(k,i) + enddo + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine mqxazz +! +! Multiplication of a complex rectangular matrix with the adjoint of +! a quadratic complex matrix: +! a(j,k)*dconjg(b(i,k)) = c(j,i) +!----------------------------------------------------------------------- + + subroutine mqxazz (a,b,c,dim1,dim2) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2 + complex(dop), dimension(dim1,dim2), intent(in) :: a + complex(dop), dimension(dim2,dim2), intent(in) :: b + complex(dop), dimension(dim1,dim2), intent(out) :: c + + do i = 1,dim2 + do j = 1,dim1 + c(j,i) = a(j,1)*dconjg(b(i,1)) + enddo + enddo + do k = 2,dim2 + do i = 1,dim2 + do j = 1,dim1 + c(j,i) = c(j,i)+a(j,k)*dconjg(b(i,k)) + enddo + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine qmxxdz +! +! Multiplication of a quadratic real matrix with a rectangular complex +! matrix: +! a(j,k)*b(k,i) = c(j,i) +!----------------------------------------------------------------------- + + subroutine qmxxdz (a,b,c,dim1,dim2) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2 + real(dop), dimension(dim1,dim1), intent(in) :: a + complex(dop), dimension(dim1,dim2), intent(in) :: b + complex(dop), dimension(dim1,dim2), intent(out) :: c + + do i=1,dim2 + do j=1,dim1 + c(j,i) = a(j,1)*b(1,i) + enddo + enddo + do i = 1,dim2 + do k = 2,dim1 + do j = 1,dim1 + c(j,i) = c(j,i)+a(j,k)*b(k,i) + enddo + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine qmtxdz +! +! Multiplication of the transpose of a quadratic real matrix with a +! rectangular complex matrix: +! a(k,j)*b(k,i) = c(j,i) +!----------------------------------------------------------------------- + + subroutine qmtxdz (a,b,c,dim1,dim2) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2 + real(dop), dimension(dim1,dim1), intent(in) :: a + complex(dop), dimension(dim1,dim2), intent(in) :: b + complex(dop), dimension(dim1,dim2), intent(out) :: c + + do i = 1,dim2 + do j = 1,dim1 + c(j,i) = a(1,j)*b(1,i) + do k = 2,dim1 + c(j,i) = c(j,i)+a(k,j)*b(k,i) + enddo + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine qqxxzz +! +! Multiplication of two complex quadratic matrices: +! a(j,k)*b(k,i) = c(j,i) +!----------------------------------------------------------------------- + + subroutine qqxxzz (a,b,c,dim) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim + complex(dop), dimension(dim,dim), intent(in) :: a + complex(dop), dimension(dim,dim), intent(in) :: b + complex(dop), dimension(dim,dim), intent(out) :: c + + do i=1,dim + do j=1,dim + c(j,i) = a(j,1)*b(1,i) + enddo + enddo + do i = 1,dim + do k = 2,dim + do j = 1,dim + c(j,i) = c(j,i)+a(j,k)*b(k,i) + enddo + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine mqxtzz +! +! Multiplication of a complex rectangular matrix with the transpose of +! a quadratic complex matrix: +! a(j,k)*b(i,k) = c(j,i) +!----------------------------------------------------------------------- + + subroutine mqxtzz (a,b,c,dim1,dim2) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2 + complex(dop), dimension(dim1,dim2), intent(in) :: a + complex(dop), dimension(dim2,dim2), intent(in) :: b + complex(dop), dimension(dim1,dim2), intent(out) :: c + + do i = 1,dim2 + do j = 1,dim1 + c(j,i) = a(j,1)*b(i,1) + enddo + enddo + do k = 2,dim2 + do i = 1,dim2 + do j = 1,dim1 + c(j,i) = c(j,i)+a(j,k)*b(i,k) + enddo + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine mqxxzz +! +! Multiplication of a complex rectangular matrix with a quadratic +! complex matrix: +! a(j,k)*b(k,i) = c(j,i) +!----------------------------------------------------------------------- + + subroutine mqxxzz (a,b,c,dim1,dim2) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2 + complex(dop), dimension(dim1,dim2), intent(in) :: a + complex(dop), dimension(dim2,dim2), intent(in) :: b + complex(dop), dimension(dim1,dim2), intent(out) :: c + + do i = 1,dim2 + do j = 1,dim1 + c(j,i) = a(j,1)*b(1,i) + enddo + enddo + do i = 1,dim2 + do k = 2,dim2 + do j = 1,dim1 + c(j,i) = c(j,i)+a(j,k)*b(k,i) + enddo + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine mmtxzz +! +! Multiplication of a transposed complex rectangular matrix with +! a rectangular complex matrix +! a(k,j)*b(k,i) = c(j,i) +!----------------------------------------------------------------------- + + subroutine mmtxzz (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2, & + dim3 + complex(dop), dimension(dim1,dim2), intent(in) :: a + complex(dop), dimension(dim1,dim3), intent(in) :: b + complex(dop), dimension(dim2,dim3), intent(out) :: c + + do i = 1,dim3 + do j = 1,dim2 + c(j,i) = a(1,j)*b(1,i) + do k = 2,dim1 + c(j,i) = c(j,i)+a(k,j)*b(k,i) + enddo + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine mmtxzza +! +! Multiplication of a transposed complex rectangular matrix with +! a rectangular complex matrix +! a(k,j)*b(k,i) + c(j,i) = c(j,i) +!----------------------------------------------------------------------- + + subroutine mmtxzza (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2, & + dim3 + complex(dop), dimension(dim1,dim2), intent(in) :: a + complex(dop), dimension(dim1,dim3), intent(in) :: b + complex(dop), dimension(dim2,dim3), intent(inout) :: c + + do i = 1,dim3 + do j = 1,dim2 + do k = 1,dim1 + c(j,i) = c(j,i)+a(k,j)*b(k,i) + enddo + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine mmxczz +! +! Multiplication of a complex rectangular matrices with the complex +! conjugate of a rectangular matrix: +! a(j,k)*dconjg(b(k,i)) = c(j,i) +!----------------------------------------------------------------------- + + subroutine mmxczz (a,b,c,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2, & + dim3 + complex(dop), dimension(dim1,dim2), intent(in) :: a + complex(dop), dimension(dim2,dim3), intent(in) :: b + complex(dop), dimension(dim1,dim3), intent(out) :: c + + do i=1,dim3 + do j=1,dim1 + c(j,i) = a(j,1)*dconjg(b(1,i)) + enddo + enddo + do i = 1,dim3 + do k = 2,dim2 + do j = 1,dim1 + c(j,i) = c(j,i)+a(j,k)*dconjg(b(k,i)) + enddo + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine mqxczz +! +! Multiplication of a complex rectangular matrices with the complex +! conjugate of a quadratic matrix: +! a(j,k)*dconjg(b(k,i)) = c(j,i) +!----------------------------------------------------------------------- + + subroutine mqxczz (a,b,c,dim1,dim2) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim1, dim2 + complex(dop), dimension(dim1,dim2), intent(in) :: a + complex(dop), dimension(dim2,dim2), intent(in) :: b + complex(dop), dimension(dim1,dim2), intent(out) :: c + + do i=1,dim2 + do j=1,dim1 + c(j,i) = a(j,1)*dconjg(b(1,i)) + enddo + enddo + do i = 1,dim2 + do k = 2,dim2 + do j = 1,dim1 + c(j,i) = c(j,i)+a(j,k)*dconjg(b(k,i)) + enddo + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine qqaxzz +! +! Multiplication of the adjoint of a complex quadratic matrix with +! a another quadratic complex matrix +! dconjg(a(k,j))*b(k,i) = c(j,i) +! +!----------------------------------------------------------------------- + + subroutine qqaxzz (a,b,c,dim) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim + complex(dop), dimension(dim,dim), intent(in) :: a + complex(dop), dimension(dim,dim), intent(in) :: b + complex(dop), dimension(dim,dim), intent(out) :: c + + do i = 1,dim + do j = 1,dim + c(j,i) = dconjg(a(1,j))*b(1,i) + do k = 2,dim + c(j,i) = c(j,i)+dconjg(a(k,j))*b(k,i) + enddo + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine qqxazz +! +! Multiplication of a complex quadratic matrix with the adjoint of +! a another quadratic complex matrix +! a(j,k)*dconjg(b(i,k)) = c(j,i) +! +!----------------------------------------------------------------------- + + subroutine qqxazz (a,b,c,dim) + + implicit none + + integer(long) :: i, j, k + integer(long), intent(in) :: dim + complex(dop), dimension(dim,dim), intent(in) :: a + complex(dop), dimension(dim,dim), intent(in) :: b + complex(dop), dimension(dim,dim), intent(out) :: c + + do i = 1,dim + do j = 1,dim + c(j,i) = a(j,1)*dconjg(b(i,1)) + do k = 2,dim + c(j,i) = c(j,i)+a(j,k)*dconjg(b(i,k)) + enddo + enddo + enddo + + return + end subroutine + +!----------------------------------------------------------------------- +! Library subroutine msqzz +! Local control: generating vibrational wavefuntion +!----------------------------------------------------------------------- + + subroutine msqzz (a,b,dim1,dim2,dim3) + + implicit none + + integer(long) :: i, j + integer(long), intent(in) :: dim1, dim2, & + dim3 + complex(dop), dimension(dim1,dim2), intent(in) :: a + complex(dop), dimension(dim1,dim2), intent(out) :: b + + do i = 1,dim2 + do j = 1,dim1 + if (i .ne. dim3) then + b(j,i) = dcmplx(0.0d0) + else + b(j,i) = a(j,i) + endif + enddo + enddo + + + return + end subroutine + + end module mmlib Index: source/propwf/summfmod.F90 =================================================================== --- source/propwf/summfmod.F90 (revision 854) +++ source/propwf/summfmod.F90 (revision 855) @@ -224,14 +224,14 @@ ! --- LOOP OVER EACH MODE AND STATE--- -!$omp parallel do num_threads(ompthread) private(m) +! omp parallel do num_threads(ompthread) private(m) do m = 1,nmode if (complete(m)) cycle call mfsumphi1m(dtpsi(zetf(m,1)),psi(zetf(m,1)),mfsum,m, & zetf(m,1),phidim(m)) enddo -!$omp end parallel do +! omp end parallel do return Index: source/propwf/projectmod.F90 =================================================================== --- source/propwf/projectmod.F90 (revision 854) +++ source/propwf/projectmod.F90 (revision 855) @@ -173,15 +173,9 @@ ! --- APPLY (1-P)-PROJECTOR --- - if(.not.lompthread)then - call mmaxzz(psi,dtpsi,tmpovl(1,2),subdim,dim,dim) - call qqxxzz(tmpovl(1,1),tmpovl(1,2),tmpovl(1,3),dim) - call mqxxzz(psi,tmpovl(1,3),help,subdim,dim) - else - call mmaxzzomp(psi,dtpsi,tmpovl(1,2),subdim,dim,dim,ompthread) - call qqxxzzomp(tmpovl(1,1),tmpovl(1,2),tmpovl(1,3),dim,ompthread) - call mqxxzzomp(psi,tmpovl(1,3),help,subdim,dim,ompthread) - endif + call mmaxzz(psi,dtpsi,tmpovl(1,2),subdim,dim,dim) + call qqxxzz(tmpovl(1,1),tmpovl(1,2),tmpovl(1,3),dim) + call mqxxzz(psi,tmpovl(1,3),help,subdim,dim) call submxxzo1(dtpsi,help,subdim,dim) return @@ -209,8 +203,8 @@ ! --- COMPUTE ACTION OF PROJECTOR ON SINGLE-PARTICLE FUNCTIONS --- -!$omp parallel num_threads(ompthread) private(e,e1,g,overlap) if(lompthread) -!$omp do schedule(dynamic) +! $omp parallel num_threads(ompthread) private(e,e1,g,overlap) if(lompthread) +! $omp do schedule(dynamic) do e = 1,dim do e1 = 1,dim overlap=(0.0_dop,0.0_dop) @@ -222,8 +216,8 @@ enddo enddo enddo -!$omp end do -!$omp end parallel +! $omp end do +! $omp end parallel return end subroutine projector Index: source/propwf/dicht1phimod.F90 =================================================================== --- source/propwf/dicht1phimod.F90 (revision 854) +++ source/propwf/dicht1phimod.F90 (revision 855) @@ -53,8 +53,8 @@ ! --- LOOP OVER EACH MODE AND STATE--- -!$omp parallel num_threads(ompthread) -!$omp do private(m,s) +! omp parallel num_threads(ompthread) +! omp do private(m,s) do m = 1,nmode if(complete(m)) cycle @@ -62,8 +62,8 @@ call dicht1phi1ms(dtpsi(zetf(m,s)),dicht1,m,s,dim(m,s),subdim(m)) enddo enddo -!$omp end do -!$omp end parallel +! omp end do +! omp end parallel call stop_timer(tid) Index: source/propwf/mfieldsmod.F90 =================================================================== --- source/propwf/mfieldsmod.F90 (revision 854) +++ source/propwf/mfieldsmod.F90 (revision 855) @@ -13,7 +13,12 @@ use hpsimod use runpropmod use eqofmotion, only: compute_mfields_tree +use openmpmod +#ifdef OMP +use omp_lib +#endif + #ifdef MPI use mpi use mpidata @@ -84,9 +89,6 @@ integer(long), save :: tid=0 ! timer ID integer(long) :: ithr -#ifdef OMP - integer(long), external :: omp_get_thread_num, omp_get_num_threads -#endif !----------------------------------------------------------------------- ! For ML-MCTDH use different routine @@ -151,7 +153,7 @@ else #endif -!$omp parallel num_threads(ompthread) private(k,s,s1,ithr) if(lompthread) +!$omp parallel num_threads(ompthread) private(k,s,s1,ithr) if(lompthread .and. lompmfield) !$omp do schedule(dynamic) do k=k1,k2 ! GWPTRj calcs do not need potential terms @@ -190,7 +192,7 @@ #endif endif -!$omp parallel num_threads(ompthread) private(n,s,s1,ithr) if(lompthread) +!$omp parallel num_threads(ompthread) private(n,s,s1,ithr) if(lompthread .and. lompmfield) !$omp do schedule(dynamic) do n=1,nmulpot(nham) #ifdef OMP @@ -373,7 +375,7 @@ implicit none integer(long) :: zeig1,zeig2,zeig3,& - m,m1,h + m,m1,h,ithr integer(long), intent(in) :: k,s,modus complex(dop), dimension(dgldim), intent(in) :: psi,psi1 complex(dop), dimension(adim), intent(inout) :: dtpsi @@ -547,7 +549,7 @@ integer(long) :: zeig1,zeig2,& zeig3,swapzeig,& m,m1,block1,& - vdim1,h + vdim1,h,ithr integer(long), intent(in) :: k,s,s1,modus complex(dop), dimension(adim), intent(in) :: psi,psi1 complex(dop), dimension(adim), intent(inout) :: dtpsi Index: source/propwf/gaussian.f90 =================================================================== --- source/propwf/gaussian.f90 (revision 854) +++ source/propwf/gaussian.f90 (revision 855) @@ -24,6 +24,8 @@ use splinepotmod use runpropmod, only: epsgwp +use openmpmod + implicit none private public :: gdot,adot,subengwp,wkgaussian,gdot1ms,renormgwp, & @@ -124,6 +126,9 @@ ! first term Y_alpha,j = sum_l _jl +! omp parallel if(lompthread) num_threads(ompthread) & +! omp private(p1,k,temp1) +! omp do schedule(dynamic) do p1 = 2,npg1 temp1=(0.0_dop,0.0_dop) do k=1,kzahl(1) @@ -145,11 +150,13 @@ yp(p1-1,1:gwpdim(m,s))=temp1(1:gwpdim(m,s),1) enddo +! omp end do ! second term Y_alpha,j = sum_l [S^(alpha,0) S^-1 ]_jl if(.not.lcysinv) call gwpproject(gs2,projector,gwpdim1) temp1=(0.0_dop,0.0_dop) +! omp do schedule(dynamic) do k=1,kzahl(1) si=ki(k) sf=kf(k) @@ -158,6 +165,7 @@ temp1,gwpdim(m,sf),gwpdim(m,si)) endif enddo +! omp enddo call ymatrix(gdicht2,hungx,temp1,gwpdim(m,s),gwpdim(m,s)) if(lcysinv)then @@ -174,6 +182,7 @@ temp2,gwpdim1) endif +! omp do schedule(dynamic) do p1=2,npg1 ! call qqxxzz(gs2(1,1,p1,1),temp2,temp1,gwpdim1) call zgemm('N','N',gwpdim1,gwpdim1,gwpdim1,(1.0_dop,0.0_dop),& @@ -186,6 +195,8 @@ enddo enddo +! omp enddo +! omp end parallel if (allocated(ghloch)) deallocate(ghloch) Index: install/compile.cnf.def =================================================================== --- install/compile.cnf.def (revision 854) +++ install/compile.cnf.def (revision 855) @@ -64,20 +64,21 @@ export AR=ar #original flags QUANTICS_FFLAGS_DEB="-g -O -ffixed-line-length-none -frecord-marker=4 -Wall -Wsurprising -fbounds-check -DDEBUG" - QUANTICS_FFLAGS_OPT="-O2 -ffixed-line-length-none -frecord-marker=4 -march=native -funroll-loops -fomit-frame-pointer" + QUANTICS_FFLAGS_OPT="-O2 -ffixed-line-length-none -frecord-marker=4 " QUANTICS_CFLAGS="-O2" if [ "$QUANTICS_PLATFORM" = "i686" ]; then -# # on any modern x86 CPU, aligned doubles are lots faster - QUANTICS_FFLAGS_OPT=${QUANTICS_FFLAGS_OPT}" -m32 -malign-double" - QUANTICS_FFLAGS_DEB=${QUANTICS_FFLAGS_DEB}" -m32 -malign-double" - QUANTICS_CFLAGS=${QUANTICS_CFLAGS}" -m32 -malign-double" + QUANTICS_FFLAGS_OPT=${QUANTICS_FFLAGS_OPT}" -m32 " + QUANTICS_FFLAGS_DEB=${QUANTICS_FFLAGS_DEB}" -m32 " + QUANTICS_CFLAGS=${QUANTICS_CFLAGS}" -m32 " elif [ "$QUANTICS_PLATFORM" = "x86_64" ]; then + # on any modern x86 CPU, aligned doubles are lots faster # for (maybe) better performance, change "-msse2" in the following to # -march=k8 (for Opteron/AMD64) # -march=nocona (for Intel processors with EM64T) (untested!) - QUANTICS_FFLAGS_OPT=${QUANTICS_FFLAGS_OPT}" -m64 -msse2 -mfpmath=sse" + # NOTE: -march=native does not produce stable code (gfortran 4.8.5) + QUANTICS_FFLAGS_OPT=${QUANTICS_FFLAGS_OPT}" -m64 -malign-double -msse2 -mfpmath=sse" QUANTICS_FFLAGS_DEB=${QUANTICS_FFLAGS_DEB}" -m64" - QUANTICS_CFLAGS=${QUANTICS_CFLAGS}" -m64" + QUANTICS_CFLAGS=${QUANTICS_CFLAGS}" -m64 -malign-double" fi if [ "$QUANTICS_COMPILE_PARA" = "omp" ]; then QUANTICS_FFLAGS_OPT=${QUANTICS_FFLAGS_OPT}" -fopenmp -DOMP" @@ -85,6 +86,9 @@ elif [ "$QUANTICS_COMPILE_PARA" = "mpi" ]; then QUANTICS_FFLAGS_OPT=${QUANTICS_FFLAGS_OPT}" -DMPI" QUANTICS_FFLAGS_DEB=${QUANTICS_FFLAGS_DEB}" -DMPI" + else + QUANTICS_FFLAGS_OPT=${QUANTICS_FFLAGS_OPT}" -funroll-loops -fomit-frame-pointer" + QUANTICS_FFLAGS_DEB=${QUANTICS_FFLAGS_DEB}" " fi # select endedness if [ "$QUANTICS_COMPILE_END" = "little" ]; then Index: install/Makefile =================================================================== --- install/Makefile (revision 854) +++ install/Makefile (revision 855) @@ -476,13 +476,10 @@ $(LIB_LA)($(PATH_LINEAR)/lineq_cg.o) \ $(LIB_LA)($(PATH_LINEAR)/lineq.o) \ $(LIB_LA)($(PATH_LINEAR)/mmlib.o) \ - $(LIB_LA)($(PATH_LINEAR)/mmomplib.o) \ $(LIB_LA)($(PATH_LINEAR)/mtlib.o) \ - $(LIB_LA)($(PATH_LINEAR)/mtomplib.o) \ $(LIB_LA)($(PATH_LINEAR)/op1lib.o) \ $(LIB_LA)($(PATH_LINEAR)/op2lib.o) \ $(LIB_LA)($(PATH_LINEAR)/rmlib.o) \ - $(LIB_LA)($(PATH_LINEAR)/rmomplib.o) \ $(LIB_LA)($(PATH_LINEAR)/sdlib.o) \ $(LIB_LA)($(PATH_LINEAR)/ttlib.o) \ $(LIB_LA)($(PATH_LINEAR)/xvlib.o) \ Index: elk_inputs/test23.inp =================================================================== --- elk_inputs/test23.inp (revision 854) +++ elk_inputs/test23.inp (revision 855) @@ -5,7 +5,7 @@ RUN-SECTION name = test23 overwrite propagate tfinal=250.0 tout= 5.0 tpsi= 10.0 -psi=double auto gridpop +psi=double auto gridpop end-run-section OPERATOR-SECTION