sample collections
findloc
We need dim=1 for gfortran (why?)
ik3= findloc(kk3,value=kkk3(3),dim=1)
nn2 = findloc([(rsmh2(i,j)>0d0,i=1,nnx)],value=.true.,dim=1,back=.true.)
ispec(j)= findloc([(trim(alabl)==trim(slabl(i)),i=1,nspec)],dim=1,value=.true.)
iout= findloc([(a(i)>0,i=1,iin)],dim=1,value=.true.,back=.true.)-1
reshape
zmelc = reshape(dconjg(zmel),shape=shape(zmelc),order=[3,2,1])
zsec= zsec+ matmul(reshape(zmelcww,[ntqxx,nm]),reshape(&
reshape(zmel,shape=[ns2-ns1+1,ngb,ntqxx],order=[2,1,3]), [nm,ntqxx]))
GPU supports reshape
count
nt0 = count(ekc<ef)
noccx(0:3) = count( ek_(1:nband, 0:3)<efermi,dim=1)
merge
itini= merge(max(ns1,nt0m+1), ns1, mask= omg>=ef)
source
mmm='abc'
allocate(farg,source=trim(mmm))
concurrent,forall
do concurrent (i2 = 1:mnl(ic),i1 = 1:mnl(ic))
...
forall(itp=lbound(zsec,1):ubound(zsec,1)) zsec(itp,itp)=1d0)
associate
do io1 = 1, norb; if(blks(io1)==0) cycle
associate(k1=>ktab(io1),nlm11 => ltab(io1)**2+1)
sumh = sumh+sum([( &
sum(qhh(k1,k2,ilm1,nlm21:nlm22,:)*ppihhz(k1,k2,ilm1,nlm21:nlm22,:)) &
,ilm1=nlm11,nlm11+blks(io1)-1) ])
do ilm1 = nlm11, nlm11+ blks(io1)-1
if( nlm21<= ilm1 .and. ilm1<=nlm21+blks(io2)-1) then
sumt = sumt + sum(qhh(k1,k2,ilm1,ilm1,:)*tauhh(k1,k2,ll(ilm1),:))
sumq = sumq + sum(qhh(k1,k2,ilm1,ilm1,:)*sighh(k1,k2,ll(ilm1),:))
endif
enddo
endassociate
enddo
array constructor
[(transpose(aaa(itpp)),itpp=lbound(zmel,3),ubound(zmel,3))]
pointer array
...
use m_struc_def
type(s_rv1) :: rhoat(3,natom)
...
do i=1,natom
allocate(rhoat(1,i)%v(1:nr(i))) !nrは動経方向のメッシュサイズ
allocate(rhoat(2,i)%v(1:nr(i)))
allocate(rhoat(3,i)%v(1:nr(i)))
enddo
When we use -----------------
associate(v1=>rhoat(1,i)%v)
associate(v2=>rhoat(2,i)%v)
...
!========================
module m_struc_def
type s_rv1
real(8),allocatable:: v(:)
endtype s_rv1
...
intent
module m_rotwave
public:: rotmto,rotmto2,rotipw,rotipw2,rotwvigg
contains
!!------------------------------------------------------
subroutine rotwvigg(igg,q,qtarget,ndimh,napw_in,nband,evec,evecout,ierr)
implicit none
intent(in):: igg,q,qtarget,ndimh,napw_in,nband,evec
intent(out):: evecout,ierr
...
Here nrecs is a module variable
...
subroutine gtv2_setrcd(recrdin)
character(len=*):: recrdin(:)
nrecs = size(recrdin)
reclnr= len(recrdin(1)) !write(6,*)nrecs,reclnr
allocate(character(reclnr)::recrd(nrecs))
recrd=recrdin
end subroutine gtv2_setrcd
Example of How to use a module
module m_igv2x !Return G vectors (integer sets) for given q points specifiec by qplist(:,iq)
use m_struc_def,only: s_nv2
public:: m_igv2xall_init, m_igv2x_setiq
integer,protected,pointer,public :: igv2x(:,:)
integer,protected,pointer,public :: napw,ndimh,ndimhx
integer,allocatable,target,protected,public:: ndimhall(:)
private
integer,protected,private,target ::napw_z,ndimh_z,ndimhx_z
type(s_nv2),allocatable,target,protected,private:: igv2xall(:)
integer,allocatable,target,protected,private:: napwall(:),ndimhxall(:),igv2x_z(:,:)
logical,private:: init=.true.
contains
subroutine m_Igv2x_setiq(iq) ! Return G vectors for given qplist(:,iq)
integer:: iq
napw => napwall(iq)
ndimh => ndimhall(iq) !nlmto+napw
ndimhx=> ndimhxall(iq) !nlmto+napw (but x2 when SO=1)
igv2x => igv2xall(iq)%nv2
end subroutine m_Igv2x_setiq
subroutine m_igv2xall_init(iqini,iqend) !initialization for qplist(iqini:iqend)
use m_qplist,only: qplist
use m_MPItk,only: master_mpi,procid,master
integer:: iqini,iqend,iq
...
Example of matrix inversion
subroutine matinv(n,a)
implicit none
integer :: n, info, ipiv(n)
real(8):: a(n,n)
real(8):: work(n*n)
call dgetrf(n,n,a,n,ipiv,info)
if(info/=0) then
print *,' matinv: degtrf info=',info
call exit(-1) !rx( ' matinv: degtrf ')
endif
call dgetri(n,a,n,ipiv,work,n*n,info)
deallocate(work)
if(info/=0) then
print *,'matinv: degtri info=',info
call exit(-1) !rx( 'matinv: degtri ')
endif
end subroutine matinv
（rx is a home-made function to do exit(-1)）
example of three point interpolation
do concurrent(it=itini:itend) ! nt0p corresponds to efp
...
associate(x=>we_(it,itp),xi=>freq_r(ixs-1:ixs+1))!x=>we_ is \omega_\epsilon in Eq.(55).
amat(1:3,1)= 1d0
amat(1:3,2)= xi(1:3)**2
amat(1:3,3)= xi(1:3)**4
wgt3(:,it,itp)= matmul([1d0,x**2,x**4], inverse33(amat))
endassociate
where
pure function inverse33(matrix) result(inverse) !Inverse of 3X3 matrix
implicit none
real(8),intent(in) :: matrix(3,3)
real(8) :: inverse(3,3), det
inverse(:,1)= crossf(matrix(:,2),matrix(:,3))
inverse(:,2)= crossf(matrix(:,3),matrix(:,1))
inverse(:,3)= crossf(matrix(:,1),matrix(:,2))
det = sum(matrix(:,1)*inverse(:,1))
inverse = transpose(inverse)
inverse = inverse/det
end function inverse33
pure function crossf(a,b) result(c)
implicit none
intent(in):: a,b
real(8):: a(3),b(3),c(3)
c(1)=a(2)*b(3)-a(3)*b(2)
c(2)=a(3)*b(1)-a(1)*b(3)
c(3)=a(1)*b(2)-a(2)*b(1)
end function crossf
compile option
### Make.ifort.inc
FC = mpiifort
LK = mpiifort
LIBMATH= -mkl
LIBLOC = ${LIBMATH}
LKFLAGS2 = $(LIBMATH)
# -check -traceback -debug extended
module = -module $(moddir)
FFLAGS = -O2 -init:snan $(module)
FFLAGS_LESS = -O0 -init:snan $(module)
FFLAGS_NONE = -O0 -init:snan $(module)
#FFLAGS = -O2 -traceback -init:snan $(module)
#FFLAGS_LESS = -O0 -traceback -init:snan $(module)
#FFLAGS_NONE = -O0 -traceback -init:snan $(module)
### conditional compile to avoid compilar bug for ucgw 2023feb ifort 18.0.5.274
$(obj_path)/m_qplist.o: $(subr)m_qplist.f90
$(FC) $(FFLAGS_NONE) -c $< -o $@
ifort
NaN initializaion is safer
### for gfortran ###
mpif90 -Wsurprising -Wmaybe-uninitialized -O2 -g -fimplicit-none -finit-integer=NaN -finit-real=NaN -JOBJ.gfortran -IOBJ.gfortran -c ../main/qg4gw.m.f90 -o OBJ.gfortran/qg4gw.m.o